+++ /dev/null
-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
+++ /dev/null
-(* 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 ()
-;;
+++ /dev/null
-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>
+++ /dev/null
-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/
+++ /dev/null
-export SHELL=/bin/bash
-
-include ../Makefile.defs
-
-NULL =
-H=@
-
-OCAML_FLAGS = -pp $(CAMLP4O)
-PKGS = -package "$(MATITA_REQUIRES)"
-CPKGS = -package "$(MATITA_CREQUIRES)"
-OCAML_THREADS_FLAGS = -thread
-OCAML_DEBUG_FLAGS = -g
-OCAMLC_FLAGS = $(OCAML_FLAGS) $(OCAML_THREADS_FLAGS)
-OCAMLC = $(OCAMLFIND) ocamlc $(OCAMLC_FLAGS) $(OCAML_DEBUG_FLAGS)
-OCAMLOPT = $(OCAMLFIND) opt $(OCAMLC_FLAGS)
-OCAMLDEP = $(OCAMLFIND) ocamldep $(OCAML_FLAGS)
-
-MATITA_FLAGS = -noprofile
-NODB=false
-ifeq ($(NODB),true)
- MATITA_FLAGS += -nodb
-endif
-
-# objects for matita (GTK GUI)
-CMOS = \
- buildTimeConf.cmo \
- matitaTypes.cmo \
- matitaMisc.cmo \
- matitamakeLib.cmo \
- matitaInit.cmo \
- matitaExcPp.cmo \
- matitaEngine.cmo \
- matitacLib.cmo \
- matitaScript.cmo \
- matitaGeneratedGui.cmo \
- matitaGtkMisc.cmo \
- applyTransformation.cmo \
- matitaMathView.cmo \
- matitaGui.cmo \
- $(NULL)
-# objects for matitac (batch compiler)
-CCMOS = \
- buildTimeConf.cmo \
- matitaTypes.cmo \
- matitaMisc.cmo \
- matitamakeLib.cmo \
- matitaInit.cmo \
- matitaExcPp.cmo \
- matitaEngine.cmo \
- matitacLib.cmo \
- $(NULL)
-MAINCMOS = \
- matitadep.cmo \
- matitaclean.cmo \
- matitamake.cmo \
- $(NULL)
-PROGRAMS_BYTE = matita matitac cicbrowser matitadep matitaclean matitamake dump_moo
-PROGRAMS = $(PROGRAMS_BYTE) matitatop
-PROGRAMS_OPT = $(patsubst %,%.opt,$(PROGRAMS_BYTE))
-
-.PHONY: all
-all: $(PROGRAMS)
-# all: matita.conf.xml $(PROGRAMS) coq.moo
-
-# matita.conf.xml: matita.conf.xml.sample
-# @if diff matita.conf.xml.sample matita.conf.xml 1>/dev/null 2>/dev/null; then\
-# touch matita.conf.xml;\
-# else\
-# echo;\
-# echo "matita.conf.xml.sample is newer than matita.conf.xml";\
-# echo;\
-# echo "PLEASE update your configuration file!";\
-# echo "(copying matita.conf.xml.sample should work)";\
-# echo;\
-# false;\
-# fi
-
-# coq.moo: library/legacy/coq.ma matitac
-# ./matitac $(MATITA_FLAGS) $<
-# coq.moo.opt: library/legacy/coq.ma matitac.opt
-# ./matitac.opt $(MATITA_FLAGS) $<
-
-ifeq ($(HAVE_OCAMLOPT),yes)
-
-CMXS = $(patsubst %.cmo,%.cmx,$(CMOS))
-CCMXS = $(patsubst %.cmo,%.cmx,$(CCMOS))
-MAINCMXS = $(patsubst %.cmo,%.cmx,$(MAINCMOS))
-LIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(MATITA_REQUIRES))
-LIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(MATITA_REQUIRES))
-CLIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(MATITA_CREQUIRES))
-CLIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(MATITA_CREQUIRES))
-.PHONY: opt
-opt: $(PROGRAMS_OPT) coq.moo.opt
-.PHONY: upx
-upx: $(PROGRAMS_UPX) coq.moo.opt
-
-else
-
-opt:
- @echo "Native code compilation is disabled"
-
-endif
-
-matita: matita.ml $(LIB_DEPS) $(CMOS)
- @echo "OCAMLC $<"
- $(H)$(OCAMLC) $(PKGS) -linkpkg -o $@ $(CMOS) matita.ml
-matita.opt: matita.ml $(LIBX_DEPS) $(CMXS)
- @echo "OCAMLOPT $<"
- $(H)$(OCAMLOPT) $(PKGS) -linkpkg -o $@ $(CMXS) matita.ml
-
-dump_moo: dump_moo.ml buildTimeConf.cmo
- @echo "OCAMLC $<"
- $(H)$(OCAMLC) $(PKGS) -linkpkg -o $@ buildTimeConf.cmo $<
-dump_moo.opt: dump_moo.ml buildTimeConf.cmx
- @echo "OCAMLOPT $<"
- $(H)$(OCAMLOPT) $(PKGS) -linkpkg -o $@ buildTimeConf.cmx $<
-
-matitac: matitac.ml $(CLIB_DEPS) $(CCMOS) $(MAINCMOS)
- @echo "OCAMLC $<"
- $(H)$(OCAMLC) $(CPKGS) -linkpkg -o $@ $(CCMOS) $(MAINCMOS) matitac.ml
-matitac.opt: matitac.ml $(CLIBX_DEPS) $(CCMXS) $(MAINCMXS)
- @echo "OCAMLOPT $<"
- $(H)$(OCAMLOPT) $(CPKGS) -linkpkg -o $@ $(CCMXS) $(MAINCMXS) matitac.ml
-
-matitatop: matitatop.ml $(CLIB_DEPS) $(CCMOS)
- @echo "OCAMLC $<"
- $(H)$(OCAMLC) $(CPKGS) -linkpkg -o $@ toplevellib.cma $(CCMOS) $<
-
-matitadep: matitac
- @test -f $@ || ln -s $< $@
-matitadep.opt: matitac.opt
- @test -f $@ || ln -s $< $@
-
-matitaclean: matitac
- @test -f $@ || ln -s $< $@
-matitaclean.opt: matitac.opt
- @test -f $@ || ln -s $< $@
-
-matitamake: matitac
- @test -f $@ || ln -s $< $@
-matitamake.opt: matitac.opt
- @test -f $@ || ln -s $< $@
-
-cicbrowser: matita
- @test -f $@ || ln -s $< $@
-cicbrowser.opt: matita.opt
- @test -f $@ || ln -s $< $@
-
-matitaGeneratedGui.ml matitaGeneratedGui.mli: matita.glade
- $(LABLGLADECC) -embed $< > matitaGeneratedGui.ml
- $(OCAMLC) $(PKGS) -i matitaGeneratedGui.ml > matitaGeneratedGui.mli
-
-.PHONY: clean
-clean:
- rm -rf *.cma *.cmo *.cmi *.cmx *.cmxa *.a *.o \
- $(PROGRAMS) \
- $(PROGRAMS_OPT) \
- $(PROGRAMS_STATIC) \
- $(PROGRAMS_UPX) \
- $(NULL)
-
-TEST_DIRS = \
- library \
- tests \
- tests/bad_tests \
- contribs/LAMBDA-TYPES \
- contribs/PREDICATIVE-TOPOLOGY \
- $(NULL)
-
-.PHONY: tests tests.opt cleantests cleantests.opt
-tests: $(foreach d,$(TEST_DIRS),$(d)-test)
-tests.opt: $(foreach d,$(TEST_DIRS),$(d)-test-opt)
-cleantests: $(foreach d,$(TEST_DIRS),$(d)-cleantests)
-cleantests.opt: $(foreach d,$(TEST_DIRS),$(d)-cleantests-opt)
-
-%-test: matitac matitadep matitaclean coq.moo
- -cd $* && make -k clean all
-%-test-opt: matitac.opt matitadep.opt matitaclean.opt coq.moo.opt
- -cd $* && make -k clean.opt opt
-%-cleantests: matitaclean
- -cd $* && make clean
-%-cleantests-opt: matitaclean.opt
- -cd $* && make clean.opt
-
-# {{{ Distribution stuff
-
-ifeq ($(wildcard matitac.opt),matitac.opt)
-BEST=opt
-else
-BEST=all
-endif
-
-stdlib:
- MATITA_RT_BASE_DIR=`pwd` \
- MATITA_FLAGS="-system -conffile `pwd`/matita.conf.xml.build" \
- ./matitamake -init build_stdlib
-
-# MATITA_RT_BASE_DIR=`pwd` \
- $(MAKE) MATITA_FLAGS="-system -conffile `pwd`/matita.conf.xml.build" -C library/ $(BEST)
-
-DEST = @RT_BASE_DIR@
-INSTALL_STUFF = \
- icons/ \
- matita.gtkrc \
- matita.lang \
- matita.ma.templ \
- core_notation.moo \
- matita.conf.xml \
- closed.xml \
- gtkmathview.matita.conf.xml \
- template_makefile.in \
- library/ \
- $(PROGRAMS_BYTE) \
- $(NULL)
-ifeq ($(HAVE_OCAMLOPT),yes)
-INSTALL_STUFF += $(PROGRAMS_OPT)
-endif
-
-install:
- install -d $(DEST)
- cp -a .matita/
- cp -a $(INSTALL_STUFF) $(DEST)
-uninstall:
-
-STATIC_LINK = dist/static_link/static_link
-# for matita
-STATIC_LIBS = \
- t1 t1x \
- gtkmathview_gmetadom mathview mathview_backend_gtk mathview_frontend_gmetadom \
- gtksourceview-1.0 \
- gdome gmetadom_gdome_cpp_smart \
- stdc++ \
- mysqlclient \
- expat \
- $(NULL)
-STATIC_EXTRA_LIBS = -cclib -lt1x -cclib -lstdc++
-# for matitac & co
-STATIC_CLIBS = \
- gdome \
- mysqlclient \
- $(NULL)
-STATIC_EXTRA_CLIBS =
-PROGRAMS_STATIC = $(patsubst %,%.static,$(PROGRAMS_OPT))
-PROGRAMS_UPX = $(patsubst %,%.upx,$(PROGRAMS_STATIC))
-
-ifeq ($(HAVE_OCAMLOPT),yes)
-static: $(STATIC_LINK) $(PROGRAMS_STATIC) coq.moo.opt
-else
-upx:
- @echo "Native code compilation is disabled"
-static:
- @echo "Native code compilation is disabled"
-endif
-
-$(STATIC_LINK):
- $(MAKE) -C dist/ $(STATIC_LINK)
-
-matita.opt.static: $(STATIC_LINK) $(LIBX_DEPS) $(CMXS) matita.ml
- $(STATIC_LINK) $(STATIC_LIBS) -- \
- $(OCAMLOPT) $(PKGS) -linkpkg -o $@ $(CMXS) matita.ml \
- $(STATIC_EXTRA_LIBS)
- strip $@
-dump_moo.opt.static: $(STATIC_LINK) buildTimeConf.cmx dump_moo.ml
- $(STATIC_LINK) $(STATIC_CLIBS) -- \
- $(OCAMLOPT) $(PKGS) -linkpkg -o $@ $^ \
- $(STATIC_EXTRA_CLIBS)
- strip $@
-matitac.opt.static: $(STATIC_LINK) $(CLIBX_DEPS) $(CCMXS) $(MAINCMXS) matitac.ml
- $(STATIC_LINK) $(STATIC_CLIBS) -- \
- $(OCAMLOPT) $(CPKGS) -linkpkg -o $@ $(CCMXS) $(MAINCMXS) matitac.ml \
- $(STATIC_EXTRA_CLIBS)
- strip $@
-matitadep.opt.static: matitac.opt.static
- @test -f $@ || ln -s $< $@
-matitaclean.opt.static: matitac.opt.static
- @test -f $@ || ln -s $< $@
-matitamake.opt.static: matitac.opt.static
- @test -f $@ || ln -s $< $@
-cicbrowser.opt.static: matita.opt.static
- @test -f $@ || ln -s $< $@
-cicbrowser.opt.static.upx: matita.opt.static.upx
- @test -f $@ || ln -s $< $@
-
-.PHONY: distclean
-distclean: clean
- $(MAKE) -C dist/ clean
- rm -f matitaGeneratedGui.ml matitaGeneratedGui.mli
- rm -f buildTimeConf.ml
- rm -f matita.glade.bak matita.gladep.bak
- rm -f matita.conf.xml.sample
-
-%.upx: %
- cp $< $@
- strip $@
- upx $@
-
-# }}} End of distribution stuff
-
-tags: TAGS
-.PHONY: TAGS
-TAGS:
- cd ..; otags -vi -r ocaml/ matita/
-
-#.depend: matitaGeneratedGui.ml matitaGeneratedGui.mli *.ml *.mli
-
-.PHONY: depend
-depend:
- $(OCAMLDEP) *.ml *.mli > .depend
-
-include .depend
-
-%.cmi: %.mli
- @echo "OCAMLC $<"
- $(H)$(OCAMLC) $(PKGS) -c $<
-%.cmo %.cmi: %.ml
- @echo "OCAMLC $<"
- $(H)$(OCAMLC) $(PKGS) -c $<
-%.cmx: %.ml
- @echo "OCAMLOPT $<"
- $(H)$(OCAMLOPT) $(PKGS) -c $<
-%.annot: %.ml
- @echo "OCAMLC -dtypes $<"
- $(H)$(OCAMLC) -dtypes $(PKGS) -c $<
-
-$(CMOS): $(LIB_DEPS)
-$(CMOS:%.cmo=%.cmx): $(LIBX_DEPS)
-
-ifeq ($(MAKECMDGOALS),all)
- $(CMOS:%.cmo=%.cmi): $(LIB_DEPS)
-endif
-ifeq ($(MAKECMDGOALS),)
- $(CMOS:%.cmo=%.cmi): $(LIB_DEPS)
-endif
-ifeq ($(MAKECMDGOALS),opt)
- $(CMOS:%.cmo=%.cmi): $(LIBX_DEPS)
-endif
-
-# vim: set foldmethod=marker:
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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)))
-
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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 *)
-
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-let debug = @DEBUG@;;
-let version = "@MATITA_VERSION@";;
-let undo_history_size = 10;;
-let console_history_size = 100;;
-let browser_history_size = 100;;
-let base_uri = "cic:/matita";;
-let phrase_sep = ".";;
-let blank_uri = "about:blank";;
-let current_proof_uri = "about:current_proof";;
-let default_font_size = 10;;
-let script_font = "Monospace";;
-
- (** may be overridden with MATITA_RT_BASE_DIR environment variable, useful for
- * binary distribution installed in user home directories *)
-let runtime_base_dir =
- try
- Sys.getenv "MATITA_RT_BASE_DIR"
- with Not_found -> "@RT_BASE_DIR@";;
-
-let images_dir = runtime_base_dir ^ "/icons"
-let gtkrc_file = runtime_base_dir ^ "/matita.gtkrc"
-let lang_file = runtime_base_dir ^ "/matita.lang"
-let script_template = runtime_base_dir ^ "/matita.ma.templ"
-let core_notation_script = runtime_base_dir ^ "/core_notation.moo"
-let matita_conf = runtime_base_dir ^ "/matita.conf.xml"
-let closed_xml = runtime_base_dir ^ "/closed.xml"
-let gtkmathview_conf = runtime_base_dir ^ "/gtkmathview.matita.conf.xml"
-let matitamake_makefile_template = runtime_base_dir ^ "/template_makefile.in"
-let stdlib_dir = runtime_base_dir ^ "/library"
-
+++ /dev/null
-(* Copyright (C) 2006, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-val base_uri : string
-val blank_uri : string
-val browser_history_size : int
-val closed_xml : string
-val console_history_size : int
-val core_notation_script : string
-val current_proof_uri : string
-val debug : bool
-val default_font_size : int
-val gtkmathview_conf : string
-val gtkrc_file : string
-val images_dir : string
-val lang_file : string
-val matita_conf : string
-val matitamake_makefile_template : string
-val phrase_sep : string
-val runtime_base_dir : string
-val script_font : string
-val script_template : string
-val stdlib_dir : string
-val undo_history_size : int
-val version : string
-
+++ /dev/null
-<?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>
+++ /dev/null
-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
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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))).
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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
-}.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-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
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
-
-
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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 [].
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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}}}.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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 }.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-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 }.
+++ /dev/null
-<?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>
+++ /dev/null
-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 $< > $@
+++ /dev/null
-#!/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
-
+++ /dev/null
-all: static_link
-static_link: static_link.ml
- ocamlfind ocamlc -package unix,str -linkpkg -o $@ $<
-clean:
- rm -f static_link.cm* static_link
+++ /dev/null
-
-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 ()
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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)
-
+++ /dev/null
-<?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>
+++ /dev/null
-<?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>
+++ /dev/null
-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
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* __ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||M|| *)
-(* ||A|| A project by Andrea Asperti *)
-(* ||T|| *)
-(* ||I|| Developers: *)
-(* ||T|| The HELM team. *)
-(* ||A|| http://helm.cs.unibo.it *)
-(* \ / *)
-(* \ / This file is distributed under the terms of the *)
-(* v GNU General Public License Version 2 *)
-(* *)
-(**************************************************************************)
-
-set "baseuri" "cic:/matita/algebra/groups/".
-
-include "algebra/monoids.ma".
-include "nat/le_arith.ma".
-include "datatypes/bool.ma".
-include "nat/compare.ma".
-
-record PreGroup : Type ≝
- { premonoid:> PreMonoid;
- opp: premonoid -> premonoid
- }.
-
-record isGroup (G:PreGroup) : Prop ≝
- { is_monoid: isMonoid G;
- opp_is_left_inverse: is_left_inverse (mk_Monoid ? is_monoid) (opp G);
- opp_is_right_inverse: is_right_inverse (mk_Monoid ? is_monoid) (opp G)
- }.
-
-record Group : Type ≝
- { pregroup:> PreGroup;
- group_properties:> isGroup pregroup
- }.
-
-(*notation < "G"
-for @{ 'monoid $G }.
-
-interpretation "Monoid coercion" 'monoid G =
- (cic:/matita/algebra/groups/monoid.con G).*)
-
-notation < "G"
-for @{ 'type_of_group $G }.
-
-interpretation "Type_of_group coercion" 'type_of_group G =
- (cic:/matita/algebra/groups/Type_of_Group.con G).
-
-notation < "G"
-for @{ 'magma_of_group $G }.
-
-interpretation "magma_of_group coercion" 'magma_of_group G =
- (cic:/matita/algebra/groups/Magma_of_Group.con G).
-
-notation "hvbox(x \sup (-1))" with precedence 89
-for @{ 'gopp $x }.
-
-interpretation "Group inverse" 'gopp x =
- (cic:/matita/algebra/groups/opp.con _ x).
-
-definition left_cancellable ≝
- λT:Type. λop: T -> T -> T.
- ∀x. injective ? ? (op x).
-
-definition right_cancellable ≝
- λT:Type. λop: T -> T -> T.
- ∀x. injective ? ? (λz.op z x).
-
-theorem eq_op_x_y_op_x_z_to_eq:
- ∀G:Group. left_cancellable G (op G).
-intros;
-unfold left_cancellable;
-unfold injective;
-intros (x y z);
-rewrite < (e_is_left_unit ? (is_monoid ? (group_properties G)));
-rewrite < (e_is_left_unit ? (is_monoid ? (group_properties G)) z);
-rewrite < (opp_is_left_inverse ? (group_properties G) x);
-rewrite > (associative ? (is_semi_group ? (is_monoid ? (group_properties G))));
-rewrite > (associative ? (is_semi_group ? (is_monoid ? (group_properties G))));
-apply eq_f;
-assumption.
-qed.
-
-
-theorem eq_op_x_y_op_z_y_to_eq:
- ∀G:Group. right_cancellable G (op G).
-intros;
-unfold right_cancellable;
-unfold injective;
-simplify;fold simplify (op G);
-intros (x y z);
-rewrite < (e_is_right_unit ? (is_monoid ? (group_properties G)));
-rewrite < (e_is_right_unit ? (is_monoid ? (group_properties G)) z);
-rewrite < (opp_is_right_inverse ? (group_properties G) x);
-rewrite < (associative ? (is_semi_group ? (is_monoid ? (group_properties G))));
-rewrite < (associative ? (is_semi_group ? (is_monoid ? (group_properties G))));
-rewrite > H;
-reflexivity.
-qed.
-
-
-record finite_enumerable (T:Type) : Type ≝
- { order: nat;
- repr: nat → T;
- index_of: T → nat;
- index_of_sur: ∀x.index_of x ≤ order;
- index_of_repr: ∀n. n≤order → index_of (repr n) = n;
- repr_index_of: ∀x. repr (index_of x) = x
- }.
-
-notation "hvbox(C \sub i)" with precedence 89
-for @{ 'repr $C $i }.
-
-(* CSC: multiple interpretations in the same file are not considered in the
- right order
-interpretation "Finite_enumerable representation" 'repr C i =
- (cic:/matita/algebra/groups/repr.con C _ i).*)
-
-notation < "hvbox(|C|)" with precedence 89
-for @{ 'card $C }.
-
-interpretation "Finite_enumerable order" 'card C =
- (cic:/matita/algebra/groups/order.con C _).
-
-record finite_enumerable_SemiGroup : Type ≝
- { semigroup:> SemiGroup;
- is_finite_enumerable:> finite_enumerable semigroup
- }.
-
-notation < "S"
-for @{ 'semigroup_of_finite_enumerable_semigroup $S }.
-
-interpretation "Semigroup_of_finite_enumerable_semigroup"
- 'semigroup_of_finite_enumerable_semigroup S
-=
- (cic:/matita/algebra/groups/semigroup.con S).
-
-notation < "S"
-for @{ 'magma_of_finite_enumerable_semigroup $S }.
-
-interpretation "Magma_of_finite_enumerable_semigroup"
- 'magma_of_finite_enumerable_semigroup S
-=
- (cic:/matita/algebra/groups/Magma_of_finite_enumerable_SemiGroup.con S).
-
-notation < "S"
-for @{ 'type_of_finite_enumerable_semigroup $S }.
-
-interpretation "Type_of_finite_enumerable_semigroup"
- 'type_of_finite_enumerable_semigroup S
-=
- (cic:/matita/algebra/groups/Type_of_finite_enumerable_SemiGroup.con S).
-
-interpretation "Finite_enumerable representation" 'repr S i =
- (cic:/matita/algebra/groups/repr.con S
- (cic:/matita/algebra/groups/is_finite_enumerable.con S) i).
-
-notation "hvbox(ι e)" with precedence 60
-for @{ 'index_of_finite_enumerable_semigroup $e }.
-
-interpretation "Index_of_finite_enumerable representation"
- 'index_of_finite_enumerable_semigroup e
-=
- (cic:/matita/algebra/groups/index_of.con _
- (cic:/matita/algebra/groups/is_finite_enumerable.con _) e).
-
-
-(* several definitions/theorems to be moved somewhere else *)
-
-definition ltb ≝ λn,m. leb n m ∧ notb (eqb n m).
-
-theorem not_eq_to_le_to_lt: ∀n,m. n≠m → n≤m → n<m.
-intros;
-elim (le_to_or_lt_eq ? ? H1);
-[ assumption
-| elim (H H2)
-].
-qed.
-
-theorem ltb_to_Prop :
- ∀n,m.
- match ltb n m with
- [ true ⇒ n < m
- | false ⇒ n ≮ m
- ].
-intros;
-unfold ltb;
-apply leb_elim;
-apply eqb_elim;
-intros;
-simplify;
-[ rewrite < H;
- apply le_to_not_lt;
- constructor 1
-| apply (not_eq_to_le_to_lt ? ? H H1)
-| rewrite < H;
- apply le_to_not_lt;
- constructor 1
-| apply le_to_not_lt;
- generalize in match (not_le_to_lt ? ? H1);
- clear H1;
- intro;
- apply lt_to_le;
- assumption
-].
-qed.
-
-theorem ltb_elim: \forall n,m:nat. \forall P:bool \to Prop.
-(n < m \to (P true)) \to (n ≮ m \to (P false)) \to
-P (ltb n m).
-intros.
-cut
-(match (ltb n m) with
-[ true \Rightarrow n < m
-| false \Rightarrow n ≮ m] \to (P (ltb n m))).
-apply Hcut.apply ltb_to_Prop.
-elim (ltb n m).
-apply ((H H2)).
-apply ((H1 H2)).
-qed.
-
-theorem Not_lt_n_n: ∀n. n ≮ n.
-intro;
-unfold Not;
-intro;
-unfold lt in H;
-apply (not_le_Sn_n ? H).
-qed.
-
-theorem eq_pred_to_eq:
- ∀n,m. O < n → O < m → pred n = pred m → n = m.
-intros;
-generalize in match (eq_f ? ? S ? ? H2);
-intro;
-rewrite < S_pred in H3;
-rewrite < S_pred in H3;
-assumption.
-qed.
-
-theorem le_pred_to_le:
- ∀n,m. O < m → pred n ≤ pred m \to n ≤ m.
-intros 2;
-elim n;
-[ apply le_O_n
-| simplify in H2;
- rewrite > (S_pred m);
- [ apply le_S_S;
- assumption
- | assumption
- ]
-].
-qed.
-
-theorem le_to_le_pred:
- ∀n,m. n ≤ m → pred n ≤ pred m.
-intros 2;
-elim n;
-[ simplify;
- apply le_O_n
-| simplify;
- generalize in match H1;
- clear H1;
- elim m;
- [ elim (not_le_Sn_O ? H1)
- | simplify;
- apply le_S_S_to_le;
- assumption
- ]
-].
-qed.
-
-theorem lt_n_m_to_not_lt_m_Sn: ∀n,m. n < m → m ≮ S n.
-intros;
-unfold Not;
-intro;
-unfold lt in H;
-unfold lt in H1;
-generalize in match (le_S_S ? ? H);
-intro;
-generalize in match (transitive_le ? ? ? H2 H1);
-intro;
-apply (not_le_Sn_n ? H3).
-qed.
-
-theorem lt_S_S: ∀n,m. n < m → S n < S m.
-intros;
-unfold lt in H;
-apply (le_S_S ? ? H).
-qed.
-
-theorem lt_O_S: ∀n. O < S n.
-intro;
-unfold lt;
-apply le_S_S;
-apply le_O_n.
-qed.
-
-theorem le_n_m_to_lt_m_Sn_to_eq_n_m: ∀n,m. n ≤ m → m < S n → n=m.
-intros;
-unfold lt in H1;
-generalize in match (le_S_S_to_le ? ? H1);
-intro;
-apply cic:/matita/nat/orders/antisym_le.con;
-assumption.
-qed.
-
-theorem pigeonhole:
- ∀n:nat.∀f:nat→nat.
- (∀x,y.x≤n → y≤n → f x = f y → x=y) →
- (∀m. m ≤ n → f m ≤ n) →
- ∀x. x≤n \to ∃y.f y = x ∧ y ≤ n.
-intro;
-elim n;
-[ apply (ex_intro ? ? O);
- split;
- [ rewrite < (le_n_O_to_eq ? H2);
- rewrite < (le_n_O_to_eq ? (H1 O ?));
- [ reflexivity
- | apply le_n
- ]
- | apply le_n
- ]
-| clear n;
- letin f' ≝
- (λx.
- let fSn1 ≝ f (S n1) in
- let fx ≝ f x in
- match ltb fSn1 fx with
- [ true ⇒ pred fx
- | false ⇒ fx
- ]);
- cut (∀x,y. x ≤ n1 → y ≤ n1 → f' x = f' y → x=y);
- [ cut (∀x. x ≤ n1 → f' x ≤ n1);
- [ apply (nat_compare_elim (f (S n1)) x);
- [ intro;
- elim (H f' ? ? (pred x));
- [ simplify in H5;
- clear Hcut;
- clear Hcut1;
- clear f';
- elim H5;
- clear H5;
- apply (ex_intro ? ? a);
- split;
- [ generalize in match (eq_f ? ? S ? ? H6);
- clear H6;
- intro;
- rewrite < S_pred in H5;
- [ generalize in match H4;
- clear H4;
- rewrite < H5;
- clear H5;
- apply (ltb_elim (f (S n1)) (f a));
- [ simplify;
- intros;
- rewrite < S_pred;
- [ reflexivity
- | apply (ltn_to_ltO ? ? H4)
- ]
- | simplify;
- intros;
- generalize in match (not_lt_to_le ? ? H4);
- clear H4;
- intro;
- generalize in match (le_n_m_to_lt_m_Sn_to_eq_n_m ? ? H6 H5);
- intro;
- generalize in match (H1 ? ? ? ? H4);
- [ intro;
- |
- |
- ]
- ]
- | apply (ltn_to_ltO ? ? H4)
- ]
- | apply le_S;
- assumption
- ]
- | apply Hcut
- | apply Hcut1
- | apply le_S_S_to_le;
- rewrite < S_pred;
- exact H3
- ]
- (* TODO: caso complicato, ma simile al terzo *)
- | intros;
- apply (ex_intro ? ? (S n1));
- split;
- [ assumption
- | constructor 1
- ]
- | intro;
- elim (H f' ? ? x);
- [ simplify in H5;
- clear Hcut;
- clear Hcut1;
- clear f';
- elim H5;
- clear H5;
- apply (ex_intro ? ? a);
- split;
- [ generalize in match H4;
- clear H4;
- rewrite < H6;
- clear H6;
- apply (ltb_elim (f (S n1)) (f a));
- [ simplify;
- intros;
- generalize in match (lt_S_S ? ? H5);
- intro;
- rewrite < S_pred in H6;
- [ elim (lt_n_m_to_not_lt_m_Sn ? ? H4 H6)
- | apply (ltn_to_ltO ? ? H4)
- ]
- | simplify;
- intros;
- reflexivity
- ]
- | apply le_S;
- assumption
- ]
- | apply Hcut
- | apply Hcut1
- | rewrite > (pred_Sn n1);
- simplify;
- generalize in match (H2 (S n1));
- intro;
- generalize in match (lt_to_le_to_lt ? ? ? H4 (H5 (le_n ?)));
- intro;
- unfold lt in H6;
- apply le_S_S_to_le;
- assumption
- ]
- ]
- | unfold f';
- simplify;
- intro;
- apply (ltb_elim (f (S n1)) (f x1));
- simplify;
- intros;
- [ generalize in match (H2 x1);
- intro;
- change in match n1 with (pred (S n1));
- apply le_to_le_pred;
- apply H6;
- apply le_S;
- assumption
- | generalize in match (H2 (S n1) (le_n ?));
- intro;
- generalize in match (not_lt_to_le ? ? H4);
- intro;
- generalize in match (transitive_le ? ? ? H7 H6);
- intro;
- cut (f x1 ≠ f (S n1));
- [ generalize in match (not_eq_to_le_to_lt ? ? Hcut1 H7);
- intro;
- unfold lt in H9;
- generalize in match (transitive_le ? ? ? H9 H6);
- intro;
- apply le_S_S_to_le;
- assumption
- | unfold Not;
- intro;
- generalize in match (H1 ? ? ? ? H9);
- [ intro;
- rewrite > H10 in H5;
- apply (not_le_Sn_n ? H5)
- | apply le_S;
- assumption
- | apply le_n
- ]
- ]
- ]
- ]
- | intros 4;
- unfold f';
- simplify;
- apply (ltb_elim (f (S n1)) (f x1));
- simplify;
- apply (ltb_elim (f (S n1)) (f y));
- simplify;
- intros;
- [ cut (f x1 = f y);
- [ apply (H1 ? ? ? ? Hcut);
- apply le_S;
- assumption
- | apply eq_pred_to_eq;
- [ apply (ltn_to_ltO ? ? H7)
- | apply (ltn_to_ltO ? ? H6)
- | assumption
- ]
- ]
- | (* pred (f x1) = f y absurd since y ≠ S n1 and thus f y ≠ f (S n1)
- so that f y < f (S n1) < f x1; hence pred (f x1) = f y is absurd *)
- cut (y < S n1);
- [ generalize in match (lt_to_not_eq ? ? Hcut);
- intro;
- cut (f y ≠ f (S n1));
- [ cut (f y < f (S n1));
- [ rewrite < H8 in Hcut2;
- unfold lt in Hcut2;
- unfold lt in H7;
- generalize in match (le_S_S ? ? Hcut2);
- intro;
- generalize in match (transitive_le ? ? ? H10 H7);
- intros;
- rewrite < (S_pred (f x1)) in H11;
- [ elim (not_le_Sn_n ? H11)
- | fold simplify ((f (S n1)) < (f x1)) in H7;
- apply (ltn_to_ltO ? ? H7)
- ]
- | apply not_eq_to_le_to_lt;
- [ assumption
- | apply not_lt_to_le;
- assumption
- ]
- ]
- | unfold Not;
- intro;
- apply H9;
- apply (H1 ? ? ? ? H10);
- [ apply lt_to_le;
- assumption
- | constructor 1
- ]
- ]
- | unfold lt;
- apply le_S_S;
- assumption
- ]
- | (* f x1 = pred (f y) absurd since it implies S (f x1) = f y and
- f x1 ≤ f (S n1) < f y = S (f x1) so that f x1 = f (S n1); by
- injectivity x1 = S n1 that is absurd since x1 ≤ n1 *)
- generalize in match (eq_f ? ? S ? ? H8);
- intro;
- rewrite < S_pred in H9;
- [ rewrite < H9 in H6;
- generalize in match (not_lt_to_le ? ? H7);
- intro;
- unfold lt in H6;
- generalize in match (le_S_S ? ? H10);
- intro;
- generalize in match (antisym_le ? ? H11 H6);
- intro;
- generalize in match (inj_S ? ? H12);
- intro;
- generalize in match (H1 ? ? ? ? H13);
- [ intro;
- rewrite > H14 in H4;
- elim (not_le_Sn_n ? H4)
- | apply le_S;
- assumption
- | apply le_n
- ]
- | apply (ltn_to_ltO ? ? H6)
- ]
- | apply (H1 ? ? ? ? H8);
- apply le_S;
- assumption
- ]
- ]
-].
-qed.
-
-theorem foo:
- ∀G:finite_enumerable_SemiGroup.
- left_cancellable ? (op G) →
- right_cancellable ? (op G) →
- ∃e:G. isMonoid (mk_PreMonoid G e).
-intros;
-letin f ≝ (λn.ι(G \sub O · G \sub n));
-cut (∀n.n ≤ order ? (is_finite_enumerable G) → ∃m.f m = n);
-[ letin EX ≝ (Hcut O ?);
- [ apply le_O_n
- | clearbody EX;
- clear Hcut;
- unfold f in EX;
- elim EX;
- clear EX;
- letin HH ≝ (eq_f ? ? (repr ? (is_finite_enumerable G)) ? ? H2);
- clearbody HH;
- rewrite > (repr_index_of ? (is_finite_enumerable G)) in HH;
- apply (ex_intro ? ? (G \sub a));
- letin GOGO ≝ (refl_eq ? (repr ? (is_finite_enumerable G) O));
- clearbody GOGO;
- rewrite < HH in GOGO;
- rewrite < HH in GOGO:(? ? % ?);
- rewrite > (associative ? G) in GOGO;
- letin GaGa ≝ (H ? ? ? GOGO);
- clearbody GaGa;
- clear GOGO;
- constructor 1;
- [ simplify;
- apply (semigroup_properties G)
- | unfold is_left_unit; intro;
- letin GaxGax ≝ (refl_eq ? (G \sub a ·x));
- clearbody GaxGax;
- rewrite < GaGa in GaxGax:(? ? % ?);
- rewrite > (associative ? (semigroup_properties G)) in GaxGax;
- apply (H ? ? ? GaxGax)
- | unfold is_right_unit; intro;
- letin GaxGax ≝ (refl_eq ? (x·G \sub a));
- clearbody GaxGax;
- rewrite < GaGa in GaxGax:(? ? % ?);
- rewrite < (associative ? (semigroup_properties G)) in GaxGax;
- apply (H1 ? ? ? GaxGax)
- ]
- ]
-| apply pigeonhole
-].
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||M|| *)
-(* ||A|| A project by Andrea Asperti *)
-(* ||T|| *)
-(* ||I|| Developers: *)
-(* ||T|| The HELM team. *)
-(* ||A|| http://helm.cs.unibo.it *)
-(* \ / *)
-(* \ / This file is distributed under the terms of the *)
-(* v GNU General Public License Version 2 *)
-(* *)
-(**************************************************************************)
-
-set "baseuri" "cic:/matita/algebra/monoids/".
-
-include "algebra/semigroups.ma".
-
-record PreMonoid : Type ≝
- { magma:> Magma;
- e: magma
- }.
-
-notation < "M" for @{ 'pmmagma $M }.
-interpretation "premonoid magma coercion" 'pmmagma M =
- (cic:/matita/algebra/monoids/magma.con M).
-
-record isMonoid (M:PreMonoid) : Prop ≝
- { is_semi_group: isSemiGroup M;
- e_is_left_unit:
- is_left_unit (mk_SemiGroup ? is_semi_group) (e M);
- e_is_right_unit:
- is_right_unit (mk_SemiGroup ? is_semi_group) (e M)
- }.
-
-record Monoid : Type ≝
- { premonoid:> PreMonoid;
- monoid_properties:> isMonoid premonoid
- }.
-
-notation < "M" for @{ 'semigroup $M }.
-interpretation "premonoid coercion" 'premonoid M =
- (cic:/matita/algebra/monoids/premonoid.con M).
-
-notation < "M" for @{ 'typeofmonoid $M }.
-interpretation "premonoid coercion" 'typeofmonoid M =
- (cic:/matita/algebra/monoids/Type_of_Monoid.con M).
-
-notation < "M" for @{ 'magmaofmonoid $M }.
-interpretation "premonoid coercion" 'magmaofmonoid M =
- (cic:/matita/algebra/monoids/Magma_of_Monoid.con M).
-
-notation "1" with precedence 89
-for @{ 'munit }.
-
-interpretation "Monoid unit" 'munit =
- (cic:/matita/algebra/monoids/e.con _).
-
-definition is_left_inverse ≝
- λM:Monoid.
- λopp: M → M.
- ∀x:M. (opp x)·x = 1.
-
-definition is_right_inverse ≝
- λM:Monoid.
- λopp: M → M.
- ∀x:M. x·(opp x) = 1.
-
-theorem is_left_inverse_to_is_right_inverse_to_eq:
- ∀M:Monoid. ∀l,r.
- is_left_inverse M l → is_right_inverse M r →
- ∀x:M. l x = r x.
- intros;
- generalize in match (H x); intro;
- generalize in match (eq_f ? ? (λy.y·(r x)) ? ? H2);
- simplify; fold simplify (op M);
- intro; clear H2;
- generalize in match (associative ? (is_semi_group ? (monoid_properties M)));
- intro;
- rewrite > H2 in H3; clear H2;
- rewrite > H1 in H3;
- rewrite > (e_is_left_unit ? (monoid_properties M)) in H3;
- rewrite > (e_is_right_unit ? (monoid_properties M)) in H3;
- assumption.
-qed.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||M|| *)
-(* ||A|| A project by Andrea Asperti *)
-(* ||T|| *)
-(* ||I|| Developers: *)
-(* ||T|| The HELM team. *)
-(* ||A|| http://helm.cs.unibo.it *)
-(* \ / *)
-(* \ / This file is distributed under the terms of the *)
-(* v GNU General Public License Version 2 *)
-(* *)
-(**************************************************************************)
-
-set "baseuri" "cic:/matita/algebra/semigroups".
-
-include "higher_order_defs/functions.ma".
-
-(* Magmas *)
-
-record Magma : Type ≝
- { carrier:> Type;
- op: carrier → carrier → carrier
- }.
-
-notation < "M" for @{ 'carrier $M }.
-interpretation "carrier coercion" 'carrier S =
- (cic:/matita/algebra/semigroups/carrier.con S).
-
-notation "hvbox(a break \middot b)"
- left associative with precedence 55
-for @{ 'magma_op $a $b }.
-
-interpretation "magma operation" 'magma_op a b =
- (cic:/matita/algebra/semigroups/op.con _ a b).
-
-(* Semigroups *)
-
-record isSemiGroup (M:Magma) : Prop ≝
- { associative: associative ? (op M) }.
-
-record SemiGroup : Type ≝
- { magma:> Magma;
- semigroup_properties:> isSemiGroup magma
- }.
-
-notation < "S" for @{ 'magma $S }.
-interpretation "magma coercion" 'magma S =
- (cic:/matita/algebra/semigroups/magma.con S).
-
-definition is_left_unit ≝
- λS:SemiGroup. λe:S. ∀x:S. e·x = x.
-
-definition is_right_unit ≝
- λS:SemiGroup. λe:S. ∀x:S. x·e = x.
-
-theorem is_left_unit_to_is_right_unit_to_eq:
- ∀S:SemiGroup. ∀e,e':S.
- is_left_unit ? e → is_right_unit ? e' → e=e'.
- intros;
- rewrite < (H e');
- rewrite < (H1 e) in \vdash (? ? % ?);
- reflexivity.
-qed.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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 ].
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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).
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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).
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||M|| *)
-(* ||A|| A project by Andrea Asperti *)
-(* ||T|| *)
-(* ||I|| Developers: *)
-(* ||T|| A.Asperti, C.Sacerdoti Coen, *)
-(* ||A|| E.Tassi, S.Zacchiroli *)
-(* \ / *)
-(* \ / This file is distributed under the terms of the *)
-(* v GNU Lesser General Public License Version 2.1 *)
-(* *)
-(**************************************************************************)
-
-set "baseuri" "cic:/matita/legacy/coq/".
-
-(* aritmetic operators *)
-
-interpretation "Coq's natural plus" 'plus x y = (cic:/Coq/Init/Peano/plus.con x y).
-interpretation "Coq's real plus" 'plus x y = (cic:/Coq/Reals/Rdefinitions/Rplus.con x y).
-interpretation "Coq's binary integer plus" 'plus x y = (cic:/Coq/ZArith/BinInt/Zplus.con x y).
-interpretation "Coq's binary positive plus" 'plus x y = (cic:/Coq/NArith/BinPos/Pplus.con x y).
-interpretation "Coq's natural minus" 'minus x y = (cic:/Coq/Init/Peano/minus.con x y).
-interpretation "Coq's real minus" 'minus x y = (cic:/Coq/Reals/Rdefinitions/Rminus.con x y).
-interpretation "Coq's binary integer minus" 'minus x y = (cic:/Coq/ZArith/BinInt/Zminus.con x y).
-interpretation "Coq's binary positive minus" 'minus x y = (cic:/Coq/NArith/BinPos/Pminus.con x y).
-interpretation "Coq's natural times" 'times x y = (cic:/Coq/Init/Peano/mult.con x y).
-interpretation "Coq's real times" 'times x y = (cic:/Coq/Reals/Rdefinitions/Rmult.con x y).
-interpretation "Coq's binary positive times" 'times x y = (cic:/Coq/NArith/BinPos/Pmult.con x y).
-interpretation "Coq's binary integer times" 'times x y = (cic:/Coq/ZArith/BinInt/Zmult.con x y).
-interpretation "Coq's real power" 'power x y = (cic:/Coq/Reals/Rfunctions/pow.con x y).
-interpretation "Coq's integer power" 'power x y = (cic:/Coq/ZArith/Zpower/Zpower.con x y).
-interpretation "Coq's real divide" 'divide x y = (cic:/Coq/Reals/Rdefinitions/Rdiv.con x y).
-interpretation "Coq's real unary minus" 'uminus x = (cic:/Coq/Reals/Rdefinitions/Ropp.con x).
-interpretation "Coq's binary integer negative sign" 'uminus x = (cic:/Coq/ZArith/BinInt/Z.ind#xpointer(1/1/3) x).
-interpretation "Coq's binary integer unary minus" 'uminus x = (cic:/Coq/ZArith/BinInt/Zopp.con x).
-
-(* logical operators *)
-
-interpretation "Coq's logical and" 'and x y = (cic:/Coq/Init/Logic/and.ind#xpointer(1/1) x y).
-interpretation "Coq's logical or" 'or x y = (cic:/Coq/Init/Logic/or.ind#xpointer(1/1) x y).
-interpretation "Coq's logical not" 'not x = (cic:/Coq/Init/Logic/not.con x).
-interpretation "Coq's exists" 'exists \eta.x = (cic:/Coq/Init/Logic/ex.ind#xpointer(1/1) _ x).
-
-(* relational operators *)
-
-interpretation "Coq's natural 'less or equal to'" 'leq x y = (cic:/Coq/Init/Peano/le.ind#xpointer(1/1) x y).
-interpretation "Coq's real 'less or equal to'" 'leq x y = (cic:/Coq/Reals/Rdefinitions/Rle.con x y).
-interpretation "Coq's natural 'greater or equal to'" 'geq x y = (cic:/Coq/Init/Peano/ge.con x y).
-interpretation "Coq's real 'greater or equal to'" 'geq x y = (cic:/Coq/Reals/Rdefinitions/Rge.con x y).
-interpretation "Coq's natural 'less than'" 'lt x y = (cic:/Coq/Init/Peano/lt.con x y).
-interpretation "Coq's real 'less than'" 'lt x y = (cic:/Coq/Reals/Rdefinitions/Rlt.con x y).
-interpretation "Coq's natural 'greater than'" 'gt x y = (cic:/Coq/Init/Peano/gt.con x y).
-interpretation "Coq's real 'greater than'" 'gt x y = (cic:/Coq/Reals/Rdefinitions/Rgt.con x y).
-
-interpretation "Coq's leibnitz's equality" 'eq x y = (cic:/Coq/Init/Logic/eq.ind#xpointer(1/1) _ x y).
-interpretation "Coq's not equal to (leibnitz)" 'neq x y = (cic:/Coq/Init/Logic/not.con (cic:/Coq/Init/Logic/eq.ind#xpointer(1/1) _ x y)).
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-*)
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-*)
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* __ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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 (? ? %).
-change with (f x < f y).
-apply H.apply H2.
-intros.assumption.
-intro.apply False_ind.apply (not_le_Sn_n (f y)).
-rewrite < H1 in \vdash (? ? %).
-change with (f y < f x).
-apply H.apply H2.
-qed.
-
-theorem increasing_to_injective: \forall f:nat\to nat.
-increasing f \to injective nat nat f.
-intros.apply monotonic_to_injective.
-apply increasing_to_monotonic.assumption.
-qed.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||M|| *)
-(* ||A|| A project by Andrea Asperti *)
-(* ||T|| *)
-(* ||I|| Developers: *)
-(* ||T|| A.Asperti, C.Sacerdoti Coen, *)
-(* ||A|| E.Tassi, S.Zacchiroli *)
-(* \ / *)
-(* \ / This file is distributed under the terms of the *)
-(* v GNU Lesser General Public License Version 2.1 *)
-(* *)
-(**************************************************************************)
-
-set "baseuri" "cic:/matita/nat/nat".
-
-include "higher_order_defs/functions.ma".
-
-inductive nat : Set \def
- | O : nat
- | S : nat \to nat.
-
-definition pred: nat \to nat \def
- \lambda n:nat. match n with
- [ O \Rightarrow O
- | (S p) \Rightarrow p ].
-
-theorem pred_Sn : \forall n:nat.n=(pred (S n)).
- intros. reflexivity.
-qed.
-
-theorem injective_S : injective nat nat S.
- unfold injective.
- intros.
- rewrite > pred_Sn.
- rewrite > (pred_Sn y).
- apply eq_f. assumption.
-qed.
-
-theorem inj_S : \forall n,m:nat.(S n)=(S m) \to n=m \def
- injective_S.
-
-theorem not_eq_S : \forall n,m:nat.
- \lnot n=m \to S n \neq S m.
- intros. unfold Not. intros.
- apply H. apply injective_S. assumption.
-qed.
-
-definition not_zero : nat \to Prop \def
- \lambda n: nat.
- match n with
- [ O \Rightarrow False
- | (S p) \Rightarrow True ].
-
-theorem not_eq_O_S : \forall n:nat. O \neq S n.
- intros. unfold Not. intros.
- cut (not_zero O).
- exact Hcut.
- rewrite > H.exact I.
-qed.
-
-theorem not_eq_n_Sn : \forall n:nat. n \neq S n.
- intros.elim n.
- apply not_eq_O_S.
- apply not_eq_S.assumption.
-qed.
-
-theorem nat_case:
- \forall n:nat.\forall P:nat \to Prop.
- P O \to (\forall m:nat. P (S m)) \to P n.
-intros.elim n
- [ assumption
- | apply H1 ]
-qed.
-
-theorem nat_case1:
- \forall n:nat.\forall P:nat \to Prop.
- (n=O \to P O) \to (\forall m:nat. (n=(S m) \to P (S m))) \to P n.
-intros 2; elim n
- [ apply H;reflexivity
- | apply H2;reflexivity ]
-qed.
-
-theorem nat_elim2 :
- \forall R:nat \to nat \to Prop.
- (\forall n:nat. R O n)
- \to (\forall n:nat. R (S n) O)
- \to (\forall n,m:nat. R n m \to R (S n) (S m))
- \to \forall n,m:nat. R n m.
-intros 5;elim n
- [ apply H
- | apply (nat_case m)
- [ apply H1
- | intro; apply H2; apply H3 ] ]
-qed.
-
-theorem decidable_eq_nat : \forall n,m:nat.decidable (n=m).
- intros.unfold decidable.
- apply (nat_elim2 (\lambda n,m.(Or (n=m) ((n=m) \to False))))
- [ intro; elim n1
- [ left; reflexivity
- | right; apply not_eq_O_S ]
- | intro; right; intro; apply (not_eq_O_S n1); apply sym_eq; assumption
- | intros; elim H
- [ left; apply eq_f; assumption
- | right; intro; apply H1; apply inj_S; assumption ] ]
-qed.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||M|| *)
-(* ||A|| A project by Andrea Asperti *)
-(* ||T|| *)
-(* ||I|| Developers: *)
-(* ||T|| A.Asperti, C.Sacerdoti Coen, *)
-(* ||A|| E.Tassi, S.Zacchiroli *)
-(* \ / *)
-(* \ / This file is distributed under the terms of the *)
-(* v GNU Lesser General Public License Version 2.1 *)
-(* *)
-(**************************************************************************)
-
-set "baseuri" "cic:/matita/nat/permutation".
-
-include "nat/compare.ma".
-include "nat/sigma_and_pi.ma".
-
-definition injn: (nat \to nat) \to nat \to Prop \def
-\lambda f:nat \to nat.\lambda n:nat.\forall i,j:nat.
-i \le n \to j \le n \to f i = f j \to i = j.
-
-theorem injn_Sn_n: \forall f:nat \to nat. \forall n:nat.
-injn f (S n) \to injn f n.unfold injn.
-intros.apply H.
-apply le_S.assumption.
-apply le_S.assumption.
-assumption.
-qed.
-
-theorem injective_to_injn: \forall f:nat \to nat. \forall n:nat.
-injective nat nat f \to injn f n.
-unfold injective.unfold injn.intros.apply H.assumption.
-qed.
-
-definition permut : (nat \to nat) \to nat \to Prop
-\def \lambda f:nat \to nat. \lambda m:nat.
-(\forall i:nat. i \le m \to f i \le m )\land injn f m.
-
-theorem permut_O_to_eq_O: \forall h:nat \to nat.
-permut h O \to (h O) = O.
-intros.unfold permut in H.
-elim H.apply sym_eq.apply le_n_O_to_eq.
-apply H1.apply le_n.
-qed.
-
-theorem permut_S_to_permut: \forall f:nat \to nat. \forall m:nat.
-permut f (S m) \to f (S m) = (S m) \to permut f m.
-unfold permut.intros.
-elim H.
-split.intros.
-cut (f i < S m \lor f i = S m).
-elim Hcut.
-apply le_S_S_to_le.assumption.
-apply False_ind.
-apply (not_le_Sn_n m).
-cut ((S m) = i).
-rewrite > Hcut1.assumption.
-apply H3.apply le_n.apply le_S.assumption.
-rewrite > H5.assumption.
-apply le_to_or_lt_eq.apply H2.apply le_S.assumption.
-apply (injn_Sn_n f m H3).
-qed.
-
-(* transpositions *)
-
-definition transpose : nat \to nat \to nat \to nat \def
-\lambda i,j,n:nat.
-match eqb n i with
- [ true \Rightarrow j
- | false \Rightarrow
- match eqb n j with
- [ true \Rightarrow i
- | false \Rightarrow n]].
-
-lemma transpose_i_j_i: \forall i,j:nat. transpose i j i = j.
-intros.unfold transpose.
-rewrite > (eqb_n_n i).simplify. reflexivity.
-qed.
-
-lemma transpose_i_j_j: \forall i,j:nat. transpose i j j = i.
-intros.unfold transpose.
-apply (eqb_elim j i).simplify.intro.assumption.
-rewrite > (eqb_n_n j).simplify.
-intros. reflexivity.
-qed.
-
-theorem transpose_i_i: \forall i,n:nat. (transpose i i n) = n.
-intros.unfold transpose.
-apply (eqb_elim n i).
-intro.simplify.apply sym_eq. assumption.
-intro.simplify.reflexivity.
-qed.
-
-theorem transpose_i_j_j_i: \forall i,j,n:nat.
-transpose i j n = transpose j i n.
-intros.unfold transpose.
-apply (eqb_elim n i).
-apply (eqb_elim n j).
-intros. simplify.rewrite < H. rewrite < H1.
-reflexivity.
-intros.simplify.reflexivity.
-apply (eqb_elim n j).
-intros.simplify.reflexivity.
-intros.simplify.reflexivity.
-qed.
-
-theorem transpose_transpose: \forall i,j,n:nat.
-(transpose i j (transpose i j n)) = n.
-intros.unfold transpose. unfold transpose.
-apply (eqb_elim n i).simplify.
-intro.
-apply (eqb_elim j i).
-simplify.intros.rewrite > H. rewrite > H1.reflexivity.
-rewrite > (eqb_n_n j).simplify.intros.
-apply sym_eq.
-assumption.
-apply (eqb_elim n j).simplify.
-rewrite > (eqb_n_n i).intros.simplify.
-apply sym_eq. assumption.
-simplify.intros.
-rewrite > (not_eq_to_eqb_false n i H1).
-rewrite > (not_eq_to_eqb_false n j H).
-simplify.reflexivity.
-qed.
-
-theorem injective_transpose : \forall i,j:nat.
-injective nat nat (transpose i j).
-unfold injective.
-intros.
-rewrite < (transpose_transpose i j x).
-rewrite < (transpose_transpose i j y).
-apply eq_f.assumption.
-qed.
-
-variant inj_transpose: \forall i,j,n,m:nat.
-transpose i j n = transpose i j m \to n = m \def
-injective_transpose.
-
-theorem permut_transpose: \forall i,j,n:nat. i \le n \to j \le n \to
-permut (transpose i j) n.
-unfold permut.intros.
-split.unfold transpose.
-intros.
-elim (eqb i1 i).simplify.assumption.
-elim (eqb i1 j).simplify.assumption.
-simplify.assumption.
-apply (injective_to_injn (transpose i j) n).
-apply injective_transpose.
-qed.
-
-theorem permut_fg: \forall f,g:nat \to nat. \forall n:nat.
-permut f n \to permut g n \to permut (\lambda m.(f(g m))) n.
-unfold permut. intros.
-elim H.elim H1.
-split.intros.simplify.apply H2.
-apply H4.assumption.
-simplify.intros.
-apply H5.assumption.assumption.
-apply H3.apply H4.assumption.apply H4.assumption.
-assumption.
-qed.
-
-theorem permut_transpose_l:
-\forall f:nat \to nat. \forall m,i,j:nat.
-i \le m \to j \le m \to permut f m \to permut (\lambda n.transpose i j (f n)) m.
-intros.apply (permut_fg (transpose i j) f m ? ?).
-apply permut_transpose.assumption.assumption.
-assumption.
-qed.
-
-theorem permut_transpose_r:
-\forall f:nat \to nat. \forall m,i,j:nat.
-i \le m \to j \le m \to permut f m \to permut (\lambda n.f (transpose i j n)) m.
-intros.apply (permut_fg f (transpose i j) m ? ?).
-assumption.apply permut_transpose.assumption.assumption.
-qed.
-
-theorem eq_transpose : \forall i,j,k,n:nat. \lnot j=i \to
- \lnot i=k \to \lnot j=k \to
-transpose i j n = transpose i k (transpose k j (transpose i k n)).
-(* uffa: triplo unfold? *)
-intros.unfold transpose.unfold transpose.unfold transpose.
-apply (eqb_elim n i).intro.
-simplify.rewrite > (eqb_n_n k).
-simplify.rewrite > (not_eq_to_eqb_false j i H).
-rewrite > (not_eq_to_eqb_false j k H2).
-reflexivity.
-intro.apply (eqb_elim n j).
-intro.
-cut (\lnot n = k).
-cut (\lnot n = i).
-rewrite > (not_eq_to_eqb_false n k Hcut).
-simplify.
-rewrite > (not_eq_to_eqb_false n k Hcut).
-rewrite > (eq_to_eqb_true n j H4).
-simplify.
-rewrite > (not_eq_to_eqb_false k i).
-rewrite > (eqb_n_n k).
-simplify.reflexivity.
-unfold Not.intro.apply H1.apply sym_eq.assumption.
-assumption.
-unfold Not.intro.apply H2.apply (trans_eq ? ? n).
-apply sym_eq.assumption.assumption.
-intro.apply (eqb_elim n k).intro.
-simplify.
-rewrite > (not_eq_to_eqb_false i k H1).
-rewrite > (not_eq_to_eqb_false i j).
-simplify.
-rewrite > (eqb_n_n i).
-simplify.assumption.
-unfold Not.intro.apply H.apply sym_eq.assumption.
-intro.simplify.
-rewrite > (not_eq_to_eqb_false n k H5).
-rewrite > (not_eq_to_eqb_false n j H4).
-simplify.
-rewrite > (not_eq_to_eqb_false n i H3).
-rewrite > (not_eq_to_eqb_false n k H5).
-simplify.reflexivity.
-qed.
-
-theorem permut_S_to_permut_transpose: \forall f:nat \to nat.
-\forall m:nat. permut f (S m) \to permut (\lambda n.transpose (f (S m)) (S m)
-(f n)) m.
-unfold permut.intros.
-elim H.
-split.intros.simplify.unfold transpose.
-apply (eqb_elim (f i) (f (S m))).
-intro.apply False_ind.
-cut (i = (S m)).
-apply (not_le_Sn_n m).
-rewrite < Hcut.assumption.
-apply H2.apply le_S.assumption.apply le_n.assumption.
-intro.simplify.
-apply (eqb_elim (f i) (S m)).
-intro.
-cut (f (S m) \lt (S m) \lor f (S m) = (S m)).
-elim Hcut.apply le_S_S_to_le.assumption.
-apply False_ind.apply H4.rewrite > H6.assumption.
-apply le_to_or_lt_eq.apply H1.apply le_n.
-intro.simplify.
-cut (f i \lt (S m) \lor f i = (S m)).
-elim Hcut.apply le_S_S_to_le.assumption.
-apply False_ind.apply H5.assumption.
-apply le_to_or_lt_eq.apply H1.apply le_S.assumption.
-unfold injn.intros.
-apply H2.apply le_S.assumption.apply le_S.assumption.
-apply (inj_transpose (f (S m)) (S m)).
-apply H5.
-qed.
-
-(* bounded bijectivity *)
-
-definition bijn : (nat \to nat) \to nat \to Prop \def
-\lambda f:nat \to nat. \lambda n. \forall m:nat. m \le n \to
-ex nat (\lambda p. p \le n \land f p = m).
-
-theorem eq_to_bijn: \forall f,g:nat\to nat. \forall n:nat.
-(\forall i:nat. i \le n \to (f i) = (g i)) \to
-bijn f n \to bijn g n.
-intros 4.unfold bijn.
-intros.elim (H1 m).
-apply (ex_intro ? ? a).
-rewrite < (H a).assumption.
-elim H3.assumption.assumption.
-qed.
-
-theorem bijn_Sn_n: \forall f:nat \to nat. \forall n:nat.
-bijn f (S n) \to f (S n) = (S n) \to bijn f n.
-unfold bijn.intros.elim (H m).
-elim H3.
-apply (ex_intro ? ? a).split.
-cut (a < S n \lor a = S n).
-elim Hcut.apply le_S_S_to_le.assumption.
-apply False_ind.
-apply (not_le_Sn_n n).
-rewrite < H1.rewrite < H6.rewrite > H5.assumption.
-apply le_to_or_lt_eq.assumption.assumption.
-apply le_S.assumption.
-qed.
-
-theorem bijn_n_Sn: \forall f:nat \to nat. \forall n:nat.
-bijn f n \to f (S n) = (S n) \to bijn f (S n).
-unfold bijn.intros.
-cut (m < S n \lor m = S n).
-elim Hcut.
-elim (H m).
-elim H4.
-apply (ex_intro ? ? a).split.
-apply le_S.assumption.assumption.
-apply le_S_S_to_le.assumption.
-apply (ex_intro ? ? (S n)).
-split.apply le_n.
-rewrite > H3.assumption.
-apply le_to_or_lt_eq.assumption.
-qed.
-
-theorem bijn_fg: \forall f,g:nat\to nat. \forall n:nat.
-bijn f n \to bijn g n \to bijn (\lambda p.f(g p)) n.
-unfold bijn.
-intros.simplify.
-elim (H m).elim H3.
-elim (H1 a).elim H6.
-apply (ex_intro ? ? a1).
-split.assumption.
-rewrite > H8.assumption.
-assumption.assumption.
-qed.
-
-theorem bijn_transpose : \forall n,i,j. i \le n \to j \le n \to
-bijn (transpose i j) n.
-intros.unfold bijn.unfold transpose.intros.
-cut (m = i \lor \lnot m = i).
-elim Hcut.
-apply (ex_intro ? ? j).
-split.assumption.
-apply (eqb_elim j i).
-intro.simplify.rewrite > H3.rewrite > H4.reflexivity.
-rewrite > (eqb_n_n j).simplify.
-intros. apply sym_eq.assumption.
-cut (m = j \lor \lnot m = j).
-elim Hcut1.
-apply (ex_intro ? ? i).
-split.assumption.
-rewrite > (eqb_n_n i).simplify.
-apply sym_eq. assumption.
-apply (ex_intro ? ? m).
-split.assumption.
-rewrite > (not_eq_to_eqb_false m i).
-rewrite > (not_eq_to_eqb_false m j).
-simplify. reflexivity.
-assumption.
-assumption.
-apply (decidable_eq_nat m j).
-apply (decidable_eq_nat m i).
-qed.
-
-theorem bijn_transpose_r: \forall f:nat\to nat.\forall n,i,j. i \le n \to j \le n \to
-bijn f n \to bijn (\lambda p.f (transpose i j p)) n.
-intros.
-apply (bijn_fg f ?).assumption.
-apply (bijn_transpose n i j).assumption.assumption.
-qed.
-
-theorem bijn_transpose_l: \forall f:nat\to nat.\forall n,i,j. i \le n \to j \le n \to
-bijn f n \to bijn (\lambda p.transpose i j (f p)) n.
-intros.
-apply (bijn_fg ? f).
-apply (bijn_transpose n i j).assumption.assumption.
-assumption.
-qed.
-
-theorem permut_to_bijn: \forall n:nat.\forall f:nat\to nat.
-permut f n \to bijn f n.
-intro.
-elim n.unfold bijn.intros.
-apply (ex_intro ? ? m).
-split.assumption.
-apply (le_n_O_elim m ? (\lambda p. f p = p)).
-assumption.unfold permut in H.
-elim H.apply sym_eq. apply le_n_O_to_eq.apply H2.apply le_n.
-apply (eq_to_bijn (\lambda p.
-(transpose (f (S n1)) (S n1)) (transpose (f (S n1)) (S n1) (f p))) f).
-intros.apply transpose_transpose.
-apply (bijn_fg (transpose (f (S n1)) (S n1))).
-apply bijn_transpose.
-unfold permut in H1.
-elim H1.apply H2.apply le_n.apply le_n.
-apply bijn_n_Sn.
-apply H.
-apply permut_S_to_permut_transpose.
-assumption.unfold transpose.
-rewrite > (eqb_n_n (f (S n1))).simplify.reflexivity.
-qed.
-
-let rec invert_permut n f m \def
- match eqb m (f n) with
- [true \Rightarrow n
- |false \Rightarrow
- match n with
- [O \Rightarrow O
- |(S p) \Rightarrow invert_permut p f m]].
-
-theorem invert_permut_f: \forall f:nat \to nat. \forall n,m:nat.
-m \le n \to injn f n\to invert_permut n f (f m) = m.
-intros 4.
-elim H.
-apply (nat_case1 m).
-intro.simplify.
-rewrite > (eqb_n_n (f O)).simplify.reflexivity.
-intros.simplify.
-rewrite > (eqb_n_n (f (S m1))).simplify.reflexivity.
-simplify.
-rewrite > (not_eq_to_eqb_false (f m) (f (S n1))).
-simplify.apply H2.
-apply injn_Sn_n. assumption.
-unfold Not.intro.absurd (m = S n1).
-apply H3.apply le_S.assumption.apply le_n.assumption.
-unfold Not.intro.
-apply (not_le_Sn_n n1).rewrite < H5.assumption.
-qed.
-
-theorem injective_invert_permut: \forall f:nat \to nat. \forall n:nat.
-permut f n \to injn (invert_permut n f) n.
-intros.
-unfold injn.intros.
-cut (bijn f n).
-unfold bijn in Hcut.
-generalize in match (Hcut i H1).intro.
-generalize in match (Hcut j H2).intro.
-elim H4.elim H6.
-elim H5.elim H9.
-rewrite < H8.
-rewrite < H11.
-apply eq_f.
-rewrite < (invert_permut_f f n a).
-rewrite < (invert_permut_f f n a1).
-rewrite > H8.
-rewrite > H11.
-assumption.assumption.
-unfold permut in H.elim H. assumption.
-assumption.
-unfold permut in H.elim H. assumption.
-apply permut_to_bijn.assumption.
-qed.
-
-theorem permut_invert_permut: \forall f:nat \to nat. \forall n:nat.
-permut f n \to permut (invert_permut n f) n.
-intros.unfold permut.split.
-intros.simplify.elim n.
-simplify.elim (eqb i (f O)).simplify.apply le_n.simplify.apply le_n.
-simplify.elim (eqb i (f (S n1))).simplify.apply le_n.
-simplify.apply le_S. assumption.
-apply injective_invert_permut.assumption.
-qed.
-
-theorem f_invert_permut: \forall f:nat \to nat. \forall n,m:nat.
-m \le n \to permut f n\to f (invert_permut n f m) = m.
-intros.
-apply (injective_invert_permut f n H1).
-unfold permut in H1.elim H1.
-apply H2.
-cut (permut (invert_permut n f) n).unfold permut in Hcut.
-elim Hcut.apply H4.assumption.
-apply permut_invert_permut.assumption.assumption.
-apply invert_permut_f.
-cut (permut (invert_permut n f) n).unfold permut in Hcut.
-elim Hcut.apply H2.assumption.
-apply permut_invert_permut.assumption.
-unfold permut in H1.elim H1.assumption.
-qed.
-
-theorem permut_n_to_eq_n: \forall h:nat \to nat.\forall n:nat.
-permut h n \to (\forall m:nat. m < n \to h m = m) \to h n = n.
-intros.unfold permut in H.elim H.
-cut (invert_permut n h n < n \lor invert_permut n h n = n).
-elim Hcut.
-rewrite < (f_invert_permut h n n) in \vdash (? ? ? %).
-apply eq_f.
-rewrite < (f_invert_permut h n n) in \vdash (? ? % ?).
-apply H1.assumption.apply le_n.assumption.apply le_n.assumption.
-rewrite < H4 in \vdash (? ? % ?).
-apply (f_invert_permut h).apply le_n.assumption.
-apply le_to_or_lt_eq.
-cut (permut (invert_permut n h) n).
-unfold permut in Hcut.elim Hcut.
-apply H4.apply le_n.
-apply permut_invert_permut.assumption.
-qed.
-
-theorem permut_n_to_le: \forall h:nat \to nat.\forall k,n:nat.
-k \le n \to permut h n \to (\forall m:nat. m < k \to h m = m) \to
-\forall j. k \le j \to j \le n \to k \le h j.
-intros.unfold permut in H1.elim H1.
-cut (h j < k \lor \not(h j < k)).
-elim Hcut.absurd (k \le j).assumption.
-apply lt_to_not_le.
-cut (h j = j).rewrite < Hcut1.assumption.
-apply H6.apply H5.assumption.assumption.
-apply H2.assumption.
-apply not_lt_to_le.assumption.
-apply (decidable_lt (h j) k).
-qed.
-
-(* applications *)
-
-let rec map_iter_i k (g:nat \to nat) f (i:nat) \def
- match k with
- [ O \Rightarrow g i
- | (S k) \Rightarrow f (g (S (k+i))) (map_iter_i k g f i)].
-
-theorem eq_map_iter_i: \forall g1,g2:nat \to nat.
-\forall f:nat \to nat \to nat. \forall n,i:nat.
-(\forall m:nat. i\le m \to m \le n+i \to g1 m = g2 m) \to
-map_iter_i n g1 f i = map_iter_i n g2 f i.
-intros 5.elim n.simplify.apply H.apply le_n.
-apply le_n.simplify.apply eq_f2.apply H1.simplify.
-apply le_S.apply le_plus_n.simplify.apply le_n.
-apply H.intros.apply H1.assumption.simplify.apply le_S.assumption.
-qed.
-
-(* map_iter examples *)
-
-theorem eq_map_iter_i_sigma: \forall g:nat \to nat. \forall n,m:nat.
-map_iter_i n g plus m = sigma n g m.
-intros.elim n.simplify.reflexivity.
-simplify.
-apply eq_f.assumption.
-qed.
-
-theorem eq_map_iter_i_pi: \forall g:nat \to nat. \forall n,m:nat.
-map_iter_i n g times m = pi n g m.
-intros.elim n.simplify.reflexivity.
-simplify.
-apply eq_f.assumption.
-qed.
-
-theorem eq_map_iter_i_fact: \forall n:nat.
-map_iter_i n (\lambda m.m) times (S O) = (S n)!.
-intros.elim n.
-simplify.reflexivity.
-change with
-(((S n1)+(S O))*(map_iter_i n1 (\lambda m.m) times (S O)) = (S(S n1))*(S n1)!).
-rewrite < plus_n_Sm.rewrite < plus_n_O.
-apply eq_f.assumption.
-qed.
-
-theorem eq_map_iter_i_transpose_l : \forall f:nat\to nat \to nat.associative nat f \to
-symmetric2 nat nat f \to \forall g:nat \to nat. \forall n,k:nat.
-map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose (k+n) (S k+n) m)) f n.
-intros.apply (nat_case1 k).
-intros.simplify.
-change with
-(f (g (S n)) (g n) =
-f (g (transpose n (S n) (S n))) (g (transpose n (S n) n))).
-rewrite > transpose_i_j_i.
-rewrite > transpose_i_j_j.
-apply H1.
-intros.
-change with
-(f (g (S (S (m+n)))) (f (g (S (m+n))) (map_iter_i m g f n)) =
-f (g (transpose (S m + n) (S (S m) + n) (S (S m)+n)))
-(f (g (transpose (S m + n) (S (S m) + n) (S m+n)))
-(map_iter_i m (\lambda m1. g (transpose (S m+n) (S (S m)+n) m1)) f n))).
-rewrite > transpose_i_j_i.
-rewrite > transpose_i_j_j.
-rewrite < H.
-rewrite < H.
-rewrite < (H1 (g (S m + n))).
-apply eq_f.
-apply eq_map_iter_i.
-intros.simplify.unfold transpose.
-rewrite > (not_eq_to_eqb_false m1 (S m+n)).
-rewrite > (not_eq_to_eqb_false m1 (S (S m)+n)).
-simplify.
-reflexivity.
-apply (lt_to_not_eq m1 (S ((S m)+n))).
-unfold lt.apply le_S_S.change with (m1 \leq S (m+n)).apply le_S.assumption.
-apply (lt_to_not_eq m1 (S m+n)).
-simplify.unfold lt.apply le_S_S.assumption.
-qed.
-
-theorem eq_map_iter_i_transpose_i_Si : \forall f:nat\to nat \to nat.associative nat f \to
-symmetric2 nat nat f \to \forall g:nat \to nat. \forall n,k,i:nat. n \le i \to i \le k+n \to
-map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i (S i) m)) f n.
-intros 6.elim k.cut (i=n).
-rewrite > Hcut.
-apply (eq_map_iter_i_transpose_l f H H1 g n O).
-apply antisymmetric_le.assumption.assumption.
-cut (i < S n1 + n \lor i = S n1 + n).
-elim Hcut.
-change with
-(f (g (S (S n1)+n)) (map_iter_i (S n1) g f n) =
-f (g (transpose i (S i) (S (S n1)+n))) (map_iter_i (S n1) (\lambda m. g (transpose i (S i) m)) f n)).
-apply eq_f2.unfold transpose.
-rewrite > (not_eq_to_eqb_false (S (S n1)+n) i).
-rewrite > (not_eq_to_eqb_false (S (S n1)+n) (S i)).
-simplify.reflexivity.
-simplify.unfold Not.intro.
-apply (lt_to_not_eq i (S n1+n)).assumption.
-apply inj_S.apply sym_eq. assumption.
-simplify.unfold Not.intro.
-apply (lt_to_not_eq i (S (S n1+n))).simplify.unfold lt.
-apply le_S_S.assumption.
-apply sym_eq. assumption.
-apply H2.assumption.apply le_S_S_to_le.
-assumption.
-rewrite > H5.
-apply (eq_map_iter_i_transpose_l f H H1 g n (S n1)).
-apply le_to_or_lt_eq.assumption.
-qed.
-
-theorem eq_map_iter_i_transpose:
-\forall f:nat\to nat \to nat.
-associative nat f \to symmetric2 nat nat f \to \forall n,k,o:nat.
-\forall g:nat \to nat. \forall i:nat. n \le i \to S (o + i) \le S k+n \to
-map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i (S(o + i)) m)) f n.
-intros 6.
-apply (nat_elim1 o).
-intro.
-apply (nat_case m ?).
-intros.
-apply (eq_map_iter_i_transpose_i_Si ? H H1).
-exact H3.apply le_S_S_to_le.assumption.
-intros.
-apply (trans_eq ? ? (map_iter_i (S k) (\lambda m. g (transpose i (S(m1 + i)) m)) f n)).
-apply H2.
-unfold lt. apply le_n.assumption.
-apply (trans_le ? (S(S (m1+i)))).
-apply le_S.apply le_n.assumption.
-apply (trans_eq ? ? (map_iter_i (S k) (\lambda m. g
-(transpose i (S(m1 + i)) (transpose (S(m1 + i)) (S(S(m1 + i))) m))) f n)).
-apply (H2 O ? ? (S(m1+i))).
-unfold lt.apply le_S_S.apply le_O_n.
-apply (trans_le ? i).assumption.
-change with (i \le (S m1)+i).apply le_plus_n.
-exact H4.
-apply (trans_eq ? ? (map_iter_i (S k) (\lambda m. g
-(transpose i (S(m1 + i))
-(transpose (S(m1 + i)) (S(S(m1 + i)))
-(transpose i (S(m1 + i)) m)))) f n)).
-apply (H2 m1).
-unfold lt. apply le_n.assumption.
-apply (trans_le ? (S(S (m1+i)))).
-apply le_S.apply le_n.assumption.
-apply eq_map_iter_i.
-intros.apply eq_f.
-apply sym_eq. apply eq_transpose.
-unfold Not. intro.
-apply (not_le_Sn_n i).
-rewrite < H7 in \vdash (? ? %).
-apply le_S_S.apply le_S.
-apply le_plus_n.
-unfold Not. intro.
-apply (not_le_Sn_n i).
-rewrite > H7 in \vdash (? ? %).
-apply le_S_S.
-apply le_plus_n.
-unfold Not. intro.
-apply (not_eq_n_Sn (S m1+i)).
-apply sym_eq.assumption.
-qed.
-
-theorem eq_map_iter_i_transpose1: \forall f:nat\to nat \to nat.associative nat f \to
-symmetric2 nat nat f \to \forall n,k,i,j:nat.
-\forall g:nat \to nat. n \le i \to i < j \to j \le S k+n \to
-map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i j m)) f n.
-intros.
-simplify in H3.
-cut ((S i) < j \lor (S i) = j).
-elim Hcut.
-cut (j = S ((j - (S i)) + i)).
-rewrite > Hcut1.
-apply (eq_map_iter_i_transpose f H H1 n k (j - (S i)) g i).
-assumption.
-rewrite < Hcut1.assumption.
-rewrite > plus_n_Sm.
-apply plus_minus_m_m.apply lt_to_le.assumption.
-rewrite < H5.
-apply (eq_map_iter_i_transpose_i_Si f H H1 g).
-simplify.
-assumption.apply le_S_S_to_le.
-apply (trans_le ? j).assumption.assumption.
-apply le_to_or_lt_eq.assumption.
-qed.
-
-theorem eq_map_iter_i_transpose2: \forall f:nat\to nat \to nat.associative nat f \to
-symmetric2 nat nat f \to \forall n,k,i,j:nat.
-\forall g:nat \to nat. n \le i \to i \le (S k+n) \to n \le j \to j \le (S k+n) \to
-map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i j m)) f n.
-intros.
-apply (nat_compare_elim i j).
-intro.apply (eq_map_iter_i_transpose1 f H H1 n k i j g H2 H6 H5).
-intro.rewrite > H6.
-apply eq_map_iter_i.intros.
-rewrite > (transpose_i_i j).reflexivity.
-intro.
-apply (trans_eq ? ? (map_iter_i (S k) (\lambda m:nat.g (transpose j i m)) f n)).
-apply (eq_map_iter_i_transpose1 f H H1 n k j i g H4 H6 H3).
-apply eq_map_iter_i.
-intros.apply eq_f.apply transpose_i_j_j_i.
-qed.
-
-theorem permut_to_eq_map_iter_i:\forall f:nat\to nat \to nat.associative nat f \to
-symmetric2 nat nat f \to \forall k,n:nat.\forall g,h:nat \to nat.
-permut h (k+n) \to (\forall m:nat. m \lt n \to h m = m) \to
-map_iter_i k g f n = map_iter_i k (\lambda m.g(h m)) f n.
-intros 4.elim k.
-simplify.rewrite > (permut_n_to_eq_n h).reflexivity.assumption.assumption.
-apply (trans_eq ? ? (map_iter_i (S n) (\lambda m.g ((transpose (h (S n+n1)) (S n+n1)) m)) f n1)).
-unfold permut in H3.
-elim H3.
-apply (eq_map_iter_i_transpose2 f H H1 n1 n ? ? g).
-apply (permut_n_to_le h n1 (S n+n1)).
-apply le_plus_n.assumption.assumption.apply le_plus_n.apply le_n.
-apply H5.apply le_n.apply le_plus_n.apply le_n.
-apply (trans_eq ? ? (map_iter_i (S n) (\lambda m.
-(g(transpose (h (S n+n1)) (S n+n1)
-(transpose (h (S n+n1)) (S n+n1) (h m)))) )f n1)).
-change with
-(f (g (transpose (h (S n+n1)) (S n+n1) (S n+n1)))
-(map_iter_i n (\lambda m.
-g (transpose (h (S n+n1)) (S n+n1) m)) f n1)
-=
-f
-(g(transpose (h (S n+n1)) (S n+n1)
-(transpose (h (S n+n1)) (S n+n1) (h (S n+n1)))))
-(map_iter_i n
-(\lambda m.
-(g(transpose (h (S n+n1)) (S n+n1)
-(transpose (h (S n+n1)) (S n+n1) (h m))))) f n1)).
-apply eq_f2.apply eq_f.
-rewrite > transpose_i_j_j.
-rewrite > transpose_i_j_i.
-rewrite > transpose_i_j_j.reflexivity.
-apply (H2 n1 (\lambda m.(g(transpose (h (S n+n1)) (S n+n1) m)))).
-apply permut_S_to_permut_transpose.
-assumption.
-intros.
-unfold transpose.
-rewrite > (not_eq_to_eqb_false (h m) (h (S n+n1))).
-rewrite > (not_eq_to_eqb_false (h m) (S n+n1)).
-simplify.apply H4.assumption.
-rewrite > H4.
-apply lt_to_not_eq.apply (trans_lt ? n1).assumption.
-simplify.unfold lt.apply le_S_S.apply le_plus_n.assumption.
-unfold permut in H3.elim H3.
-simplify.unfold Not.intro.
-apply (lt_to_not_eq m (S n+n1)).apply (trans_lt ? n1).assumption.
-simplify.unfold lt.apply le_S_S.apply le_plus_n.
-unfold injn in H7.
-apply (H7 m (S n+n1)).apply (trans_le ? n1).
-apply lt_to_le.assumption.apply le_plus_n.apply le_n.
-assumption.
-apply eq_map_iter_i.intros.
-rewrite > transpose_transpose.reflexivity.
-qed.
\ No newline at end of file
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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). *)
-
+++ /dev/null
-(**************************************************************************)
-(* __ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* __ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* __ *)
-(* ||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
+++ /dev/null
-matita.conf.xml.devel
\ No newline at end of file
+++ /dev/null
-<?xml version="1.0" encoding="utf-8"?>
-<helm_registry>
- <section name="user">
- <key name="home">$(HOME)</key>
- </section>
- <section name="matita">
- <key name="basedir">.matita</key>
- <key name="owner">nobody</key>
- </section>
- <section name="db">
- <key name="host">@DBHOST@</key>
- <key name="user">helm</key>
- <key name="database">matita</key>
- </section>
- <section name="getter">
- <key name="cache_dir">.matita/getter/cache</key>
- <key name="prefix">
- cic:/matita/
- file://.matita/xml/matita/
- </key>
- <key name="prefix">
- cic:/
- file:///does_not_exists/
- legacy
- </key>
- </section>
-</helm_registry>
+++ /dev/null
-<?xml version="1.0" encoding="utf-8"?>
-<helm_registry>
- <section name="user">
- <!-- User home directory. Here a ".matita" directory will be created
- and used to store the part of the library developed by the user. -->
- <key name="home">$(HOME)</key>
- <!-- User name. It is used down in this configuration file. If left
- unspecified, name of the user executing matita will be used (as per
- getent) -->
- <!-- <key name="name">foo</key> -->
- </section>
- <section name="matita">
- <!-- Debug only. Stay away. -->
- <!-- <key name="auto_disambiguation">true</key> -->
- <!-- Debug only. Stay away. -->
- <!-- <key name="environment_trust">true</key> -->
- <key name="basedir">$(user.home)/.matita</key>
- <!-- Metadata owner. It will be used to create user-specific tables
- in the SQL database. -->
- <key name="owner">$(user.name)</key>
- <!-- Initial GUI font size. -->
- <!-- <key name="font_size">10</key> -->
- </section>
- <section name="db">
- <!-- Access parameter to the (MySql) metadata database. They are not
- needed if Matita is always run with -nodb, but this is _not_
- recommended since a lot of features wont work.
- Hint. The simplest way to create a database is:
- 0) # become an user with database administration privileges
- 1) mysqladmin create matita
- 2) echo "grant all privileges on matita.* to helm;" | mysql matita
- Note that this way the database will be open to anyone, apply
- stricter permissions if needed.
- -->
- <key name="host">@DBHOST@</key>
- <key name="user">helm</key>
- <key name="database">matita</key>
- </section>
- <section name="getter">
- <!-- Cache dir for CIC XML documents downloaded from the net.
- Beware that this dir may become really space-consuming. It wont be
- used if all prefexises below are local (i.e. "file:///" URI scheme).
- -->
- <key name="cache_dir">$(user.home)/.matita/getter/cache</key>
- <!-- "Prefixes", i.e.: mappings URI -> URL of the global library
- Each prefix mapps an URI of the cic:/ namespace to an URL where the
- documents can actually be accessed. URL can be in the "file://" or
- "http://" scheme. Only "file://" scheme can be used to store
- documents created by the user.
- Each prefix may be given a list of attributes. Currently supported
- attributes are:
- - "legacy" for parts of the library not generated by Matita (e.g.
- exported from Coq)
- - "ro" for parts of the library which are not writable by the user
- (e.g. the Matita standard library)
- "legacy" implies "ro"
- -->
- <key name="prefix">
- cic:/matita/
- file://$(user.home)/.matita/xml/matita/
- </key>
- <key name="prefix">
- cic:/
- file:///projects/helm/library/coq_contribs/
- legacy
- </key>
- </section>
-</helm_registry>
+++ /dev/null
-<?xml version="1.0" encoding="utf-8"?>
-<helm_registry>
- <section name="user">
- <!-- User home directory. Here a ".matita" directory will be created
- and used to store the part of the library developed by the user. -->
- <key name="home">$(HOME)</key>
- <!-- User name. It is used down in this configuration file. If left
- unspecified, name of the user executing matita will be used (as per
- getent) -->
- <!-- <key name="name">foo</key> -->
- </section>
- <section name="matita">
- <!-- Debug only. Stay away. -->
- <!-- <key name="auto_disambiguation">true</key> -->
- <!-- Debug only. Stay away. -->
- <!-- <key name="environment_trust">true</key> -->
- <key name="basedir">$(user.home)/.matita</key>
- <!-- Metadata owner. It will be used to create user-specific tables
- in the SQL database. -->
- <key name="owner">$(user.name)</key>
- <!-- Initial GUI font size. -->
- <!-- <key name="font_size">10</key> -->
- </section>
- <section name="db">
- <!-- Access parameter to the (MySql) metadata database. They are not
- needed if Matita is always run with -nodb, but this is _not_
- recommended since a lot of features wont work.
- Hint. The simplest way to create a database is:
- 0) # become an user with database administration privileges
- 1) mysqladmin create matita
- 2) echo "grant all privileges on matita.* to helm;" | mysql matita
- Note that this way the database will be open to anyone, apply
- stricter permissions if needed.
- -->
- <key name="host">@DBHOST@</key>
- <key name="user">helm</key>
- <key name="database">matita</key>
- </section>
- <section name="getter">
- <!-- Cache dir for CIC XML documents downloaded from the net.
- Beware that this dir may become really space-consuming. It wont be
- used if all prefexises below are local (i.e. "file:///" URI scheme).
- -->
- <key name="cache_dir">$(user.home)/.matita/getter/cache</key>
- <!-- "Prefixes", i.e.: mappings URI -> URL of the global library
- Each prefix mapps an URI of the cic:/ namespace to an URL where the
- documents can actually be accessed. URL can be in the "file://" or
- "http://" scheme. Only "file://" scheme can be used to store
- documents created by the user.
- Each prefix may be given a list of attributes. Currently supported
- attributes are:
- - "legacy" for parts of the library not generated by Matita (e.g.
- exported from Coq)
- - "ro" for parts of the library which are not writable by the user
- (e.g. the Matita standard library)
- "legacy" implies "ro"
- -->
- <key name="prefix">
- cic:/matita/
- file://@RT_BASE_DIR@/library/
- ro
- </key>
- <key name="prefix">
- cic:/matita/$(user.name)/
- file://$(user.home)/.matita/xml/matita/
- </key>
- <key name="prefix">
- cic:/
- file://@RT_BASE_DIR@/legacy/coq/
- legacy
- </key>
- </section>
-</helm_registry>
+++ /dev/null
-<?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 & 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 & 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>
+++ /dev/null
-# 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"
-
+++ /dev/null
-<?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>"</start-regex>
- <end-regex>"</end-regex>
- </string>
-
-</language>
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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/".
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-
-open MatitaGtkMisc
-open GrafiteTypes
-
-(** {2 Initialization} *)
-
-let _ = MatitaInit.initialize_all ()
-(* let _ = Saturation.init () (* ALB to link paramodulation *) *)
-
-(** {2 GUI callbacks} *)
-
-let gui = MatitaGui.instance ()
-
-let script =
- let s =
- MatitaScript.script
- ~source_view:gui#sourceView
- ~mathviewer:(MatitaMathView.mathViewer ())
- ~urichooser:(fun uris ->
- try
- MatitaGui.interactive_uri_choice ~selection_mode:`SINGLE
- ~title:"Matita: URI chooser"
- ~msg:"Select the URI" ~hide_uri_entry:true
- ~hide_try:true ~ok_label:"_Apply" ~ok_action:`SELECT
- ~copy_cb:(fun s -> gui#sourceView#buffer#insert ("\n"^s^"\n"))
- () ~id:"boh?" uris
- with MatitaTypes.Cancel -> [])
- ~set_star:gui#setStar
- ~ask_confirmation:
- (fun ~title ~message ->
- MatitaGtkMisc.ask_confirmation ~title ~message
- ~parent:gui#main#toplevel ())
- ~develcreator:gui#createDevelopment
- ()
- in
- gui#sourceView#source_buffer#begin_not_undoable_action ();
- s#reset ();
- s#template ();
- gui#sourceView#source_buffer#end_not_undoable_action ();
- s
-
- (* math viewers *)
-let _ =
- let cic_math_view = MatitaMathView.cicMathView_instance () in
- let sequents_viewer = MatitaMathView.sequentsViewer_instance () in
- sequents_viewer#load_logo;
- cic_math_view#set_href_callback
- (Some (fun uri -> (MatitaMathView.cicBrowser ())#load
- (`Uri (UriManager.uri_of_string uri))));
- let browser_observer _ _ = MatitaMathView.refresh_all_browsers () in
- let sequents_observer _ grafite_status =
- sequents_viewer#reset;
- match grafite_status.proof_status with
- | Incomplete_proof ({ stack = stack } as incomplete_proof) ->
- sequents_viewer#load_sequents incomplete_proof;
- (try
- script#setGoal (Some (Continuationals.Stack.find_goal stack));
- let goal =
- match script#goal with
- None -> assert false
- | Some n -> n
- in
- sequents_viewer#goto_sequent goal
- with Failure _ -> script#setGoal None);
- | Proof proof -> sequents_viewer#load_logo_with_qed
- | No_proof -> sequents_viewer#load_logo
- | Intermediate _ -> assert false (* only the engine may be in this state *)
- in
- script#addObserver sequents_observer;
- script#addObserver browser_observer
-
- (** {{{ Debugging *)
-let _ =
- if BuildTimeConf.debug then begin
- gui#main#debugMenu#misc#show ();
- let addDebugItem ~label callback =
- let item =
- GMenu.menu_item ~packing:gui#main#debugMenu_menu#append ~label ()
- in
- ignore (item#connect#activate callback)
- in
- addDebugItem "dump environment to \"env.dump\"" (fun _ ->
- let oc = open_out "env.dump" in
- CicEnvironment.dump_to_channel oc;
- close_out oc);
- addDebugItem "load environment from \"env.dump\"" (fun _ ->
- let ic = open_in "env.dump" in
- CicEnvironment.restore_from_channel ic;
- close_in ic);
- addDebugItem "dump universes" (fun _ ->
- List.iter (fun (u,_,g) ->
- prerr_endline (UriManager.string_of_uri u);
- CicUniv.print_ugraph g) (CicEnvironment.list_obj ())
- );
- addDebugItem "dump environment content" (fun _ ->
- List.iter (fun (u,_,_) ->
- prerr_endline (UriManager.string_of_uri u))
- (CicEnvironment.list_obj ()));
-(* addDebugItem "print selections" (fun () ->
- let cicMathView = MatitaMathView.cicMathView_instance () in
- List.iter HLog.debug (cicMathView#string_of_selections)); *)
- addDebugItem "dump script status" script#dump;
- addDebugItem "dump configuration file to ./foo.conf.xml" (fun _ ->
- Helm_registry.save_to "./foo.conf.xml");
- addDebugItem "dump metasenv"
- (fun _ ->
- if script#onGoingProof () then
- HLog.debug (CicMetaSubst.ppmetasenv [] script#proofMetasenv));
- addDebugItem "dump coercions Db" (fun _ ->
- List.iter
- (fun (s,t,u) ->
- HLog.debug
- (UriManager.name_of_uri u ^ ":"
- ^ CoercDb.name_of_carr s ^ " -> " ^ CoercDb.name_of_carr t))
- (CoercDb.to_list ()));
- addDebugItem "print top-level grammar entries"
- CicNotationParser.print_l2_pattern;
- addDebugItem "dump moo to stderr" (fun _ ->
- let grafite_status = (MatitaScript.current ())#grafite_status in
- let moo = grafite_status.moo_content_rev in
- List.iter
- (fun cmd ->
- prerr_endline (GrafiteAstPp.pp_command ~obj_pp:(fun _ -> assert false)
- cmd))
- (List.rev moo));
- addDebugItem "print metasenv goals and stack to stderr"
- (fun _ ->
- prerr_endline ("metasenv goals: " ^ String.concat " "
- (List.map (fun (g, _, _) -> string_of_int g)
- (MatitaScript.current ())#proofMetasenv));
- prerr_endline ("stack: " ^ Continuationals.Stack.pp
- (GrafiteTypes.get_stack (MatitaScript.current ())#grafite_status)));
-(* addDebugItem "ask record choice"
- (fun _ ->
- HLog.debug (string_of_int
- (MatitaGtkMisc.ask_record_choice ~gui ~title:"title" ~message:"msg"
- ~fields:["a"; "b"; "c"]
- ~records:[
- ["0"; "0"; "0"]; ["0"; "0"; "1"]; ["0"; "1"; "0"]; ["0"; "1"; "1"];
- ["1"; "0"; "0"]; ["1"; "0"; "1"]; ["1"; "1"; "0"]; ["1"; "1"; "1"]]
- ()))); *)
- addDebugItem "rotate light bulbs"
- (fun _ ->
- let nb = gui#main#hintNotebook in
- nb#goto_page ((nb#current_page + 1) mod 3));
- addDebugItem "print runtime dir"
- (fun _ ->
- prerr_endline BuildTimeConf.runtime_base_dir);
- addDebugItem "disable all (pretty printing) notations"
- (fun _ -> CicNotation.set_active_notations []);
- addDebugItem "enable all (pretty printing) notations"
- (fun _ ->
- CicNotation.set_active_notations
- (List.map fst (CicNotation.get_all_notations ())));
- end
- (** Debugging }}} *)
-
- (** {2 Command line parsing} *)
-
-let set_matita_mode () =
- let matita_mode =
- if Filename.basename Sys.argv.(0) = "cicbrowser" ||
- Filename.basename Sys.argv.(0) = "cicbrowser.opt"
- then "cicbrowser"
- else "matita"
- in
- Helm_registry.set "matita.mode" matita_mode
-
- (** {2 Main} *)
-
-let _ =
- set_matita_mode ();
- at_exit (fun () -> print_endline "\nThanks for using Matita!\n");
- Sys.catch_break true;
- let args = Helm_registry.get_list Helm_registry.string "matita.args" in
- if Helm_registry.get "matita.mode" = "cicbrowser" then (* cicbrowser *)
- let browser = MatitaMathView.cicBrowser () in
- let uri = match args with [] -> "cic:/" | _ -> String.concat " " args in
- browser#loadInput uri
- else begin (* matita *)
- (try gui#loadScript (List.hd args) with Failure _ -> ());
- gui#main#mainWin#show ();
- end;
- try
- GtkThread.main ()
- with Sys.Break -> ()
-
-(* vim:set foldmethod=marker: *)
+++ /dev/null
- 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 *)
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 _ _ -> ())
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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)
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 :=
- (function
- | MatitaScript.ActionCancelled -> ()
- | exn ->
- if not (Helm_registry.get_bool "matita.debug") then
- let floc, msg = MatitaExcPp.to_string exn in
- begin
- match floc with
- None -> ()
- | Some floc ->
- let (x, y) = HExtlib.loc_of_floc floc in
- let script = MatitaScript.current () in
- let locked_mark = script#locked_mark in
- let error_tag = script#error_tag in
- let baseoffset =
- (source_buffer#get_iter_at_mark (`MARK locked_mark))#offset in
- let x' = baseoffset + x in
- let y' = baseoffset + y in
- let x_iter = source_buffer#get_iter (`OFFSET x') in
- let y_iter = source_buffer#get_iter (`OFFSET y') in
- source_buffer#apply_tag error_tag ~start:x_iter ~stop:y_iter;
- let id = ref None in
- id := Some (source_buffer#connect#changed ~callback:(fun () ->
- source_buffer#remove_tag error_tag
- ~start:source_buffer#start_iter
- ~stop:source_buffer#end_iter;
- match !id with
- | None -> assert false (* a race condition occurred *)
- | Some id ->
- (new GObj.gobject_ops source_buffer#as_buffer)#disconnect id));
- source_buffer#place_cursor
- (source_buffer#get_iter (`OFFSET x'));
- end;
- HLog.error msg
- else raise exn);
- (* script *)
- ignore (source_buffer#connect#mark_set (fun _ _ -> next_ligatures <- []));
- let _ =
- match GSourceView.source_language_from_file BuildTimeConf.lang_file with
- | None ->
- HLog.warn (sprintf "can't load language file %s"
- BuildTimeConf.lang_file)
- | Some matita_lang ->
- source_buffer#set_language matita_lang;
- source_buffer#set_highlight true
- in
- let s () = MatitaScript.current () in
- let disableSave () =
- script_fname <- None;
- main#saveMenuItem#misc#set_sensitive false
- in
- let saveAsScript () =
- let script = s () in
- match self#chooseFile ~ok_not_exists:true () with
- | Some f ->
- script#assignFileName f;
- script#saveToFile ();
- console#message ("'"^f^"' saved.\n");
- self#_enableSaveTo f
- | None -> ()
- in
- let saveScript () =
- match script_fname with
- | None -> saveAsScript ()
- | Some f ->
- (s ())#assignFileName f;
- (s ())#saveToFile ();
- console#message ("'"^f^"' saved.\n");
- in
- let abandon_script () =
- let lexicon_status = (s ())#lexicon_status in
- let grafite_status = (s ())#grafite_status in
- if source_view#buffer#modified then
- (match ask_unsaved main#toplevel with
- | `YES -> saveScript ()
- | `NO -> ()
- | `CANCEL -> raise MatitaTypes.Cancel);
- (match script_fname with
- | None -> ()
- | Some fname ->
- ask_and_save_moo_if_needed main#toplevel fname
- lexicon_status grafite_status);
- in
- let loadScript () =
- let script = s () in
- try
- match self#chooseFile () with
- | Some f ->
- abandon_script ();
- script#reset ();
- script#assignFileName f;
- source_view#source_buffer#begin_not_undoable_action ();
- script#loadFromFile f;
- source_view#source_buffer#end_not_undoable_action ();
- console#message ("'"^f^"' loaded.\n");
- self#_enableSaveTo f
- | None -> ()
- with MatitaTypes.Cancel -> ()
- in
- let newScript () =
- abandon_script ();
- source_view#source_buffer#begin_not_undoable_action ();
- (s ())#reset ();
- (s ())#template ();
- source_view#source_buffer#end_not_undoable_action ();
- disableSave ();
- script_fname <- None
- in
- let cursor () =
- source_buffer#place_cursor
- (source_buffer#get_iter_at_mark (`NAME "locked")) in
- let advance _ = (MatitaScript.current ())#advance (); cursor () in
- let retract _ = (MatitaScript.current ())#retract (); cursor () in
- let top _ = (MatitaScript.current ())#goto `Top (); cursor () in
- let bottom _ = (MatitaScript.current ())#goto `Bottom (); cursor () in
- let jump _ = (MatitaScript.current ())#goto `Cursor (); cursor () in
- let advance = locker (keep_focus advance) in
- let retract = locker (keep_focus retract) in
- let top = locker (keep_focus top) in
- let bottom = locker (keep_focus bottom) in
- let jump = locker (keep_focus jump) in
- (* quit *)
- self#setQuitCallback (fun () ->
- let lexicon_status = (MatitaScript.current ())#lexicon_status in
- let grafite_status = (MatitaScript.current ())#grafite_status in
- if source_view#buffer#modified then
- begin
- let rc = ask_unsaved main#toplevel in
- try
- match rc with
- | `YES -> saveScript ();
- if not source_view#buffer#modified then
- begin
- (match script_fname with
- | None -> ()
- | Some fname ->
- ask_and_save_moo_if_needed main#toplevel
- fname lexicon_status grafite_status);
- GMain.Main.quit ()
- end
- | `NO -> GMain.Main.quit ()
- | `CANCEL -> raise MatitaTypes.Cancel
- with MatitaTypes.Cancel -> ()
- end
- else
- begin
- (match script_fname with
- | None -> clean_current_baseuri grafite_status; GMain.Main.quit ()
- | Some fname ->
- try
- ask_and_save_moo_if_needed main#toplevel fname lexicon_status
- grafite_status;
- GMain.Main.quit ()
- with MatitaTypes.Cancel -> ())
- end);
- connect_button main#scriptAdvanceButton advance;
- connect_button main#scriptRetractButton retract;
- connect_button main#scriptTopButton top;
- connect_button main#scriptBottomButton bottom;
- connect_button main#scriptJumpButton jump;
- connect_menu_item main#scriptAdvanceMenuItem advance;
- connect_menu_item main#scriptRetractMenuItem retract;
- connect_menu_item main#scriptTopMenuItem top;
- connect_menu_item main#scriptBottomMenuItem bottom;
- connect_menu_item main#scriptJumpMenuItem jump;
- connect_menu_item main#openMenuItem loadScript;
- connect_menu_item main#saveMenuItem saveScript;
- connect_menu_item main#saveAsMenuItem saveAsScript;
- connect_menu_item main#newMenuItem newScript;
- (* script monospace font stuff *)
- self#updateFontSize ();
- (* debug menu *)
- main#debugMenu#misc#hide ();
- (* status bar *)
- main#hintLowImage#set_file (image_path "matita-bulb-low.png");
- main#hintMediumImage#set_file (image_path "matita-bulb-medium.png");
- main#hintHighImage#set_file (image_path "matita-bulb-high.png");
- (* focus *)
- self#sourceView#misc#grab_focus ();
- (* main win dimension *)
- let width = Gdk.Screen.width () in
- let height = Gdk.Screen.height () in
- let main_w = width * 90 / 100 in
- let main_h = height * 80 / 100 in
- let script_w = main_w * 6 / 10 in
- main#toplevel#resize ~width:main_w ~height:main_h;
- main#hpaneScriptSequent#set_position script_w;
- (* source_view *)
- ignore(source_view#connect#after#paste_clipboard
- ~callback:(fun () -> (MatitaScript.current ())#clean_dirty_lock));
- (* clean_locked is set to true only "during" a PRIMARY paste
- operation (i.e. by clicking with the second mouse button) *)
- let clean_locked = ref false in
- ignore(source_view#event#connect#button_press
- ~callback:
- (fun button ->
- if GdkEvent.Button.button button = 2 then
- clean_locked := true;
- false
- ));
- ignore(source_view#event#connect#button_release
- ~callback:(fun button -> clean_locked := false; false));
- ignore(source_view#buffer#connect#after#apply_tag
- ~callback:(
- fun tag ~start:_ ~stop:_ ->
- if !clean_locked &&
- tag#get_oid = (MatitaScript.current ())#locked_tag#get_oid
- then
- begin
- clean_locked := false;
- (MatitaScript.current ())#clean_dirty_lock;
- clean_locked := true
- end));
- (* math view handling *)
- connect_menu_item main#newCicBrowserMenuItem (fun () ->
- ignore (MatitaMathView.cicBrowser ()));
- connect_menu_item main#increaseFontSizeMenuItem (fun () ->
- self#increaseFontSize ();
- MatitaMathView.increase_font_size ();
- MatitaMathView.update_font_sizes ());
- connect_menu_item main#decreaseFontSizeMenuItem (fun () ->
- self#decreaseFontSize ();
- MatitaMathView.decrease_font_size ();
- MatitaMathView.update_font_sizes ());
- connect_menu_item main#normalFontSizeMenuItem (fun () ->
- self#resetFontSize ();
- MatitaMathView.reset_font_size ();
- MatitaMathView.update_font_sizes ());
- MatitaMathView.reset_font_size ();
-
- (** selections / clipboards handling *)
-
- method markupSelected = MatitaMathView.has_selection ()
- method private textSelected =
- (source_buffer#get_iter_at_mark `INSERT)#compare
- (source_buffer#get_iter_at_mark `SEL_BOUND) <> 0
- method private somethingSelected = self#markupSelected || self#textSelected
- method private markupStored = MatitaMathView.has_clipboard ()
- method private textStored = clipboard#text <> None
- method private somethingStored = self#markupStored || self#textStored
-
- method canCopy = self#somethingSelected
- method canCut = self#textSelected
- method canDelete = self#textSelected
- method canPaste = self#somethingStored
- method canPastePattern = self#markupStored
-
- method copy () =
- if self#textSelected
- then begin
- MatitaMathView.empty_clipboard ();
- source_view#buffer#copy_clipboard clipboard;
- end else
- MatitaMathView.copy_selection ()
- method cut () =
- source_view#buffer#cut_clipboard clipboard;
- MatitaMathView.empty_clipboard ()
- method delete () = ignore (source_view#buffer#delete_selection ())
- method paste () =
- if MatitaMathView.has_clipboard ()
- then source_view#buffer#insert (MatitaMathView.paste_clipboard `Term)
- else source_view#buffer#paste_clipboard clipboard;
- (MatitaScript.current ())#clean_dirty_lock
- method pastePattern () =
- source_view#buffer#insert (MatitaMathView.paste_clipboard `Pattern)
-
- method private nextLigature () =
- let iter = source_buffer#get_iter_at_mark `INSERT in
- let write_ligature len s =
- source_buffer#delete ~start:iter ~stop:(iter#copy#backward_chars len);
- source_buffer#insert ~iter:(source_buffer#get_iter_at_mark `INSERT) s
- in
- let get_ligature word =
- let len = String.length word in
- let aux_tex () =
- try
- for i = len - 1 downto 0 do
- if HExtlib.is_alpha word.[i] then ()
- else
- (if word.[i] = '\\' then raise (Found i) else raise (Found ~-1))
- done;
- None
- with Found i ->
- if i = ~-1 then None else Some (String.sub word i (len - i))
- in
- let aux_ligature () =
- try
- for i = len - 1 downto 0 do
- if CicNotationLexer.is_ligature_char word.[i] then ()
- else raise (Found (i+1))
- done;
- raise (Found 0)
- with
- | Found i ->
- (try
- Some (String.sub word i (len - i))
- with Invalid_argument _ -> None)
- in
- match aux_tex () with
- | Some macro -> macro
- | None -> (match aux_ligature () with Some l -> l | None -> word)
- in
- (match next_ligatures with
- | [] -> (* find ligatures and fill next_ligatures, then try again *)
- let last_word =
- iter#get_slice
- ~stop:(iter#copy#backward_find_char Glib.Unichar.isspace)
- in
- let ligature = get_ligature last_word in
- (match CicNotationLexer.lookup_ligatures ligature with
- | [] -> ()
- | hd :: tl ->
- write_ligature (String.length ligature) hd;
- next_ligatures <- tl @ [ hd ])
- | hd :: tl ->
- write_ligature 1 hd;
- next_ligatures <- tl @ [ hd ])
-
- method private externalEditor () =
- let cmd = Helm_registry.get "matita.external_editor" in
-(* ZACK uncomment to enable interactive ask of external editor command *)
-(* let cmd =
- let msg =
- "External editor command:
-%f will be substitute for the script name,
-%p for the cursor position in bytes,
-%l for the execution point in bytes."
- in
- ask_text ~gui:self ~title:"External editor" ~msg ~multiline:false
- ~default:(Helm_registry.get "matita.external_editor") ()
- in *)
- let fname = (MatitaScript.current ())#filename in
- let slice mark =
- source_buffer#start_iter#get_slice
- ~stop:(source_buffer#get_iter_at_mark mark)
- in
- let script = MatitaScript.current () in
- let locked = `MARK script#locked_mark in
- let string_pos mark = string_of_int (String.length (slice mark)) in
- let cursor_pos = string_pos `INSERT in
- let locked_pos = string_pos locked in
- let cmd =
- Pcre.replace ~pat:"%f" ~templ:fname
- (Pcre.replace ~pat:"%p" ~templ:cursor_pos
- (Pcre.replace ~pat:"%l" ~templ:locked_pos
- cmd))
- in
- let locked_before = slice locked in
- let locked_offset = (source_buffer#get_iter_at_mark locked)#offset in
- ignore (Unix.system cmd);
- source_buffer#set_text (HExtlib.input_file fname);
- let locked_iter = source_buffer#get_iter (`OFFSET locked_offset) in
- source_buffer#move_mark locked locked_iter;
- source_buffer#apply_tag script#locked_tag
- ~start:source_buffer#start_iter ~stop:locked_iter;
- let locked_after = slice locked in
- let line = ref 0 in
- let col = ref 0 in
- try
- for i = 0 to String.length locked_before - 1 do
- if locked_before.[i] <> locked_after.[i] then begin
- source_buffer#place_cursor
- ~where:(source_buffer#get_iter (`LINEBYTE (!line, !col)));
- script#goto `Cursor ();
- raise Exit
- end else if locked_before.[i] = '\n' then begin
- incr line;
- col := 0
- end
- done
- with
- | Exit -> ()
- | Invalid_argument _ -> script#goto `Bottom ()
-
- method loadScript file =
- let script = MatitaScript.current () in
- script#reset ();
- script#assignFileName file;
- let content =
- if Sys.file_exists file then file
- else BuildTimeConf.script_template
- in
- source_view#source_buffer#begin_not_undoable_action ();
- script#loadFromFile content;
- source_view#source_buffer#end_not_undoable_action ();
- console#message ("'"^file^"' loaded.");
- self#_enableSaveTo file
-
- method setStar name b =
- let l = main#scriptLabel in
- if b then
- l#set_text (name ^ " *")
- else
- l#set_text (name)
-
- method private _enableSaveTo file =
- script_fname <- Some file;
- self#main#saveMenuItem#misc#set_sensitive true
-
- method console = console
- method sourceView: GSourceView.source_view =
- (source_view: GSourceView.source_view)
- method fileSel = fileSel
- method findRepl = findRepl
- method main = main
- method develList = develList
- method newDevel = newDevel
-
- method newBrowserWin () =
- object (self)
- inherit browserWin ()
- val combo = GEdit.combo_box_entry ()
- initializer
- self#check_widgets ();
- let combo_widget = combo#coerce in
- uriHBox#pack ~from:`END ~fill:true ~expand:true combo_widget;
- combo#entry#misc#grab_focus ()
- method browserUri = combo
- end
-
- method newUriDialog () =
- let dialog = new uriChoiceDialog () in
- dialog#check_widgets ();
- dialog
-
- method newRecordDialog () =
- let dialog = new recordChoiceDialog () in
- dialog#check_widgets ();
- dialog
-
- method newConfirmationDialog () =
- let dialog = new confirmationDialog () in
- dialog#check_widgets ();
- dialog
-
- method newEmptyDialog () =
- let dialog = new emptyDialog () in
- dialog#check_widgets ();
- dialog
-
- method private addKeyBinding key callback =
- List.iter (fun evbox -> add_key_binding key callback evbox)
- keyBindingBoxes
-
- method setQuitCallback callback =
- connect_menu_item main#quitMenuItem callback;
- ignore (main#toplevel#event#connect#delete
- (fun _ -> callback ();true));
- self#addKeyBinding GdkKeysyms._q callback
-
- method chooseFile ?(ok_not_exists = false) () =
- _ok_not_exists <- ok_not_exists;
- _only_directory <- false;
- fileSel#fileSelectionWin#show ();
- GtkThread.main ();
- chosen_file
-
- method private chooseDir ?(ok_not_exists = false) () =
- _ok_not_exists <- ok_not_exists;
- _only_directory <- true;
- fileSel#fileSelectionWin#show ();
- GtkThread.main ();
- (* we should check that this is a directory *)
- chosen_file
-
- method createDevelopment ~containing =
- next_devel_must_contain <- containing;
- newDevel#toplevel#misc#show()
-
- method askText ?(title = "") ?(msg = "") () =
- let dialog = new textDialog () in
- dialog#textDialog#set_title title;
- dialog#textDialogLabel#set_label msg;
- let text = ref None in
- let return v =
- text := v;
- dialog#textDialog#destroy ();
- GMain.Main.quit ()
- in
- ignore (dialog#textDialog#event#connect#delete (fun _ -> true));
- connect_button dialog#textDialogCancelButton (fun _ -> return None);
- connect_button dialog#textDialogOkButton (fun _ ->
- let text = dialog#textDialogTextView#buffer#get_text () in
- return (Some text));
- dialog#textDialog#show ();
- GtkThread.main ();
- !text
-
- method private updateFontSize () =
- self#sourceView#misc#modify_font_by_name
- (sprintf "%s %d" BuildTimeConf.script_font font_size)
-
- method increaseFontSize () =
- font_size <- font_size + 1;
- self#updateFontSize ()
-
- method decreaseFontSize () =
- font_size <- font_size - 1;
- self#updateFontSize ()
-
- method resetFontSize () =
- font_size <- default_font_size;
- self#updateFontSize ()
-
- end
-
-let gui () =
- let g = new gui () in
- gui_instance := Some g;
- MatitaMathView.set_gui g;
- g
-
-let instance = singleton gui
-
-let non p x = not (p x)
-
-(* this is a shit and should be changed :-{ *)
-let interactive_uri_choice
- ?(selection_mode:[`SINGLE|`MULTIPLE] = `MULTIPLE) ?(title = "")
- ?(msg = "") ?(nonvars_button = false) ?(hide_uri_entry=false)
- ?(hide_try=false) ?(ok_label="_Auto") ?(ok_action:[`SELECT|`AUTO] = `AUTO)
- ?copy_cb ()
- ~id uris
-=
- let gui = instance () in
- let nonvars_uris = lazy (List.filter (non UriManager.uri_is_var) uris) in
- if (selection_mode <> `SINGLE) &&
- (Helm_registry.get_bool "matita.auto_disambiguation")
- then
- Lazy.force nonvars_uris
- else begin
- let dialog = gui#newUriDialog () in
- if hide_uri_entry then
- dialog#uriEntryHBox#misc#hide ();
- if hide_try then
- begin
- dialog#uriChoiceSelectedButton#misc#hide ();
- dialog#uriChoiceConstantsButton#misc#hide ();
- end;
- dialog#okLabel#set_label ok_label;
- dialog#uriChoiceTreeView#selection#set_mode
- (selection_mode :> Gtk.Tags.selection_mode);
- let model = new stringListModel dialog#uriChoiceTreeView in
- let choices = ref None in
- (match copy_cb with
- | None -> ()
- | Some cb ->
- dialog#copyButton#misc#show ();
- connect_button dialog#copyButton
- (fun _ ->
- match model#easy_selection () with
- | [u] -> (cb u)
- | _ -> ()));
- dialog#uriChoiceDialog#set_title title;
- dialog#uriChoiceLabel#set_text msg;
- List.iter model#easy_append (List.map UriManager.string_of_uri uris);
- dialog#uriChoiceConstantsButton#misc#set_sensitive nonvars_button;
- let return v =
- choices := v;
- dialog#uriChoiceDialog#destroy ();
- GMain.Main.quit ()
- in
- ignore (dialog#uriChoiceDialog#event#connect#delete (fun _ -> true));
- connect_button dialog#uriChoiceConstantsButton (fun _ ->
- return (Some (Lazy.force nonvars_uris)));
- if ok_action = `AUTO then
- connect_button dialog#uriChoiceAutoButton (fun _ ->
- Helm_registry.set_bool "matita.auto_disambiguation" true;
- return (Some (Lazy.force nonvars_uris)))
- else
- connect_button dialog#uriChoiceAutoButton (fun _ ->
- match model#easy_selection () with
- | [] -> ()
- | uris -> return (Some (List.map UriManager.uri_of_string uris)));
- connect_button dialog#uriChoiceSelectedButton (fun _ ->
- match model#easy_selection () with
- | [] -> ()
- | uris -> return (Some (List.map UriManager.uri_of_string uris)));
- connect_button dialog#uriChoiceAbortButton (fun _ -> return None);
- dialog#uriChoiceDialog#show ();
- GtkThread.main ();
- (match !choices with
- | None -> raise MatitaTypes.Cancel
- | Some uris -> uris)
- end
-
-class interpModel =
- let cols = new GTree.column_list in
- let id_col = cols#add Gobject.Data.string in
- let dsc_col = cols#add Gobject.Data.string in
- let interp_no_col = cols#add Gobject.Data.int in
- let tree_store = GTree.tree_store cols in
- let id_renderer = GTree.cell_renderer_text [], ["text", id_col] in
- let dsc_renderer = GTree.cell_renderer_text [], ["text", dsc_col] in
- let id_view_col = GTree.view_column ~renderer:id_renderer () in
- let dsc_view_col = GTree.view_column ~renderer:dsc_renderer () in
- fun tree_view choices ->
- object
- initializer
- tree_view#set_model (Some (tree_store :> GTree.model));
- ignore (tree_view#append_column id_view_col);
- ignore (tree_view#append_column dsc_view_col);
- let name_of_interp =
- (* try to find a reasonable name for an interpretation *)
- let idx = ref 0 in
- fun interp ->
- try
- List.assoc "0" interp
- with Not_found ->
- incr idx; string_of_int !idx
- in
- tree_store#clear ();
- let idx = ref ~-1 in
- List.iter
- (fun interp ->
- incr idx;
- let interp_row = tree_store#append () in
- tree_store#set ~row:interp_row ~column:id_col
- (name_of_interp interp);
- tree_store#set ~row:interp_row ~column:interp_no_col !idx;
- List.iter
- (fun (id, dsc) ->
- let row = tree_store#append ~parent:interp_row () in
- tree_store#set ~row ~column:id_col id;
- tree_store#set ~row ~column:dsc_col dsc;
- tree_store#set ~row ~column:interp_no_col !idx)
- interp)
- choices
-
- method get_interp_no tree_path =
- let iter = tree_store#get_iter tree_path in
- tree_store#get ~row:iter ~column:interp_no_col
- end
-
-let interactive_interp_choice () choices =
- let gui = instance () in
- assert (choices <> []);
- let dialog = gui#newRecordDialog () in
- let model = new interpModel dialog#recordChoiceTreeView choices in
- dialog#recordChoiceDialog#set_title "Interpretation choice";
- dialog#recordChoiceDialogLabel#set_label "Choose an interpretation:";
- let interp_no = ref None in
- let return _ =
- dialog#recordChoiceDialog#destroy ();
- GMain.Main.quit ()
- in
- let fail _ = interp_no := None; return () in
- ignore (dialog#recordChoiceDialog#event#connect#delete (fun _ -> true));
- connect_button dialog#recordChoiceOkButton (fun _ ->
- match !interp_no with None -> () | Some _ -> return ());
- connect_button dialog#recordChoiceCancelButton fail;
- ignore (dialog#recordChoiceTreeView#connect#row_activated (fun path _ ->
- interp_no := Some (model#get_interp_no path);
- return ()));
- let selection = dialog#recordChoiceTreeView#selection in
- ignore (selection#connect#changed (fun _ ->
- match selection#get_selected_rows with
- | [path] -> interp_no := Some (model#get_interp_no path)
- | _ -> assert false));
- dialog#recordChoiceDialog#show ();
- GtkThread.main ();
- (match !interp_no with Some row -> [row] | _ -> raise MatitaTypes.Cancel)
-
-let _ =
- (* disambiguator callbacks *)
- GrafiteDisambiguator.set_choose_uris_callback (interactive_uri_choice ());
- GrafiteDisambiguator.set_choose_interp_callback (interactive_interp_choice ());
- (* gtk initialization *)
- GtkMain.Rc.add_default_file BuildTimeConf.gtkrc_file; (* loads gtk rc *)
- GMathView.add_configuration_path BuildTimeConf.gtkmathview_conf;
- ignore (GMain.Main.init ())
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-
-type thingsToInitilaize =
- ConfigurationFile | Db | Environment | Getter | Makelib | CmdLine | Registry
-
-exception FailedToInitialize of thingsToInitilaize
-
-let wants s l =
- List.iter (
- fun item ->
- if not (List.exists (fun x -> x = item) l) then
- raise (FailedToInitialize item))
- s
-
-let already_configured s l =
- List.for_all (fun item -> List.exists (fun x -> x = item) l) s
-
-let conffile = ref BuildTimeConf.matita_conf
-
-let registry_defaults =
- [
- "db.nodb", "false";
- "matita.system", "false";
- "matita.debug", "false";
- "matita.external_editor", "gvim -f -c 'go %p' %f";
- "matita.preserve", "false";
- "matita.quiet", "false";
- "matita.profile", "true";
- ]
-
-let set_registry_values =
- List.iter (fun key, value -> Helm_registry.set ~key ~value)
-
-let fill_registry init_status =
- if not (already_configured [ Registry ] init_status) then begin
- set_registry_values registry_defaults;
- Registry :: init_status
- end else
- init_status
-
-let load_configuration init_status =
- wants [ Registry ] init_status;
- if not (already_configured [ConfigurationFile] init_status) then
- begin
- Helm_registry.load_from !conffile;
- if not (Helm_registry.has "user.name") then begin
- let login = (Unix.getpwuid (Unix.getuid ())).Unix.pw_name in
- Helm_registry.set "user.name" login
- end;
- if Helm_registry.get_bool "matita.system" then
- Helm_registry.set "user.home" BuildTimeConf.runtime_base_dir;
- ConfigurationFile::init_status
- end
- else
- init_status
-
-let initialize_db init_status =
- wants [ ConfigurationFile; CmdLine ] init_status;
- if not (already_configured [ Db ] init_status) then
- begin
- if not (Helm_registry.get_bool "matita.system") then
- MetadataTypes.ownerize_tables (Helm_registry.get "matita.owner");
- LibraryDb.create_owner_environment ();
- Db::init_status
- end
- else
- init_status
-
-let initialize_makelib init_status =
- wants [ConfigurationFile] init_status;
- if not (already_configured [Makelib] init_status) then
- begin
- MatitamakeLib.initialize ();
- Makelib::init_status
- end
- else
- init_status
-
-let initialize_environment init_status =
- wants [ConfigurationFile] init_status;
- if not (already_configured [Getter;Environment] init_status) then
- begin
- Http_getter.init ();
- CicEnvironment.set_trust (* environment trust *)
- (let trust =
- Helm_registry.get_opt_default Helm_registry.get_bool
- ~default:true "matita.environment_trust" in
- fun _ -> trust);
- Getter::Environment::init_status
- end
- else
- init_status
-
-let status = ref []
-
-let usages = Hashtbl.create 11
-let _ =
- List.iter
- (fun (name, s) -> Hashtbl.replace usages name s)
- [ "matitac",
- sprintf "MatitaC v%s
-Usage: matitac [ OPTION ... ] FILE
-Options:"
- BuildTimeConf.version;
- "matita",
- sprintf "Matita v%s
-Usage: matita [ OPTION ... ] [ FILE ... ]
-Options:"
- BuildTimeConf.version;
- "cicbrowser",
- sprintf
- "CIC Browser v%s
-Usage: cicbrowser [ URL | WHELP QUERY ]
-Options:"
- BuildTimeConf.version;
- "matitadep",
- sprintf "MatitaDep v%s
-Usage: matitadep [ OPTION ... ] FILE ...
-Options:"
- BuildTimeConf.version;
- "matitaclean",
- sprintf "MatitaClean v%s
-Usage: matitaclean all
- matitaclean [ (FILE | URI) ... ]
-Options:"
- BuildTimeConf.version;
- ]
-let default_usage =
- sprintf "Matita v%s\nUsage: matita [ ARG ]\nOptions:" BuildTimeConf.version
-
-let usage () =
- let basename = Filename.basename Sys.argv.(0) in
- let usage_key =
- try Filename.chop_extension basename with Invalid_argument _ -> basename
- in
- try Hashtbl.find usages usage_key with Not_found -> default_usage
-
-let parse_cmdline init_status =
- if not (already_configured [CmdLine] init_status) then begin
- let includes = ref [ BuildTimeConf.stdlib_dir ] in
- let args = ref [] in
- let add_l l = fun s -> l := s :: !l in
- let arg_spec =
- let std_arg_spec = [
- "-I", Arg.String (add_l includes),
- ("<path> Adds path to the list of searched paths for the "
- ^ "include command");
- "-conffile", Arg.Set_string conffile,
- (Printf.sprintf "<filename> Read configuration from filename (default: %s)"
- BuildTimeConf.matita_conf);
- "-q", Arg.Unit (fun () -> Helm_registry.set_bool "matita.quiet" true),
- "Turn off verbose compilation";
- "-preserve",
- Arg.Unit (fun () -> Helm_registry.set_bool "matita.preserve" true),
- "Turns off automatic baseuri cleaning";
- "-nodb", Arg.Unit (fun () -> Helm_registry.set_bool "db.nodb" true),
- ("Avoid using external database connection "
- ^ "(WARNING: disable many features)");
- "-system", Arg.Unit (fun () ->
- Helm_registry.set_bool "matita.system" true),
- ("Act on the system library instead of the user one"
- ^ "(WARNING: not for the casual user)");
- "-noprofile",
- Arg.Unit (fun () -> Helm_registry.set_bool "matita.profile" false),
- "Turns off profiling printings";
- ] in
- let debug_arg_spec =
- if BuildTimeConf.debug then
- [ "-debug",
- Arg.Unit (fun () -> Helm_registry.set_bool "matita.debug" true),
- ("Do not catch top-level exception "
- ^ "(useful for backtrace inspection)");
- ]
- else []
- in
- std_arg_spec @ debug_arg_spec
- in
- let set_list ~key l =
- Helm_registry.set_list Helm_registry.of_string ~key ~value:(List.rev !l)
- in
- Arg.parse arg_spec (add_l args) (usage ());
- set_list ~key:"matita.includes" includes;
- set_list ~key:"matita.args" args;
- HExtlib.set_profiling_printings
- (fun () -> Helm_registry.get_bool "matita.profile");
- CmdLine :: init_status
- end else
- init_status
-
-let die_usage () =
- print_endline (usage ());
- exit 1
-
-let initialize_all () =
- status :=
- List.fold_left (fun s f -> f s) !status
- [ fill_registry;
- parse_cmdline; load_configuration; initialize_makelib;
- initialize_db; initialize_environment ]
-(* initialize_notation
- (initialize_environment
- (initialize_db
- (initialize_makelib
- (load_configuration
- (parse_cmdline !status))))) *)
-
-let load_configuration_file () =
- status := load_configuration !status
-
-let parse_cmdline () =
- status := parse_cmdline !status
-
-let fill_registry () =
- status := fill_registry !status
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
- (** {2 global initialization} *)
-val initialize_all: unit -> unit
-
- (** {2 per-components initialization} *)
-val fill_registry: unit -> unit (** fill registry with default values *)
-val parse_cmdline: unit -> unit (** parse cmdline setting registry keys *)
-val load_configuration_file: unit -> unit
-
- (** {2 Utilities} *)
-
- (** die nicely: exit with return code 1 printing usage error message *)
-val die_usage: unit -> 'a
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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));
- if BuildTimeConf.debug then begin
- let name = "sequent_viewer.xml" in
- HLog.debug ("load_sequent: dumping MathML to ./" ^ name);
- ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ())
- end;
- self#load_root ~root:mathml#get_documentElement
-
- method load_object obj =
- let use_diff = false in (* ZACK TODO use XmlDiff when re-rendering? *)
- let (mathml,
- (annobj, (ids_to_terms, ids_to_father_ids, _, ids_to_hypotheses, _, ids_to_inner_types)))
- =
- ApplyTransformation.mml_of_cic_object obj
- in
- self#set_cic_info
- (Some (None, ids_to_terms, ids_to_hypotheses, ids_to_father_ids, ids_to_inner_types, Some annobj));
- (match current_mathml with
- | Some current_mathml when use_diff ->
- self#freeze;
- XmlDiff.update_dom ~from:current_mathml mathml;
- self#thaw
- | _ ->
- if BuildTimeConf.debug then begin
- let name = "cic_browser.xml" in
- HLog.debug ("cic_browser: dumping MathML to ./" ^ name);
- ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ())
- end;
- self#load_root ~root:mathml#get_documentElement;
- current_mathml <- Some mathml);
-end
-
-let tab_label meta_markup =
- let rec aux =
- function
- | `Current m -> sprintf "<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)
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-open GrafiteTypes
-
-module TA = GrafiteAst
-
-let debug = false
-let debug_print = if debug then prerr_endline else ignore
-
- (** raised when one of the script margins (top or bottom) is reached *)
-exception Margin
-exception NoUnfinishedProof
-exception ActionCancelled
-
-let safe_substring s i j =
- try String.sub s i j with Invalid_argument _ -> assert false
-
-let heading_nl_RE = Pcre.regexp "^\\s*\n\\s*"
-let heading_nl_RE' = Pcre.regexp "^(\\s*\n\\s*)((.|\n)*)"
-let only_dust_RE = Pcre.regexp "^(\\s|\n|%%[^\n]*\n)*$"
-let multiline_RE = Pcre.regexp "^\n[^\n]+$"
-let newline_RE = Pcre.regexp "\n"
-
-let comment str =
- if Pcre.pmatch ~rex:multiline_RE str then
- "\n(** " ^ (Pcre.replace ~rex:newline_RE str) ^ " *)"
- else
- "\n(**\n" ^ str ^ "\n*)"
-
-let first_line s =
- let s = Pcre.replace ~rex:heading_nl_RE s in
- try
- let nl_pos = String.index s '\n' in
- String.sub s 0 nl_pos
- with Not_found -> s
-
- (** creates a statement AST for the Goal tactic, e.g. "goal 7" *)
-let goal_ast n =
- let module A = GrafiteAst in
- let loc = HExtlib.dummy_floc in
- A.Executable (loc, A.Tactical (loc,
- A.Tactic (loc, A.Goal (loc, n)),
- Some (A.Dot loc)))
-
-type guistuff = {
- mathviewer:MatitaTypes.mathViewer;
- urichooser: UriManager.uri list -> UriManager.uri list;
- ask_confirmation: title:string -> message:string -> [`YES | `NO | `CANCEL];
- develcreator: containing:string option -> unit;
- mutable filenamedata: string option * MatitamakeLib.development option
-}
-
-let eval_with_engine guistuff lexicon_status grafite_status user_goal
- parsed_text st
-=
- let module TAPp = GrafiteAstPp in
- let parsed_text_length = String.length parsed_text in
- let initial_space,parsed_text =
- try
- let pieces = Pcre.extract ~rex:heading_nl_RE' parsed_text in
- pieces.(1), pieces.(2)
- with
- Not_found -> "", parsed_text in
- let inital_space,new_grafite_status,new_lexicon_status,new_status_and_text_list' =
- (* the code commented out adds the "select" command if needed *)
- initial_space,grafite_status,lexicon_status,[] in
-(* let loc, ex =
- match st with TA.Executable (loc,ex) -> loc, ex | _ -> assert false in
- match grafite_status.proof_status with
- | Incomplete_proof { stack = stack }
- when not (List.mem user_goal (Continuationals.head_goals stack)) ->
- let grafite_status =
- MatitaEngine.eval_ast
- ~do_heavy_checks:true grafite_status (goal_ast user_goal)
- in
- let initial_space = if initial_space = "" then "\n" else initial_space
- in
- "\n", grafite_status,
- [ grafite_status,
- initial_space ^ TAPp.pp_tactical (TA.Select (loc, [user_goal])) ]
- | _ -> initial_space,grafite_status,[] in *)
- let enriched_history_fragment =
- MatitaEngine.eval_ast ~do_heavy_checks:true
- new_lexicon_status new_grafite_status st
- in
- let _,new_text_list_rev =
- let module DTE = DisambiguateTypes.Environment in
- let module UM = UriManager in
- List.fold_right (
- fun (_,alias) (initial_space,acc) ->
- match alias with
- None -> initial_space,initial_space::acc
- | Some (k,((v,_) as value)) ->
- let new_text =
- let initial_space =
- if initial_space = "" then "\n" else initial_space
- in
- initial_space ^
- DisambiguatePp.pp_environment
- (DisambiguateTypes.Environment.add k value
- DisambiguateTypes.Environment.empty)
- in
- "\n",new_text::acc
- ) enriched_history_fragment (initial_space,[]) in
- let new_text_list_rev =
- match enriched_history_fragment,new_text_list_rev with
- (_,None)::_, initial_space::tl -> (initial_space ^ parsed_text)::tl
- | _,_ -> assert false
- in
- let res =
- try
- List.combine (fst (List.split enriched_history_fragment)) new_text_list_rev
- with
- Invalid_argument _ -> assert false
- in
- res,parsed_text_length
-
-let wrap_with_developments guistuff f arg =
- try
- f arg
- with
- | DependenciesParser.UnableToInclude what
- | LexiconEngine.IncludedFileNotCompiled what
- | GrafiteEngine.IncludedFileNotCompiled what as exc ->
- let compile_needed_and_go_on d =
- let target = Pcre.replace ~pat:"lexicon$" ~templ:"moo" what in
- let refresh_cb () =
- while Glib.Main.pending () do ignore(Glib.Main.iteration false); done
- in
- if not(MatitamakeLib.build_development_in_bg ~target refresh_cb d) then
- raise exc
- else
- f arg
- in
- let do_nothing () = raise ActionCancelled in
- let handle_with_devel d =
- let name = MatitamakeLib.name_for_development d in
- let title = "Unable to include " ^ what in
- let message =
- what ^ " is handled by development <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 eval_with_engine
- guistuff lexicon_status grafite_status user_goal parsed_text st
-=
- wrap_with_developments guistuff
- (eval_with_engine
- guistuff lexicon_status grafite_status user_goal parsed_text) st
-;;
-
-let pp_eager_statement_ast =
- GrafiteAstPp.pp_statement ~term_pp:CicNotationPp.pp_term
- ~lazy_term_pp:(fun _ -> assert false) ~obj_pp:(fun _ -> assert false)
-
-let rec eval_macro include_paths (buffer : GText.buffer) guistuff lexicon_status grafite_status user_goal unparsed_text parsed_text script mac =
- let module TAPp = GrafiteAstPp in
- let module MQ = MetadataQuery in
- let module MDB = LibraryDb in
- let module CTC = CicTypeChecker in
- let module CU = CicUniv in
- (* no idea why ocaml wants this *)
- let parsed_text_length = String.length parsed_text in
- let dbd = LibraryDb.instance () in
- (* XXX use a real CIC -> string pretty printer *)
- let pp_macro = TAPp.pp_macro ~term_pp:CicPp.ppterm in
- match mac with
- (* WHELP's stuff *)
- | TA.WMatch (loc, term) ->
- let l = Whelp.match_term ~dbd term in
- let query_url =
- MatitaMisc.strip_suffix ~suffix:"."
- (HExtlib.trim_blanks unparsed_text)
- in
- let entry = `Whelp (query_url, l) in
- guistuff.mathviewer#show_uri_list ~reuse:true ~entry l;
- [], parsed_text_length
- | TA.WInstance (loc, term) ->
- let l = Whelp.instance ~dbd term in
- let entry = `Whelp (pp_macro (TA.WInstance (loc, term)), l) in
- guistuff.mathviewer#show_uri_list ~reuse:true ~entry l;
- [], parsed_text_length
- | TA.WLocate (loc, s) ->
- let l = Whelp.locate ~dbd s in
- let entry = `Whelp (pp_macro (TA.WLocate (loc, s)), l) in
- guistuff.mathviewer#show_uri_list ~reuse:true ~entry l;
- [], parsed_text_length
- | TA.WElim (loc, term) ->
- let uri =
- match term with
- | Cic.MutInd (uri,n,_) -> UriManager.uri_of_uriref uri n None
- | _ -> failwith "Not a MutInd"
- in
- let l = Whelp.elim ~dbd uri in
- let entry = `Whelp (pp_macro (TA.WElim (loc, term)), l) in
- guistuff.mathviewer#show_uri_list ~reuse:true ~entry l;
- [], parsed_text_length
- | TA.WHint (loc, term) ->
- let s = ((None,[0,[],term], Cic.Meta (0,[]) ,term),0) in
- let l = List.map fst (MQ.experimental_hint ~dbd s) in
- let entry = `Whelp (pp_macro (TA.WHint (loc, term)), l) in
- guistuff.mathviewer#show_uri_list ~reuse:true ~entry l;
- [], parsed_text_length
- (* REAL macro *)
- | TA.Hint loc ->
- let user_goal' =
- match user_goal with
- Some n -> n
- | None -> raise NoUnfinishedProof
- in
- let proof = GrafiteTypes.get_current_proof grafite_status in
- let proof_status = proof,user_goal' in
- let l = List.map fst (MQ.experimental_hint ~dbd proof_status) in
- let selected = guistuff.urichooser l in
- (match selected with
- | [] -> [], parsed_text_length
- | [uri] ->
- let suri = UriManager.string_of_uri uri in
- let ast loc =
- TA.Executable (loc, (TA.Tactical (loc,
- TA.Tactic (loc,
- TA.Apply (loc, CicNotationPt.Uri (suri, None))),
- Some (TA.Dot loc)))) in
- let text =
- comment parsed_text ^ "\n" ^
- pp_eager_statement_ast (ast HExtlib.dummy_floc) in
- let text_len = String.length text in
- let loc = HExtlib.floc_of_loc (0,text_len) in
- let statement = `Ast (GrafiteParser.LSome (ast loc),text) in
- let res,_parsed_text_len =
- eval_statement include_paths buffer guistuff lexicon_status
- grafite_status user_goal script statement
- in
- (* we need to replace all the parsed_text *)
- res,String.length parsed_text
- | _ ->
- HLog.error
- "The result of the urichooser should be only 1 uri, not:\n";
- List.iter (
- fun u -> HLog.error (UriManager.string_of_uri u ^ "\n")
- ) selected;
- assert false)
- | TA.Check (_,term) ->
- let metasenv = GrafiteTypes.get_proof_metasenv grafite_status in
- let context =
- match user_goal with
- None -> []
- | Some n -> GrafiteTypes.get_proof_context grafite_status n in
- let ty,_ = CTC.type_of_aux' metasenv context term CicUniv.empty_ugraph in
- let t_and_ty = Cic.Cast (term,ty) in
- guistuff.mathviewer#show_entry (`Cic (t_and_ty,metasenv));
- [], parsed_text_length
- (* TODO *)
- | TA.Quit _ -> failwith "not implemented"
- | TA.Print (_,kind) -> failwith "not implemented"
- | TA.Search_pat (_, search_kind, str) -> failwith "not implemented"
- | TA.Search_term (_, search_kind, term) -> failwith "not implemented"
-
-and eval_executable include_paths (buffer : GText.buffer) guistuff lexicon_status grafite_status user_goal unparsed_text parsed_text script loc ex
-=
- let module TAPp = GrafiteAstPp in
- let module MD = GrafiteDisambiguator in
- let module ML = MatitaMisc in
- try
- begin
- match ex with
- | TA.Command (_,TA.Set (_,"baseuri",u)) ->
- if not (GrafiteMisc.is_empty u) then
- (match
- guistuff.ask_confirmation
- ~title:"Baseuri redefinition"
- ~message:(
- "Baseuri " ^ u ^ " already exists.\n" ^
- "Do you want to redefine the corresponding "^
- "part of the library?")
- with
- | `YES ->
- let basedir = Helm_registry.get "matita.basedir" in
- LibraryClean.clean_baseuris ~basedir [u]
- | `NO -> ()
- | `CANCEL -> raise MatitaTypes.Cancel)
- | _ -> ()
- end;
- eval_with_engine
- guistuff lexicon_status grafite_status user_goal parsed_text
- (TA.Executable (loc, ex))
- with
- MatitaTypes.Cancel -> [], 0
- | GrafiteEngine.Macro (_loc,lazy_macro) ->
- let context =
- match user_goal with
- None -> []
- | Some n -> GrafiteTypes.get_proof_context grafite_status n in
- let grafite_status,macro = lazy_macro context in
- eval_macro include_paths buffer guistuff lexicon_status grafite_status
- user_goal unparsed_text parsed_text script macro
-
-and eval_statement include_paths (buffer : GText.buffer) guistuff lexicon_status
- grafite_status user_goal script statement
-=
- let (lexicon_status,st), unparsed_text =
- match statement with
- | `Raw text ->
- if Pcre.pmatch ~rex:only_dust_RE text then raise Margin;
- let ast =
- wrap_with_developments guistuff
- (GrafiteParser.parse_statement
- (Ulexing.from_utf8_string text) ~include_paths) lexicon_status
- in
- ast, text
- | `Ast (st, text) -> (lexicon_status, st), text
- in
- let text_of_loc loc =
- let parsed_text_length = snd (HExtlib.loc_of_floc loc) in
- let parsed_text = safe_substring unparsed_text 0 parsed_text_length in
- parsed_text, parsed_text_length
- in
- match st with
- | GrafiteParser.LNone loc ->
- let parsed_text, parsed_text_length = text_of_loc loc in
- [(grafite_status,lexicon_status),parsed_text],
- parsed_text_length
- | GrafiteParser.LSome (GrafiteAst.Comment (loc, _)) ->
- let parsed_text, parsed_text_length = text_of_loc loc in
- let remain_len = String.length unparsed_text - parsed_text_length in
- let s = String.sub unparsed_text parsed_text_length remain_len in
- let s,len =
- try
- eval_statement include_paths buffer guistuff lexicon_status
- grafite_status user_goal script (`Raw s)
- with
- HExtlib.Localized (floc, exn) ->
- HExtlib.raise_localized_exception ~offset:parsed_text_length floc exn
- | GrafiteDisambiguator.DisambiguationError (offset,errorll) ->
- raise
- (GrafiteDisambiguator.DisambiguationError
- (offset+parsed_text_length, errorll))
- in
- (match s with
- | (statuses,text)::tl ->
- (statuses,parsed_text ^ text)::tl,parsed_text_length + len
- | [] -> [], 0)
- | GrafiteParser.LSome (GrafiteAst.Executable (loc, ex)) ->
- let parsed_text, parsed_text_length = text_of_loc loc in
- eval_executable include_paths buffer guistuff lexicon_status
- grafite_status user_goal unparsed_text parsed_text script loc ex
-
-let fresh_script_id =
- let i = ref 0 in
- fun () -> incr i; !i
-
-class script ~(source_view: GSourceView.source_view)
- ~(mathviewer: MatitaTypes.mathViewer)
- ~set_star
- ~ask_confirmation
- ~urichooser
- ~develcreator
- () =
-let buffer = source_view#buffer in
-let source_buffer = source_view#source_buffer in
-let initial_statuses =
- (* these include_paths are used only to load the initial notation *)
- let include_paths =
- Helm_registry.get_list Helm_registry.string "matita.includes" in
- let lexicon_status =
- CicNotation2.load_notation ~include_paths
- BuildTimeConf.core_notation_script in
- let grafite_status = GrafiteSync.init () in
- grafite_status,lexicon_status
-in
-object (self)
- val mutable include_paths =
- Helm_registry.get_list Helm_registry.string "matita.includes"
-
- val scriptId = fresh_script_id ()
-
- val guistuff = {
- mathviewer = mathviewer;
- urichooser = urichooser;
- ask_confirmation = ask_confirmation;
- develcreator = develcreator;
- filenamedata = (None, None)}
-
- method private getFilename =
- match guistuff.filenamedata with Some f,_ -> f | _ -> assert false
-
- method filename = self#getFilename
-
- method private ppFilename =
- match guistuff.filenamedata with
- | Some f,_ -> f
- | None,_ -> sprintf ".unnamed%d.ma" scriptId
-
- initializer
- ignore (GMain.Timeout.add ~ms:300000
- ~callback:(fun _ -> self#_saveToBackupFile ();true));
- ignore (buffer#connect#modified_changed
- (fun _ -> set_star (Filename.basename self#ppFilename) buffer#modified))
-
- val mutable statements = [] (** executed statements *)
-
- val mutable history = [ initial_statuses ]
- (** list of states before having executed statements. Head element of this
- * list is the current state, last element is the state at the beginning of
- * the script.
- * Invariant: this list length is 1 + length of statements *)
-
- (** goal as seen by the user (i.e. metano corresponding to current tab) *)
- val mutable userGoal = None
-
- (** text mark and tag representing locked part of a script *)
- val locked_mark =
- buffer#create_mark ~name:"locked" ~left_gravity:true buffer#start_iter
- val locked_tag = buffer#create_tag [`BACKGROUND "lightblue"; `EDITABLE false]
- val error_tag = buffer#create_tag [`UNDERLINE `SINGLE; `FOREGROUND "red"]
-
- method locked_mark = locked_mark
- method locked_tag = locked_tag
- method error_tag = error_tag
-
- (* history can't be empty, the invariant above grant that it contains at
- * least the init grafite_status *)
- method grafite_status = match history with (s,_)::_ -> s | _ -> assert false
- method lexicon_status = match history with (_,ss)::_ -> ss | _ -> assert false
-
- method private _advance ?statement () =
- let s = match statement with Some s -> s | None -> self#getFuture in
- HLog.debug ("evaluating: " ^ first_line s ^ " ...");
- let (entries, parsed_len) =
- try
- eval_statement include_paths buffer guistuff self#lexicon_status
- self#grafite_status userGoal self (`Raw s)
- with End_of_file -> raise Margin
- in
- let new_statuses, new_statements =
- let statuses, texts = List.split entries in
- statuses, texts
- in
- history <- new_statuses @ history;
- statements <- new_statements @ statements;
- let start = buffer#get_iter_at_mark (`MARK locked_mark) in
- let new_text = String.concat "" (List.rev new_statements) in
- if statement <> None then
- buffer#insert ~iter:start new_text
- else begin
- if new_text <> String.sub s 0 parsed_len then begin
- buffer#delete ~start ~stop:(start#copy#forward_chars parsed_len);
- buffer#insert ~iter:start new_text;
- end;
- end;
- self#moveMark (String.length new_text);
- (* here we need to set the Goal in case we are going to cursor (or to
- bottom) and we will face a macro *)
- match self#grafite_status.proof_status with
- Incomplete_proof p ->
- userGoal <-
- (try Some (Continuationals.Stack.find_goal p.stack)
- with Failure _ -> None)
- | _ -> userGoal <- None
-
- method private _retract offset lexicon_status grafite_status new_statements
- new_history
- =
- let cur_grafite_status,cur_lexicon_status =
- match history with s::_ -> s | [] -> assert false
- in
- LexiconSync.time_travel ~present:cur_lexicon_status ~past:lexicon_status;
- GrafiteSync.time_travel ~present:cur_grafite_status ~past:grafite_status;
- statements <- new_statements;
- history <- new_history;
- self#moveMark (- offset)
-
- method advance ?statement () =
- try
- self#_advance ?statement ();
- self#notify
- with
- | Margin -> self#notify
- | exc -> self#notify; raise exc
-
- method retract () =
- try
- let cmp,new_statements,new_history,(grafite_status,lexicon_status) =
- match statements,history with
- stat::statements, _::(status::_ as history) ->
- String.length stat, statements, history, status
- | [],[_] -> raise Margin
- | _,_ -> assert false
- in
- self#_retract cmp lexicon_status grafite_status new_statements
- new_history;
- self#notify
- with
- | Margin -> self#notify
- | exc -> self#notify; raise exc
-
- method private getFuture =
- buffer#get_text ~start:(buffer#get_iter_at_mark (`MARK locked_mark))
- ~stop:buffer#end_iter ()
-
-
- (** @param rel_offset relative offset from current position of locked_mark *)
- method private moveMark rel_offset =
- let mark = `MARK locked_mark in
- let old_insert = buffer#get_iter_at_mark `INSERT in
- buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter;
- let current_mark_pos = buffer#get_iter_at_mark mark in
- let new_mark_pos =
- match rel_offset with
- | 0 -> current_mark_pos
- | n when n > 0 -> current_mark_pos#forward_chars n
- | n (* when n < 0 *) -> current_mark_pos#backward_chars (abs n)
- in
- buffer#move_mark mark ~where:new_mark_pos;
- buffer#apply_tag locked_tag ~start:buffer#start_iter ~stop:new_mark_pos;
- buffer#move_mark `INSERT old_insert;
- let mark_position = buffer#get_iter_at_mark mark in
- if source_view#move_mark_onscreen mark then
- begin
- buffer#move_mark mark mark_position;
- source_view#scroll_to_mark ~use_align:true ~xalign:1.0 ~yalign:0.1 mark;
- end;
- while Glib.Main.pending () do ignore(Glib.Main.iteration false); done
-
- method clean_dirty_lock =
- let lock_mark_iter = buffer#get_iter_at_mark (`MARK locked_mark) in
- buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter;
- buffer#apply_tag locked_tag ~start:buffer#start_iter ~stop:lock_mark_iter
-
- val mutable observers = []
-
- method addObserver (o: LexiconEngine.status -> GrafiteTypes.status -> unit) =
- observers <- o :: observers
-
- method private notify =
- let lexicon_status = self#lexicon_status in
- let grafite_status = self#grafite_status in
- List.iter (fun o -> o lexicon_status grafite_status) observers
-
- method loadFromFile f =
- buffer#set_text (HExtlib.input_file f);
- self#reset_buffer;
- buffer#set_modified false
-
- method assignFileName file =
- let abspath = MatitaMisc.absolute_path file in
- let dirname = Filename.dirname abspath in
- let devel = MatitamakeLib.development_for_dir dirname in
- guistuff.filenamedata <- Some abspath, devel;
- let include_ =
- match MatitamakeLib.development_for_dir dirname with
- None -> []
- | Some devel -> [MatitamakeLib.root_for_development devel] in
- let include_ =
- include_ @ (Helm_registry.get_list Helm_registry.string "matita.includes")
- in
- include_paths <- include_
-
- method saveToFile () =
- let oc = open_out self#getFilename in
- output_string oc (buffer#get_text ~start:buffer#start_iter
- ~stop:buffer#end_iter ());
- close_out oc;
- buffer#set_modified false
-
- method private _saveToBackupFile () =
- if buffer#modified then
- begin
- let f = self#ppFilename ^ "~" in
- let oc = open_out f in
- output_string oc (buffer#get_text ~start:buffer#start_iter
- ~stop:buffer#end_iter ());
- close_out oc;
- HLog.debug ("backup " ^ f ^ " saved")
- end
-
- method private goto_top =
- let grafite_status,lexicon_status =
- let rec last x = function
- | [] -> x
- | hd::tl -> last hd tl
- in
- last (self#grafite_status,self#lexicon_status) history
- in
- (* FIXME: this is not correct since there is no undo for
- * library_objects.set_default... *)
- GrafiteSync.time_travel ~present:self#grafite_status ~past:grafite_status;
- LexiconSync.time_travel ~present:self#lexicon_status ~past:lexicon_status
-
- method private reset_buffer =
- statements <- [];
- history <- [ initial_statuses ];
- userGoal <- None;
- self#notify;
- buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter;
- buffer#move_mark (`MARK locked_mark) ~where:buffer#start_iter
-
- method reset () =
- self#reset_buffer;
- source_buffer#begin_not_undoable_action ();
- buffer#delete ~start:buffer#start_iter ~stop:buffer#end_iter;
- source_buffer#end_not_undoable_action ();
- buffer#set_modified false;
-
- method template () =
- let template = HExtlib.input_file BuildTimeConf.script_template in
- buffer#insert ~iter:(buffer#get_iter `START) template;
- let development = MatitamakeLib.development_for_dir (Unix.getcwd ()) in
- guistuff.filenamedata <- (None,development);
- let include_ =
- match development with
- None -> []
- | Some devel -> [MatitamakeLib.root_for_development devel ]
- in
- let include_ =
- include_ @ (Helm_registry.get_list Helm_registry.string "matita.includes")
- in
- include_paths <- include_ ;
- buffer#set_modified false;
- set_star (Filename.basename self#ppFilename) false
-
- method goto (pos: [`Top | `Bottom | `Cursor]) () =
- let old_locked_mark =
- `MARK
- (buffer#create_mark ~name:"old_locked_mark"
- ~left_gravity:true (buffer#get_iter_at_mark (`MARK locked_mark))) in
- let getpos _ = buffer#get_iter_at_mark (`MARK locked_mark) in
- let getoldpos _ = buffer#get_iter_at_mark old_locked_mark in
- let dispose_old_locked_mark () = buffer#delete_mark old_locked_mark in
- match pos with
- | `Top ->
- dispose_old_locked_mark ();
- self#goto_top;
- self#reset_buffer;
- self#notify
- | `Bottom ->
- (try
- let rec dowhile () =
- self#_advance ();
- let newpos = getpos () in
- if (getoldpos ())#compare newpos < 0 then
- begin
- buffer#move_mark old_locked_mark newpos;
- dowhile ()
- end
- in
- dowhile ();
- dispose_old_locked_mark ();
- self#notify
- with
- | Margin -> dispose_old_locked_mark (); self#notify
- | exc -> dispose_old_locked_mark (); self#notify; raise exc)
- | `Cursor ->
- let locked_iter () = buffer#get_iter_at_mark (`NAME "locked") in
- let cursor_iter () = buffer#get_iter_at_mark `INSERT in
- let remember =
- `MARK
- (buffer#create_mark ~name:"initial_insert"
- ~left_gravity:true (cursor_iter ())) in
- let dispose_remember () = buffer#delete_mark remember in
- let remember_iter () =
- buffer#get_iter_at_mark (`NAME "initial_insert") in
- let cmp () = (locked_iter ())#offset - (remember_iter ())#offset in
- let icmp = cmp () in
- let forward_until_cursor () = (* go forward until locked > cursor *)
- let rec aux () =
- self#_advance ();
- if cmp () < 0 && (getoldpos ())#compare (getpos ()) < 0
- then
- begin
- buffer#move_mark old_locked_mark (getpos ());
- aux ()
- end
- in
- aux ()
- in
- let rec back_until_cursor len = (* go backward until locked < cursor *)
- function
- statements, ((grafite_status,lexicon_status)::_ as history)
- when len <= 0 ->
- self#_retract (icmp - len) lexicon_status grafite_status statements
- history
- | statement::tl1, _::tl2 ->
- back_until_cursor (len - String.length statement) (tl1,tl2)
- | _,_ -> assert false
- in
- (try
- begin
- if icmp < 0 then (* locked < cursor *)
- (forward_until_cursor (); self#notify)
- else if icmp > 0 then (* locked > cursor *)
- (back_until_cursor icmp (statements,history); self#notify)
- else (* cursor = locked *)
- ()
- end ;
- dispose_remember ();
- dispose_old_locked_mark ();
- with
- | Margin -> dispose_remember (); dispose_old_locked_mark (); self#notify
- | exc -> dispose_remember (); dispose_old_locked_mark ();
- self#notify; raise exc)
-
- method onGoingProof () =
- match self#grafite_status.proof_status with
- | No_proof | Proof _ -> false
- | Incomplete_proof _ -> true
- | Intermediate _ -> assert false
-
-(* method proofStatus = MatitaTypes.get_proof_status self#status *)
- method proofMetasenv = GrafiteTypes.get_proof_metasenv self#grafite_status
-
- method proofContext =
- match userGoal with
- None -> []
- | Some n -> GrafiteTypes.get_proof_context self#grafite_status n
-
- method proofConclusion =
- match userGoal with
- None -> assert false
- | Some n ->
- GrafiteTypes.get_proof_conclusion self#grafite_status n
-
- method stack = GrafiteTypes.get_stack self#grafite_status
- method setGoal n = userGoal <- n
- method goal = userGoal
-
- method eos =
- let s = self#getFuture in
- let rec is_there_only_comments lexicon_status s =
- if Pcre.pmatch ~rex:only_dust_RE s then raise Margin;
- let lexicon_status,st =
- GrafiteParser.parse_statement (Ulexing.from_utf8_string s)
- ~include_paths lexicon_status
- in
- match st with
- | GrafiteParser.LSome (GrafiteAst.Comment (loc,_)) ->
- let parsed_text_length = snd (HExtlib.loc_of_floc loc) in
- let remain_len = String.length s - parsed_text_length in
- let next = String.sub s parsed_text_length remain_len in
- is_there_only_comments lexicon_status next
- | GrafiteParser.LNone _
- | GrafiteParser.LSome (GrafiteAst.Executable _) -> false
- in
- try
- is_there_only_comments self#lexicon_status s
- with
- | CicNotationParser.Parse_error _ -> false
- | Margin | End_of_file -> true
-
- (* debug *)
- method dump () =
- HLog.debug "script status:";
- HLog.debug ("history size: " ^ string_of_int (List.length history));
- HLog.debug (sprintf "%d statements:" (List.length statements));
- List.iter HLog.debug statements;
- HLog.debug ("Current file name: " ^
- (match guistuff.filenamedata with
- |None,_ -> "[ no name ]"
- | Some f,_ -> f));
-
-end
-
-let _script = ref None
-
-let script ~source_view ~mathviewer ~urichooser ~develcreator ~ask_confirmation ~set_star ()
-=
- let s = new script
- ~source_view ~mathviewer ~ask_confirmation ~urichooser ~develcreator ~set_star ()
- in
- _script := Some s;
- s
-
-let current () = match !_script with None -> assert false | Some s -> s
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-exception NoUnfinishedProof
-exception ActionCancelled
-
-class type script =
-object
-
- method locked_mark : Gtk.text_mark
- method locked_tag : GText.tag
- method error_tag : GText.tag
-
- (** @return current status *)
- method lexicon_status: LexiconEngine.status
- method grafite_status: GrafiteTypes.status
-
- (** {2 Observers} *)
-
- method addObserver :
- (LexiconEngine.status -> GrafiteTypes.status -> unit) -> unit
-
- (** {2 History} *)
-
- method advance : ?statement:string -> unit -> unit
- method retract : unit -> unit
- method goto: [`Top | `Bottom | `Cursor] -> unit -> unit
- method reset: unit -> unit
- method template: unit -> unit
-
- (** {2 Load/save} *)
-
- method assignFileName : string -> unit (* to the current active file *)
- method loadFromFile : string -> unit
- method saveToFile : unit -> unit
- method filename : string
-
- (** {2 Current proof} (if any) *)
-
- (** @return true if there is an ongoing proof, false otherise *)
- method onGoingProof: unit -> bool
-
-(* method proofStatus: ProofEngineTypes.status |+* @raise Statement_error +| *)
- method proofMetasenv: Cic.metasenv (** @raise Statement_error *)
- method proofContext: Cic.context (** @raise Statement_error *)
- method proofConclusion: Cic.term (** @raise Statement_error *)
- method stack: Continuationals.Stack.t (** @raise Statement_error *)
-
- method setGoal: int option -> unit
- method goal: int option
-
- (** end of script, true if the whole script has been executed *)
- method eos: bool
-
- (** misc *)
- method clean_dirty_lock: unit
-
- (* debug *)
- method dump : unit -> unit
-
-end
-
- (** @param set_star callback used to set the modified symbol (usually a star
- * "*") on the side of a script name *)
-val script:
- source_view:GSourceView.source_view ->
- mathviewer: MatitaTypes.mathViewer->
- urichooser: (UriManager.uri list -> UriManager.uri list) ->
- develcreator: (containing:string option -> unit) ->
- ask_confirmation:
- (title:string -> message:string -> [`YES | `NO | `CANCEL]) ->
- set_star: (string -> bool -> unit) ->
- unit ->
- script
-
-(* each time script above is called an internal ref is set, instance will return
- * the value of this ref *)
-(* TODO Zack: orrible solution until we found a better one for having a single
- * access point for the script *)
-val current: unit -> script
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 ()
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-
-open GrafiteTypes
-
-exception AttemptToInsertAnAlias
-
-let pp_ast_statement =
- GrafiteAstPp.pp_statement ~term_pp:CicNotationPp.pp_term
- ~lazy_term_pp:CicNotationPp.pp_term ~obj_pp:CicNotationPp.pp_obj
-
-(** {2 Initialization} *)
-
-let grafite_status = (ref None : GrafiteTypes.status option ref)
-let lexicon_status = (ref None : LexiconEngine.status option ref)
-
-let run_script is eval_function =
- let lexicon_status',grafite_status' =
- match !lexicon_status,!grafite_status with
- | Some ss, Some s -> ss,s
- | _,_ -> assert false
- in
- let slash_n_RE = Pcre.regexp "\\n" in
- let cb =
- if Helm_registry.get_bool "matita.quiet" then
- (fun _ _ -> ())
- else
- (fun grafite_status stm ->
- (* dump_status grafite_status; *)
- let stm = pp_ast_statement stm in
- let stm = Pcre.replace ~rex:slash_n_RE stm in
- let stm =
- if String.length stm > 50 then
- String.sub stm 0 50 ^ " ..."
- else
- stm
- in
- HLog.debug ("Executing: ``" ^ stm ^ "''"))
- in
- try
- let grafite_status'', lexicon_status'' =
- match eval_function lexicon_status' grafite_status' is cb with
- [] -> assert false
- | (s,None)::_ -> s
- | (s,Some _)::_ -> raise AttemptToInsertAnAlias
- in
- lexicon_status := Some lexicon_status'';
- grafite_status := Some grafite_status''
- with
- | GrafiteEngine.Drop
- | End_of_file
- | CicNotationParser.Parse_error _ as exn -> raise exn
- | exn ->
- HLog.error (snd (MatitaExcPp.to_string exn));
- raise exn
-
-let fname () =
- match Helm_registry.get_list Helm_registry.string "matita.args" with
- | [x] -> x
- | _ -> MatitaInit.die_usage ()
-
-let pp_ocaml_mode () =
- HLog.message "";
- HLog.message " ** Entering Ocaml mode ** ";
- HLog.message "";
- HLog.message "Type 'go ();;' to enter an interactive matitac";
- HLog.message ""
-
-let clean_exit n =
- let opt_exit =
- function
- None -> ()
- | Some n -> exit n
- in
- match !grafite_status with
- None -> opt_exit n
- | Some grafite_status ->
- try
- let baseuri = GrafiteTypes.get_string_option grafite_status "baseuri" in
- let basedir = Helm_registry.get "matita.basedir" in
- LibraryClean.clean_baseuris ~basedir ~verbose:false [baseuri];
- opt_exit n
- with GrafiteTypes.Option_error("baseuri", "not found") ->
- (* no baseuri ==> nothing to clean yet *)
- opt_exit n
-
-let rec interactive_loop () =
- let str = Ulexing.from_utf8_channel stdin in
- try
- run_script str
- (MatitaEngine.eval_from_stream ~first_statement_only:false ~prompt:true
- ~include_paths:(Helm_registry.get_list Helm_registry.string
- "matita.includes"))
- with
- | GrafiteEngine.Drop -> pp_ocaml_mode ()
- | GrafiteEngine.Macro (floc,_) ->
- let x, y = HExtlib.loc_of_floc floc in
- HLog.error
- (sprintf "A macro has been found in a script at %d-%d" x y);
- interactive_loop ()
- | Sys.Break -> HLog.error "user break!"; interactive_loop ()
- | GrafiteTypes.Command_error _ -> interactive_loop ()
- | End_of_file ->
- print_newline ();
- clean_exit (Some 0)
- | HExtlib.Localized (floc,CicNotationParser.Parse_error err) ->
- let x, y = HExtlib.loc_of_floc floc in
- HLog.error (sprintf "Parse error at %d-%d: %s" x y err);
- interactive_loop ()
- | exn -> HLog.error (Printexc.to_string exn); interactive_loop ()
-
-let go () =
- Helm_registry.load_from BuildTimeConf.matita_conf;
- Http_getter.init ();
- MetadataTypes.ownerize_tables (Helm_registry.get "matita.owner");
- LibraryDb.create_owner_environment ();
- CicEnvironment.set_trust (* environment trust *)
- (let trust =
- Helm_registry.get_opt_default Helm_registry.get_bool
- ~default:true "matita.environment_trust" in
- fun _ -> trust);
- let include_paths =
- Helm_registry.get_list Helm_registry.string "matita.includes" in
- grafite_status := Some (GrafiteSync.init ());
- lexicon_status :=
- Some (CicNotation2.load_notation ~include_paths
- BuildTimeConf.core_notation_script);
- Sys.catch_break true;
- interactive_loop ()
-
-let main ~mode =
- MatitaInit.initialize_all ();
- (* must be called after init since args are set by cmdline parsing *)
- let fname = fname () in
- let include_paths =
- Helm_registry.get_list Helm_registry.string "matita.includes" in
- grafite_status := Some (GrafiteSync.init ());
- lexicon_status :=
- Some (CicNotation2.load_notation ~include_paths
- BuildTimeConf.core_notation_script);
- Sys.catch_break true;
- let origcb = HLog.get_log_callback () in
- let newcb tag s =
- match tag with
- | `Debug | `Message -> ()
- | `Warning | `Error -> origcb tag s
- in
- if Helm_registry.get_bool "matita.quiet" then
- HLog.set_log_callback newcb;
- let matita_debug = Helm_registry.get_bool "matita.debug" in
- try
- let time = Unix.time () in
- if Helm_registry.get_bool "matita.quiet" then
- origcb `Message ("compiling " ^ Filename.basename fname ^ "...")
- else
- HLog.message (sprintf "execution of %s started:" fname);
- let is =
- Ulexing.from_utf8_channel
- (match fname with
- | "stdin" -> stdin
- | fname -> open_in fname) in
- let include_paths =
- Helm_registry.get_list Helm_registry.string "matita.includes" in
- (try
- run_script is
- (MatitaEngine.eval_from_stream ~first_statement_only:false ~include_paths
- ~clean_baseuri:(not (Helm_registry.get_bool "matita.preserve")))
- with End_of_file -> ());
- let elapsed = Unix.time () -. time in
- let tm = Unix.gmtime elapsed in
- let sec = string_of_int tm.Unix.tm_sec ^ "''" in
- let min =
- if tm.Unix.tm_min > 0 then (string_of_int tm.Unix.tm_min ^ "' ") else ""
- in
- let hou =
- if tm.Unix.tm_hour > 0 then (string_of_int tm.Unix.tm_hour ^ "h ") else ""
- in
- let proof_status,moo_content_rev,metadata,lexicon_content_rev =
- match !lexicon_status,!grafite_status with
- | Some ss, Some s ->
- s.proof_status, s.moo_content_rev, ss.LexiconEngine.metadata,
- ss.LexiconEngine.lexicon_content_rev
- | _,_ -> assert false
- in
- if proof_status <> GrafiteTypes.No_proof then
- begin
- HLog.error
- "there are still incomplete proofs at the end of the script";
- clean_exit (Some 2)
- end
- else
- begin
- let basedir = Helm_registry.get "matita.basedir" in
- let baseuri =
- DependenciesParser.baseuri_of_script ~include_paths fname in
- let moo_fname = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in
- let lexicon_fname= LibraryMisc.lexicon_file_of_baseuri ~basedir ~baseuri in
- let metadata_fname =
- LibraryMisc.metadata_file_of_baseuri ~basedir ~baseuri
- in
- GrafiteMarshal.save_moo moo_fname moo_content_rev;
- LibraryNoDb.save_metadata metadata_fname metadata;
- LexiconMarshal.save_lexicon lexicon_fname lexicon_content_rev;
- HLog.message
- (sprintf "execution of %s completed in %s." fname (hou^min^sec));
- exit 0
- end
- with
- | Sys.Break ->
- HLog.error "user break!";
- if mode = `COMPILER then
- clean_exit (Some ~-1)
- else
- pp_ocaml_mode ()
- | GrafiteEngine.Drop ->
- if mode = `COMPILER then
- clean_exit (Some 1)
- else
- pp_ocaml_mode ()
- | GrafiteEngine.Macro (floc,_) ->
- let x, y = HExtlib.loc_of_floc floc in
- HLog.error
- (sprintf "A macro has been found in a script at %d-%d" x y);
- if mode = `COMPILER then
- clean_exit (Some 1)
- else
- pp_ocaml_mode ()
- | HExtlib.Localized (floc,CicNotationParser.Parse_error err) ->
- let (x, y) = HExtlib.loc_of_floc floc in
- HLog.error (sprintf "Parse error at %d-%d: %s" x y err);
- if mode = `COMPILER then
- clean_exit (Some 1)
- else
- pp_ocaml_mode ()
- | exn ->
- if matita_debug then raise exn;
- if mode = `COMPILER then
- clean_exit (Some 3)
- else
- pp_ocaml_mode ()
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-module GA = GrafiteAst
-module U = UriManager
-
-let main () =
- (* all are maps from "file" to "something" *)
- let include_deps = Hashtbl.create (Array.length Sys.argv) in
- let baseuri_of = Hashtbl.create (Array.length Sys.argv) in
- let uri_deps = Hashtbl.create (Array.length Sys.argv) in
- let buri alias = U.buri_of_uri (U.uri_of_string alias) in
- let resolve alias current_buri =
- let buri = buri alias in
- if buri <> current_buri then Some buri else None in
- MatitaInit.fill_registry ();
- MatitaInit.parse_cmdline ();
- MatitaInit.load_configuration_file ();
- let include_paths =
- Helm_registry.get_list Helm_registry.string "matita.includes" in
- let basedir = Helm_registry.get "matita.basedir" in
- List.iter
- (fun ma_file ->
- let ic = open_in ma_file in
- let istream = Ulexing.from_utf8_channel ic in
- let dependencies = DependenciesParser.parse_dependencies istream in
- close_in ic;
- List.iter
- (function
- | DependenciesParser.UriDep uri ->
- let uri = UriManager.string_of_uri uri in
- if not (Http_getter_storage.is_legacy uri) then
- Hashtbl.add uri_deps ma_file uri
- | DependenciesParser.BaseuriDep uri ->
- let uri = Http_getter_misc.strip_trailing_slash uri in
- Hashtbl.add baseuri_of ma_file uri
- | DependenciesParser.IncludeDep path ->
- try
- let baseuri =
- DependenciesParser.baseuri_of_script ~include_paths path in
- if not (Http_getter_storage.is_legacy baseuri) then
- let moo_file =
- LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in
- Hashtbl.add include_deps ma_file moo_file
- with Sys_error _ ->
- HLog.warn
- ("Unable to find " ^ path ^ " that is included in " ^ ma_file)
- ) dependencies
- ) (Helm_registry.get_list Helm_registry.string "matita.args");
- Hashtbl.iter
- (fun file alias ->
- let dep = resolve alias (Hashtbl.find baseuri_of file) in
- match dep with
- | None -> ()
- | Some u ->
- Hashtbl.add include_deps file
- (LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri:u))
- uri_deps;
- List.iter
- (fun ma_file ->
- let deps = Hashtbl.find_all include_deps ma_file in
- let deps = List.fast_sort Pervasives.compare deps in
- let deps = HExtlib.list_uniq deps in
- let deps = ma_file :: deps in
- let baseuri = Hashtbl.find baseuri_of ma_file in
- let moo = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in
- Printf.printf "%s: %s\n" moo (String.concat " " deps);
- Printf.printf "%s: %s\n" (Pcre.replace ~pat:"ma$" ~templ:"mo" ma_file) moo)
- (Helm_registry.get_list Helm_registry.string "matita.args")
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-module MK = MatitamakeLib ;;
-
-let main () =
- MatitaInit.fill_registry ();
- MatitaInit.load_configuration_file ();
- MK.initialize ();
- let usage = ref (fun () -> ()) in
- let dev_of_name name =
- match MK.development_for_name name with
- | None ->
- prerr_endline ("Unable to find a development called " ^ name);
- exit 1
- | Some d -> d
- in
- let dev_for_dir dir =
- match MK.development_for_dir dir with
- | None ->
- prerr_endline ("Unable to find a development holding directory: "^ dir);
- exit 1
- | Some d -> d
- in
- let init_dev_doc = "
-\tParameters: name (the name of the development, required)
-\tDescription: tells matitamake that a new development radicated
-\t\tin the current working directory should be handled."
- in
- let init_dev args =
- if List.length args <> 1 then !usage ();
- match MK.initialize_development (List.hd args) (Unix.getcwd ()) with
- | None -> exit 2
- | Some _ -> exit 0
- in
- let list_dev_doc = "
-\tParameters:
-\tDescription: lists the known developments and their roots."
- in
- let list_dev args =
- if List.length args <> 0 then !usage ();
- match MK.list_known_developments () with
- | [] -> print_string "No developments found.\n"; exit 0
- | l ->
- List.iter
- (fun (name, root) ->
- print_string (Printf.sprintf "%-10s\trooted in %s\n" name root))
- l;
- exit 0
- in
- let destroy_dev_doc = "
-\tParameters: name (the name of the development to destroy, required)
-\tDescription: deletes a development (only from matitamake metadat, no
-\t\t.ma files will be deleted)."
- in
- let destroy_dev args =
- if List.length args <> 1 then !usage ();
- let name = (List.hd args) in
- let dev = dev_of_name name in
- MK.destroy_development dev;
- exit 0
- in
- let clean_dev_doc = "
-\tParameters: name (the name of the development to destroy, optional)
-\t\tIf omitted the development that holds the current working
-\t\tdirectory is used (if any).
-\tDescription: clean the develpoment."
- in
- let clean_dev args =
- let dev =
- match args with
- | [] -> dev_for_dir (Unix.getcwd ())
- | [name] -> dev_of_name name
- | _ -> !usage (); exit 1
- in
- match MK.clean_development dev with
- | true -> exit 0
- | false -> exit 1
- in
- let build_dev_doc = "
-\tParameters: name (the name of the development to build, required)
-\tDescription: completely builds the develpoment."
- in
- let build_dev args =
- if List.length args <> 1 then !usage ();
- let name = (List.hd args) in
- let dev = dev_of_name name in
- match MK.build_development dev with
- | true -> exit 0
- | false -> exit 1
- in
- let nodb_doc = "
-\tParameters:
-\tDescription: avoid using external database connection."
- in
- let nodb _ = Helm_registry.set_bool "db.nodb" true in
- let target args =
- if List.length args < 1 then !usage ();
- let dev = dev_for_dir (Unix.getcwd ()) in
- List.iter
- (fun t ->
- ignore(MK.build_development ~target:t dev))
- args
- in
- let params = [
- "-init", init_dev, init_dev_doc;
- "-clean", clean_dev, clean_dev_doc;
- "-list", list_dev, list_dev_doc;
- "-destroy", destroy_dev, destroy_dev_doc;
- "-build", build_dev, build_dev_doc;
- "-nodb", nodb, nodb_doc;
- "-h", (fun _ -> !usage()), "print this help screen";
- "-help", (fun _ -> !usage()), "print this help screen";
- ]
- in
- usage := (fun () ->
- let p = prerr_endline in
- p "\nusage:";
- p "\tmatitamake(.opt) [command [options]]\n";
- p "\tmatitamake(.opt) [target]\n";
- p "commands:";
- List.iter (fun (n,_,d) -> p (Printf.sprintf " %-10s%s" n d)) params;
- p "\nIf target is omitted a 'all' will be used as the default.";
- p "With -build you can build a development wherever it is.";
- p "If you specify a target it implicitly refers to the development that";
- p "holds the current working directory (if any).\n";
- exit 1);
- let rec parse args =
- match args with
- | [] -> target ["all"]
- | s::tl ->
- try
- let _,f,_ = List.find (fun (n,_,_) -> n = s) params in
- f tl;
- parse tl
- with Not_found -> if s.[0] = '-' then !usage () else target args
- in
- parse (List.tl (Array.to_list Sys.argv))
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-
-let logger = fun mark ->
- match mark with
- | `Error -> HLog.error
- | `Warning -> HLog.warn
- | `Debug -> HLog.debug
- | `Message -> HLog.message
-;;
-
-type development =
- { root: string ; name: string }
-
-let developments = ref []
-
-let pool () = Helm_registry.get "matita.basedir" ^ "/matitamake/" ;;
-let rootfile = "/root" ;;
-
-let ls_dir dir =
- try
- let d = Unix.opendir dir in
- let content = ref [] in
- try
- while true do
- let name = Unix.readdir d in
- if name <> "." && name <> ".." then
- content := name :: !content
- done;
- Some []
- with End_of_file -> Unix.closedir d; Some !content
- with Unix.Unix_error _ -> None
-
-let initialize () =
- (* create a base env if none *)
- HExtlib.mkdir (pool ());
- (* load developments *)
- match ls_dir (pool ()) with
- | None -> logger `Error ("Unable to list directory " ^ pool ())
- | Some l ->
- List.iter
- (fun name ->
- let root =
- try
- Some (HExtlib.input_file (pool () ^ name ^ rootfile))
- with Unix.Unix_error _ ->
- logger `Warning ("Malformed development " ^ name);
- None
- in
- match root with
- | None -> ()
- | Some root ->
- developments := {root = root ; name = name} :: !developments)
- l
-
-(* finds the makefile path for development devel *)
-let makefile_for_development devel =
- let develdir = pool () ^ devel.name in
- develdir ^ "/makefile"
-;;
-
-(* given a dir finds a development that is radicated in it or below *)
-let development_for_dir dir =
- let is_prefix_of d1 d2 =
- let len1 = String.length d1 in
- let len2 = String.length d2 in
- if len2 < len1 then
- false
- else
- let pref = String.sub d2 0 len1 in
- pref = d1
- in
- (* it must be unique *)
- try
- Some (List.find (fun d -> is_prefix_of d.root dir) !developments)
- with Not_found -> None
-;;
-
-let development_for_name name =
- try
- Some (List.find (fun d -> d.name = name) !developments)
- with Not_found -> None
-
-(* dumps the deveopment to disk *)
-let dump_development devel =
- let devel_dir = pool () ^ devel.name in
- HExtlib.mkdir devel_dir;
- HExtlib.output_file ~filename:(devel_dir ^ rootfile) ~text:devel.root
-;;
-
-let list_known_developments () =
- List.map (fun r -> r.name,r.root) !developments
-
-let am_i_opt () =
- if Pcre.pmatch ~pat:"\\.opt$" Sys.argv.(0) then ".opt" else ""
-
-let rebuild_makefile development =
- let makefilepath = makefile_for_development development in
- let template =
- HExtlib.input_file BuildTimeConf.matitamake_makefile_template
- in
- let cc = BuildTimeConf.runtime_base_dir ^ "/matitac" ^ am_i_opt () in
- let rm = BuildTimeConf.runtime_base_dir ^ "/matitaclean" ^ am_i_opt () in
- let mm = BuildTimeConf.runtime_base_dir ^ "/matitadep" ^ am_i_opt () in
- let df = pool () ^ development.name ^ "/depend" in
- let template = Pcre.replace ~pat:"@ROOT@" ~templ:development.root template in
- let template = Pcre.replace ~pat:"@CC@" ~templ:cc template in
- let template = Pcre.replace ~pat:"@DEP@" ~templ:mm template in
- let template = Pcre.replace ~pat:"@DEPFILE@" ~templ:df template in
- let template = Pcre.replace ~pat:"@CLEAN@" ~templ:rm template in
- HExtlib.output_file ~filename:makefilepath ~text:template
-
-(* creates a new development if possible *)
-let initialize_development name dir =
- let name = Pcre.replace ~pat:" " ~templ:"_" name in
- let dev = {name = name ; root = dir} in
- match development_for_dir dir with
- | Some d ->
- logger `Error
- ("Directory " ^ dir ^ " is already handled by development " ^ d.name);
- logger `Error
- ("Development " ^ d.name ^ " is rooted in " ^ d.root);
- logger `Error
- (dir ^ " is a subdir of " ^ d.root);
- None
- | None ->
- dump_development dev;
- rebuild_makefile dev;
- developments := dev :: !developments;
- Some dev
-
-let make chdir args =
- let old = Unix.getcwd () in
- try
- Unix.chdir chdir;
- let rc =
- Unix.system
- (String.concat " " ("make"::(List.map Filename.quote args)))
- in
- Unix.chdir old;
- match rc with
- | Unix.WEXITED 0 -> true
- | Unix.WEXITED i -> logger `Error ("make returned " ^ string_of_int i);false
- | _ -> logger `Error "make STOPPED or SIGNALED!";false
- with Unix.Unix_error (_,cmd,err) ->
- logger `Warning ("Unix Error: " ^ cmd ^ ": " ^ err);
- false
-
-let call_make development target make =
- rebuild_makefile development;
- let makefile = makefile_for_development development in
- let nodb =
- Helm_registry.get_opt_default Helm_registry.bool ~default:false "db.nodb"
- in
- let flags = [] in
- let flags = flags @ if nodb then ["NODB=true"] else [] in
- let flags =
- try
- flags @ [ sprintf "MATITA_FLAGS=\"%s\"" (Sys.getenv "MATITA_FLAGS") ]
- with Not_found -> flags in
- make development.root
- (["--no-print-directory"; "-s"; "-k"; "-f"; makefile; target]
- @ flags)
-
-let build_development ?(target="all") development =
- call_make development target make
-
-(* not really good vt100 *)
-let vt100 s =
- let rex = Pcre.regexp "\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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
+++ /dev/null
-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
-
+++ /dev/null
-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;
+++ /dev/null
-MAILTO=helm@cs.unibo.it
-HOME=/home/tassi/
-#SVNOPTIONS='-r {2006-01-09}'
-10 5 * * * sh /home/tassi/helm/matita/scripts/crontab.sh
+++ /dev/null
-#!/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
-
+++ /dev/null
-#!/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
+++ /dev/null
- {
- 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;
- }
+++ /dev/null
-#!/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
+++ /dev/null
-<?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 : ";
- 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> ";
- }
- $q1 = str_replace(urlencode("***"), " ", $q);
- echo "<a href=\"showquery.php?query=$q1;\">" .
- minus1_to_all("-1") . "</a> ";
- }
- 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>
+++ /dev/null
-<?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>";
-}
-
-?>
+++ /dev/null
-<?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;
-?>
+++ /dev/null
-<?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>
+++ /dev/null
-<?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>
+++ /dev/null
-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;
-}
-
-
+++ /dev/null
-<?php
- require($argv[1]);
- $rc = query($argv[2]);
- $a = array_values($rc[0]);
- print($a[0]);
-?>
+++ /dev/null
-<?php
- require($argv[1]);
- print(time_2_cents($argv[2]));
-?>
+++ /dev/null
-SRC=$(shell find @ROOT@ -name "*.ma" -a -type f)
-TODO=$(SRC:%.ma=%.mo)
-
-MATITA_FLAGS=
-MATITA_FLAGS+=-noprofile
-NODB=false
-ifeq ($(NODB),true)
- MATITA_FLAGS += -nodb
-endif
-
-MATITAC=@CC@
-MATITACLEAN=@CLEAN@
-MATITADEP=@DEP@
-
-all: $(TODO)
-
-clean:
- $(MATITACLEAN) $(MATITA_FLAGS) $(SRC)
- rm -f $(TODO)
-
-%.moo:
- ($(MATITAC) $(MATITA_FLAGS) -q -I @ROOT@ $< | (grep -v "^make" || true))
-
-@DEPFILE@ : $(SRC)
- $(MATITADEP) $(MATITA_FLAGS) -I '@ROOT@' $^ 1> @DEPFILE@
-
-# this is the depend for full targets like:
-# dir/dir/name.moo: dir/dir/name.ma dir/dep.moo
--include @DEPFILE@
+++ /dev/null
-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
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||M|| *)
-(* ||A|| A project by Andrea Asperti *)
-(* ||T|| *)
-(* ||I|| Developers: *)
-(* ||T|| The HELM team. *)
-(* ||A|| http://helm.cs.unibo.it *)
-(* \ / *)
-(* \ / This file is distributed under the terms of the *)
-(* v GNU General Public License Version 2 *)
-(* *)
-(**************************************************************************)
-
-set "baseuri" "cic:/matita/SK/".
-
-include "legacy/coq.ma".
-alias symbol "eq" = "Coq's leibnitz's equality".
-
-theorem SKK:
- \forall A:Set.
- \forall app: A \to A \to A.
- \forall K:A.
- \forall S:A.
- \forall H1: (\forall x,y:A.(app (app K x) y) = x).
- \forall H2: (\forall x,y,z:A.
- (app (app (app S x) y) z) = (app (app x z) (app y z))).
- \forall x:A.
- (app (app (app S K) K) x) = x.
-intros.auto paramodulation.
-qed.
-
-theorem bool1:
- \forall A:Set.
- \forall one:A.
- \forall zero:A.
- \forall add: A \to A \to A.
- \forall mult: A \to A \to A.
- \forall inv: A \to A.
- \forall c1:(\forall x,y:A.(add x y) = (add y x)).
- \forall c2:(\forall x,y:A.(mult x y) = (mult y x)).
- \forall d1: (\forall x,y,z:A.
- (add x (mult y z)) = (mult (add x y) (add x z))).
- \forall d2: (\forall x,y,z:A.
- (mult x (add y z)) = (add (mult x y) (mult x z))).
- \forall i1: (\forall x:A. (add x zero) = x).
- \forall i2: (\forall x:A. (mult x one) = x).
- \forall inv1: (\forall x:A. (add x (inv x)) = one).
- \forall inv2: (\forall x:A. (mult x (inv x)) = zero).
- (inv zero) = one.
-intros.auto paramodulation.
-qed.
-
-theorem bool2:
- \forall A:Set.
- \forall one:A.
- \forall zero:A.
- \forall add: A \to A \to A.
- \forall mult: A \to A \to A.
- \forall inv: A \to A.
- \forall c1:(\forall x,y:A.(add x y) = (add y x)).
- \forall c2:(\forall x,y:A.(mult x y) = (mult y x)).
- \forall d1: (\forall x,y,z:A.
- (add x (mult y z)) = (mult (add x y) (add x z))).
- \forall d2: (\forall x,y,z:A.
- (mult x (add y z)) = (add (mult x y) (mult x z))).
- \forall i1: (\forall x:A. (add x zero) = x).
- \forall i2: (\forall x:A. (mult x one) = x).
- \forall inv1: (\forall x:A. (add x (inv x)) = one).
- \forall inv2: (\forall x:A. (mult x (inv x)) = zero).
- \forall x:A. (mult x zero) = zero.
-intros.auto paramodulation.
-qed.
-
-theorem bool3:
- \forall A:Set.
- \forall one:A.
- \forall zero:A.
- \forall add: A \to A \to A.
- \forall mult: A \to A \to A.
- \forall inv: A \to A.
- \forall c1:(\forall x,y:A.(add x y) = (add y x)).
- \forall c2:(\forall x,y:A.(mult x y) = (mult y x)).
- \forall d1: (\forall x,y,z:A.
- (add x (mult y z)) = (mult (add x y) (add x z))).
- \forall d2: (\forall x,y,z:A.
- (mult x (add y z)) = (add (mult x y) (mult x z))).
- \forall i1: (\forall x:A. (add x zero) = x).
- \forall i2: (\forall x:A. (mult x one) = x).
- \forall inv1: (\forall x:A. (add x (inv x)) = one).
- \forall inv2: (\forall x:A. (mult x (inv x)) = zero).
- \forall x:A. (inv (inv x)) = x.
-intros.auto paramodulation.
-qed.
-
-theorem bool2:
- \forall A:Set.
- \forall one:A.
- \forall zero:A.
- \forall add: A \to A \to A.
- \forall mult: A \to A \to A.
- \forall inv: A \to A.
- \forall c1:(\forall x,y:A.(add x y) = (add y x)).
- \forall c2:(\forall x,y:A.(mult x y) = (mult y x)).
- \forall d1: (\forall x,y,z:A.
- (add x (mult y z)) = (mult (add x y) (add x z))).
- \forall d2: (\forall x,y,z:A.
- (mult x (add y z)) = (add (mult x y) (mult x z))).
- \forall i1: (\forall x:A. (add x zero) = x).
- \forall i2: (\forall x:A. (mult x one) = x).
- \forall inv1: (\forall x:A. (add x (inv x)) = one).
- \forall inv2: (\forall x:A. (mult x (inv x)) = zero).
- \forall x,y:A.
- (inv (mult x y)) = (add (inv x) (inv y)).
-intros.auto paramodulation.
-qed.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-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
+++ /dev/null
-\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:/matita/legacy/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
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-\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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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/".
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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)).
-
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
-
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||M|| *)
-(* ||A|| A project by Andrea Asperti *)
-(* ||T|| *)
-(* ||I|| Developers: *)
-(* ||T|| The HELM team. *)
-(* ||A|| http://helm.cs.unibo.it *)
-(* \ / *)
-(* \ / This file is distributed under the terms of the *)
-(* v GNU General Public License Version 2 *)
-(* *)
-(**************************************************************************)
-
-set "baseuri" "cic:/matita/demodulation/".
-
-include "legacy/coq.ma".
-
-alias num = "natural number".
-alias symbol "times" = "Coq's natural times".
-alias symbol "plus" = "Coq's natural plus".
-alias symbol "eq" = "Coq's leibnitz's equality".
-alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)".
-alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)".
-
-
-theorem p0 : \forall m:nat. m+O = m.
-intro. demodulate.
-
-theorem p: \forall m.1*m = m.
-intros.demodulate.reflexivity.
-qed.
-
-theorem p2: \forall x,y:nat.(S x)*y = (y+x*y).
-intros.demodulate.reflexivity.
-qed.
-
-theorem p1: \forall x,y:nat.(S ((S x)*y+x))=(S x)+(y*x+y).
-intros.demodulate.reflexivity.
-qed.
-
-theorem p3: \forall x,y:nat. (x+y)*(x+y) = x*x + 2*(x*y) + (y*y).
-intros.demodulate.reflexivity.
-qed.
-
-theorem p4: \forall x:nat. (x+1)*(x-1)=x*x - 1.
-intro.
-apply (nat_case x)
-[simplify.reflexivity
-|intro.demodulate.reflexivity]
-qed.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||M|| *)
-(* ||A|| A project by Andrea Asperti *)
-(* ||T|| *)
-(* ||I|| Developers: *)
-(* ||T|| The HELM team. *)
-(* ||A|| http://helm.cs.unibo.it *)
-(* \ / *)
-(* \ / This file is distributed under the terms of the *)
-(* v GNU General Public License Version 2 *)
-(* *)
-(**************************************************************************)
-
-set "baseuri" "cic:/matita/demodulation_matita/".
-
-include "nat/minus.ma".
-
-theorem p2: \forall x,y:nat. x+x = (S(S O))*x.
-intros.demodulate.reflexivity.
-qed.
-
-theorem p4: \forall x:nat. (x+(S O))*(x-(S O))=x*x - (S O).
-intro.
-apply (nat_case x)
-[simplify.reflexivity
-|intro.demodulate.reflexivity]
-qed.
-
-theorem p5: \forall x,y:nat. (x+y)*(x+y) = x*x + (S(S O))*(x*y) + (y*y).
-intros.demodulate.reflexivity.
-qed.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-*)
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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
+++ /dev/null
-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.
+++ /dev/null
-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".
+++ /dev/null
-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.
+++ /dev/null
-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.
+++ /dev/null
-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.
+++ /dev/null
-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).
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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) ].
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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].
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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
-}.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||M|| *)
-(* ||A|| A project by Andrea Asperti *)
-(* ||T|| *)
-(* ||I|| Developers: *)
-(* ||T|| The HELM team. *)
-(* ||A|| http://helm.cs.unibo.it *)
-(* \ / *)
-(* \ / This file is distributed under the terms of the *)
-(* v GNU General Public License Version 2 *)
-(* *)
-(**************************************************************************)
-
-set "baseuri" "cic:/matita/tests/simpl/".
-include "legacy/coq.ma".
-
-alias symbol "eq" (instance 0) = "Coq's leibnitz's equality".
-alias id "plus" = "cic:/Coq/Init/Peano/plus.con".
-alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)".
-alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)".
-alias id "not" = "cic:/Coq/Init/Logic/not.con".
-alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)".
-alias id "plus_comm" = "cic:/Coq/Arith/Plus/plus_comm.con".
-
-theorem t: let f \def \lambda x,y. x y in f (\lambda x.S x) O = S O.
- intros. simplify. change in \vdash (? ? (? ? %) ?) with O.
- reflexivity. qed.
-
-theorem X: \forall x:nat. let myplus \def plus x in myplus (S O) = S x.
- intros. simplify. change in \vdash (? ? (% ?) ?) with (plus x).
-
-rewrite > plus_comm. reflexivity. qed.
-
-theorem R: \forall x:nat. let uno \def x + O in S O + uno = 1 + x.
- intros. simplify.
- change in \vdash (? ? (? %) ?) with (x + O).
- rewrite > plus_comm. reflexivity. qed.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
-
+++ /dev/null
-(**************************************************************************)
-(* ___ *)
-(* ||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.
+++ /dev/null
-requires="helm-cic_acic"
-version="0.0.1"
-archive(byte)="acic_content.cma"
-archive(native)="acic_content.cmxa"
+++ /dev/null
-requires="helm-urimanager helm-xml expat"
-version="0.0.1"
-archive(byte)="cic.cma"
-archive(native)="cic.cmxa"
-linkopts=""
+++ /dev/null
-requires="helm-cic_proof_checking"
-version="0.0.1"
-archive(byte)="cic_acic.cma"
-archive(native)="cic_acic.cmxa"
+++ /dev/null
-requires="helm-whelp helm-acic_content helm-cic_unification"
-version="0.0.1"
-archive(byte)="cic_disambiguation.cma"
-archive(native)="cic_disambiguation.cmxa"
+++ /dev/null
-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=""
+++ /dev/null
-requires="helm-cic_proof_checking helm-library"
-version="0.0.1"
-archive(byte)="cic_unification.cma"
-archive(native)="cic_unification.cmxa"
-linkopts=""
+++ /dev/null
-requires="helm-acic_content helm-utf8_macros camlp4.gramlib ulex"
-version="0.0.1"
-archive(byte)="content_pres.cma"
-archive(native)="content_pres.cmxa"
+++ /dev/null
-requires="unix camlp4.gramlib"
-version="0.0.1"
-archive(byte)="extlib.cma"
-archive(native)="extlib.cmxa"
-linkopts=""
+++ /dev/null
-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=""
+++ /dev/null
-requires="helm-cic"
-version="0.0.1"
-archive(byte)="grafite.cma"
-archive(native)="grafite.cmxa"
+++ /dev/null
-requires="helm-library helm-grafite helm-tactics"
-version="0.0.1"
-archive(byte)="grafite_engine.cma"
-archive(native)="grafite_engine.cmxa"
-linkopts=""
+++ /dev/null
-requires="helm-lexicon helm-grafite ulex"
-version="0.0.1"
-archive(byte)="grafite_parser.cma"
-archive(native)="grafite_parser.cmxa"
-linkopts=""
+++ /dev/null
-requires="helm-xml gdome2"
-version="0.0.1"
-archive(byte)="hgdome.cma"
-archive(native)="hgdome.cmxa"
+++ /dev/null
-requires="helm-registry mysql helm-extlib"
-version="0.0.1"
-archive(byte)="hmysql.cma"
-archive(native)="hmysql.cmxa"
+++ /dev/null
-requires="helm-content_pres helm-cic_disambiguation camlp4.gramlib"
-version="0.0.1"
-archive(byte)="lexicon.cma"
-archive(native)="lexicon.cmxa"
+++ /dev/null
-requires="helm-cic_acic helm-metadata"
-version="0.0.1"
-archive(byte)="library.cma"
-archive(native)="library.cmxa"
-linkopts=""
+++ /dev/null
-requires=""
-version="0.0.1"
-archive(byte)="logger.cma"
-archive(native)="logger.cmxa"
-linkopts=""
+++ /dev/null
-requires="helm-hmysql helm-cic_proof_checking"
-version="0.0.1"
-archive(byte)="metadata.cma"
-archive(native)="metadata.cmxa"
+++ /dev/null
-requires="str netstring helm-xml"
-version="0.0.1"
-archive(byte)="registry.cma"
-archive(native)="registry.cmxa"
+++ /dev/null
-requires="helm-cic_proof_checking helm-cic_unification helm-whelp"
-version="0.0.1"
-archive(byte)="tactics.cma"
-archive(native)="tactics.cmxa"
+++ /dev/null
-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=""
+++ /dev/null
-requires="str"
-version="0.0.1"
-archive(byte)="urimanager.cma"
-archive(native)="urimanager.cmxa"
-linkopts=""
+++ /dev/null
-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=""
+++ /dev/null
-requires="helm-metadata"
-version="0.0.1"
-archive(byte)="whelp.cma"
-archive(native)="whelp.cmxa"
+++ /dev/null
-requires="zip expat helm-extlib"
-version="0.0.1"
-archive(byte)="xml.cma"
-archive(native)="xml.cmxa"
-linkopts=""
+++ /dev/null
-requires="gdome2"
-version="0.0.1"
-archive(byte)="xmldiff.cma"
-archive(native)="xmldiff.cmxa"
+++ /dev/null
-
-export SHELL=/bin/bash
-
-include ../Makefile.defs
-
-# Warning: the modules must be in compilation order
-NULL =
-MODULES = \
- extlib \
- xml \
- hgdome \
- registry \
- hmysql \
- utf8_macros \
- thread \
- xmldiff \
- urimanager \
- logger \
- getter \
- cic \
- cic_proof_checking \
- cic_acic \
- acic_content \
- content_pres \
- grafite \
- metadata \
- library \
- cic_unification \
- whelp \
- tactics \
- cic_disambiguation \
- lexicon \
- grafite_engine \
- grafite_parser \
- tactics/paramodulation \
- $(NULL)
-
-METAS = $(filter-out %/paramodulation,$(MODULES:%=METAS/META.helm-%))
-
-all: metas $(MODULES:%=%.all)
-opt: metas $(MODULES:%=%.opt)
-world: all opt
-depend: $(MODULES:%=%.depend)
-install: $(MODULES:%=%.install)
-uninstall: $(MODULES:%=%.uninstall)
-clean: $(MODULES:%=%.clean) clean_metas
-
-.stats: $(MODULES:%=%.stats)
- (for m in $(MODULES); do echo -n "$$m:"; cat $$m/.stats; done) \
- | sort -t : -k 2 -n -r > .stats
-
-EXTRA_DIST_CLEAN = \
- libraries-clusters.ps \
- libraries-clusters.pdf \
- libraries-ext.ps \
- libraries.ps \
- .dep.dot \
- .extdep.dot \
- .clustersdep.dot \
- $(NULL)
-
-distclean: clean clean_metas
- rm -f $(METAS)
- rm -f configure config.log config.cache config.status
- rm -f $(EXTRA_DIST_CLEAN)
-
-.PHONY: all opt world metas depend install uninstall clean clean_metas distclean
-
-%.all:
- $(MAKE) -C $* all
-%.opt:
- $(MAKE) -C $* opt
-%.clean:
- $(MAKE) -C $* clean
-%.depend:
- $(MAKE) -C $* depend
-%.stats:
- @$(MAKE) -C $* .stats
-%.install:
- $(MAKE) -C $* install
-%.uninstall:
- $(MAKE) -C $* uninstall
-
-METAS/META.helm-%: METAS/meta.helm-%.src
- cp $< $@ && echo "directory=\"$(shell pwd)/$*\"" >> $@
-
-.PHONY: .dep.dot
-.dep.dot:
- echo "digraph G {" > $@
- echo " rankdir = TB ;" >> $@
- for i in $(MODULES); do $(OCAMLFIND) query helm-$$i -recursive -p-format | grep helm | sed "s/^helm-/ \"$$i\" -> \"/g" | sed "s/$$/\";/g" >> $@ ; done
- mv $@ $@.old ; ./simplify_deps/simplify_deps.opt < $@.old > $@ ; rm $@.old
- echo "}" >> $@
-
-.PHONY: .alldep.dot
-.alldep.dot:
- echo "digraph G {" > $@
- echo " rankdir = TB ;" >> $@
- for i in $(MODULES); do $(OCAMLFIND) query helm-$$i -recursive -p-format | grep -v "pxp-" | sed "s/^pxp/pxp[-*]/g" | sed "s/^/ \"helm-$$i\" -> \"/g" | sed "s/$$/\";/g" >> $@ ; done
- mv $@ $@.old ; ./simplify_deps/simplify_deps.opt < $@.old > $@ ; rm $@.old
- for i in $(MODULES); do echo "\"helm-$$i\" [shape=box,style=filled,fillcolor=yellow];" >> $@ ; done
- echo "}" >> $@
-
-.extdep.dot: .dep.dot
- STATS/patch_deps.sh $< $@
-.clustersdep.dot: .dep.dot
- USE_CLUSTERS=yes STATS/patch_deps.sh $< $@
-
-libraries.ps: .dep.dot
- dot -Tps -o $@ $<
-libraries-ext.ps: .extdep.dot
- dot -Tps -o $@ $<
-libraries-clusters.ps: .clustersdep.dot
- dot -Tps -o $@ $<
-libraries-complete.ps: .alldep.dot
- dot -Tps -o $@ $<
-
-ps: libraries.ps libraries-ext.ps libraries-clusters.ps
-
-tags: TAGS
-.PHONY: TAGS
-TAGS:
- otags -vi -r .
-
+++ /dev/null
-H=@
-
-# This Makefile must be included by another one defining:
-# $PACKAGE
-# $PREDICATES
-# $INTERFACE_FILES
-# $IMPLEMENTATION_FILES
-# $EXTRA_OBJECTS_TO_INSTALL
-# $EXTRA_OBJECTS_TO_CLEAN
-# and put in a directory where there is a .depend file.
-
-# $OCAMLFIND must be set to a meaningful vaule, including OCAMLPATH=
-
-PREPROCOPTIONS = -pp camlp4o
-SYNTAXOPTIONS = -syntax camlp4o
-PREREQ =
-OCAMLOPTIONS = -package "$(REQUIRES)" -predicates "$(PREDICATES)" -thread
-OCAMLDEBUGOPTIONS = -g
-OCAMLARCHIVEOPTIONS =
-REQUIRES := $(shell $(OCAMLFIND) -query -format '%(requires)' helm-$(PACKAGE))
-OCAMLC = $(OCAMLFIND) ocamlc $(OCAMLDEBUGOPTIONS) $(OCAMLOPTIONS) $(PREPROCOPTIONS)
-OCAMLOPT = $(OCAMLFIND) opt $(OCAMLOPTIONS) $(PREPROCOPTIONS)
-OCAMLDEP = $(OCAMLFIND) ocamldep -package "camlp4 $(CAMLP4REQUIRES)" $(SYNTAXOPTIONS) $(OCAMLDEPOPTIONS)
-OCAMLLEX = ocamllex
-OCAMLYACC = ocamlyacc
-
-OCAMLC_P4 = $(OCAMLFIND) ocamlc $(OCAMLDEBUGOPTIONS) $(OCAMLOPTIONS) $(SYNTAXOPTIONS)
-OCAMLOPT_P4 = $(OCAMLFIND) opt $(OCAMLOPTIONS) $(SYNTAXOPTIONS)
-
-LIBRARIES = $(shell $(OCAMLFIND) query -recursive -predicates "byte $(PREDICATES)" -format "%d/%a" $(REQUIRES))
-LIBRARIES_OPT = $(shell $(OCAMLFIND) query -recursive -predicates "native $(PREDICATES)" -format "%d/%a" $(REQUIRES))
-LIBRARIES_DEPS := \
- $(foreach X,$(filter-out /usr/lib/ocaml%,$(LIBRARIES)),\
- $(wildcard \
- $(shell dirname $(X))/*.mli \
- $(shell dirname $(X))/*.ml \
- $(shell dirname $(X))/paramodulation/*.ml \
- $(shell dirname $(X))/paramodultation/*.mli))
-
-
-ARCHIVE = $(PACKAGE).cma
-ARCHIVE_OPT = $(PACKAGE).cmxa
-OBJECTS_TO_INSTALL = $(ARCHIVE) $(ARCHIVE_OPT) $(ARCHIVE_OPT:%.cmxa=%.a) \
- $(INTERFACE_FILES) $(INTERFACE_FILES:%.mli=%.cmi) \
- $(EXTRA_OBJECTS_TO_INSTALL)
-DEPEND_FILES = $(INTERFACE_FILES) $(IMPLEMENTATION_FILES)
-
-$(ARCHIVE): $(IMPLEMENTATION_FILES:%.ml=%.cmo) $(LIBRARIES)
- $(H)if [ $(PACKAGE) != dummy ]; then \
- echo " OCAMLC -a $@";\
- $(OCAMLC) $(OCAMLARCHIVEOPTIONS) -a -o $@ \
- $(IMPLEMENTATION_FILES:%.ml=%.cmo); fi
-
-$(ARCHIVE_OPT): $(IMPLEMENTATION_FILES:%.ml=%.cmx) $(LIBRARIES_OPT)
- $(H)if [ $(PACKAGE) != dummy ]; then \
- echo " OCAMLOPT -a $@";\
- $(OCAMLOPT) $(OCAMLARCHIVEOPTIONS) -a -o $@ \
- $(IMPLEMENTATION_FILES:%.ml=%.cmx); fi
-
-prereq: $(PREREQ)
-all: prereq $(IMPLEMENTATION_FILES:%.ml=%.cmo) $(ARCHIVE)
- @echo -n
-opt: prereq $(IMPLEMENTATION_FILES:%.ml=%.cmx) $(ARCHIVE_OPT)
- @echo -n
-world: all opt
-test: test.ml $(ARCHIVE)
- $(OCAMLC) $(ARCHIVE) -linkpkg -o $@ $<
-test.opt: test.ml $(ARCHIVE_OPT)
- $(OCAMLOPT) $(ARCHIVE_OPT) -linkpkg -o $@ $<
-install:
-uninstall:
-
-depend: $(DEPEND_FILES)
- $(OCAMLDEP) $(INTERFACE_FILES) $(IMPLEMENTATION_FILES) > .depend
-
-$(PACKAGE).ps: .dep.dot
- dot -Tps -o $@ $<
-
-.dep.dot: .depend
- ocamldot < .depend > $@
-
-%.cmi: %.mli
- @echo " OCAMLC $<"
- $(H)$(OCAMLC) -c $<
-%.cmo %.cmi: %.ml
- @echo " OCAMLC $<"
- $(H)$(OCAMLC) -c $<
-%.cmx: %.ml
- @echo " OCAMLOPT $<"
- $(H)$(OCAMLOPT) -c $<
-%.annot: %.ml
- $(OCAMLC) -dtypes $(PKGS) -c $<
-%.ml %.mli: %.mly
- $(OCAMLYACC) $<
-%.ml: %.mll
- $(OCAMLLEX) $<
-
-ifneq ($(MAKECMDGOALS), clean)
-$(IMPLEMENTATION_FILES:%.ml=%.cmo): $(LIBRARIES)
-$(IMPLEMENTATION_FILES:%.ml=%.cmi): $(LIBRARIES_DEPS)
-$(IMPLEMENTATION_FILES:%.ml=%.cmx): $(LIBRARIES_OPT)
-endif
-
-clean:
- rm -f *.cm[ioax] *.cmxa *.o *.a *.annot $(EXTRA_OBJECTS_TO_CLEAN)
- if [ -f test ]; then rm -f test; else true; fi
- if [ -f test.opt ]; then rm -f test.opt; else true; fi
-
-backup:
- cd ..; tar cvzf $(PACKAGE)_$(shell date +%s).tar.gz $(PACKAGE)
-
-ocamlinit:
- echo "#use \"topfind\";;" > .ocamlinit
- echo "#thread;;" >> .ocamlinit
- for p in $(REQUIRES); do echo "#require \"$$p\";;" >> .ocamlinit; done
- echo "#load \"$(PACKAGE).cma\";;" >> .ocamlinit
-
-# $(STATS_EXCLUDE) may be defined in libraries' Makefile to exclude some file
-# from statistics collection
-STATS_FILES = \
- $(shell find . -maxdepth 1 -type f -name \*.ml $(foreach f,$(STATS_EXCLUDE),-not -name $(f))) \
- $(shell find . -maxdepth 1 -type f -name \*.mli $(foreach f,$(STATS_EXCLUDE),-not -name $(f)))
-.stats: $(STATS_FILES)
- rm -f .stats
- echo -n "LOC:" >> .stats
- wc -l $(STATS_FILES) | tail -1 | awk '{ print $$1 }' >> .stats
-
-.PHONY: all opt world backup depend install uninstall clean ocamlinit
-
-ifneq ($(MAKECMDGOALS), depend)
- include .depend
-endif
-
-NULL =
-
+++ /dev/null
-// clusterrank = none;
- fillcolor = "gray93";
- fontsize = 24;
- node [fontsize = 24];
- /* libs clusters */
- subgraph cluster_presentation {
- label = "Terms at the content and presentation level";
- labelloc = "b";
- labeljust = "r";
- style = "filled";
- color = "white"
- acic_content;
- cic_disambiguation;
- content_pres;
- grafite_parser;
- lexicon;
- }
- subgraph cluster_partially {
- label = "Partially specified terms";
- labelloc = "t";
- labeljust = "l";
- style = "filled";
- color = "white"
- cic_unification;
- tactics;
- grafite;
- grafite_engine;
- }
- subgraph cluster_fully {
- label = "Fully specified terms";
- labelloc = "b";
- labeljust = "l";
- style = "filled";
- color = "white"
- cic;
- cic_proof_checking;
- getter;
- metadata;
- urimanager;
- whelp;
- library;
- cic_acic;
- }
- subgraph cluster_utilities {
- label = "Utilities";
- labelloc = "b";
- labeljust = "r";
- style = "filled";
- color = "white"
- extlib;
- hgdome;
- hmysql;
- registry;
- utf8_macros;
- xml;
- logger;
- }
+++ /dev/null
- /* apps */
- subgraph applications {
- node [shape=plaintext,style=filled,fillcolor=slategray2];
- DependencyAnalyzer [label="Dependency\nAnalyzer\n .3 klocs"];
- Getter [label="Getter\n .3 klocs"];
- Matita [label="Matita\n 6.7 klocs"];
- ProofChecker [label="Proof Checker\n .1 klocs"];
- Uwobo [label="Uwobo\n 2.1 klocs"];
- Whelp [label="Whelp\n .6 klocs"];
- }
- /* apps dep */
- DependencyAnalyzer -> metadata;
- Getter -> getter;
- Matita -> grafite_engine;
- Matita -> grafite_parser;
- Matita -> hgdome;
- ProofChecker -> cic_proof_checking;
- Uwobo -> content_pres;
- Whelp -> grafite_parser;
+++ /dev/null
---- .clustersdep.dot 2006-01-26 10:10:46.000000000 +0100
-+++ .clustersdep.new 2006-01-26 10:10:44.000000000 +0100
-@@ -1,11 +1,8 @@
- digraph G {
- xml [label="xml\n.5 klocs"];
-- xmldiff [label="xmldiff\n.3 klocs"];
- whelp [label="whelp\n.3 klocs"];
- utf8_macros [label="utf8_macros\n.2 klocs"];
- urimanager [label="urimanager\n.2 klocs"];
-- thread [label="thread\n.2 klocs"];
-- paramodulation [label="paramodulation\n5.9 klocs"];
- tactics [label="tactics\n10.0 klocs"];
- registry [label="registry\n.6 klocs"];
- metadata [label="metadata\n1.9 klocs"];
-@@ -42,7 +39,7 @@
- "cic_unification" -> "library";
- "library" -> "metadata";
- "library" -> "cic_acic";
--"metadata" -> "cic_proof_checking";
-+"metadata" -> "cic";
- "metadata" -> "hmysql";
- "grafite" -> "cic";
- "content_pres" -> "utf8_macros";
+++ /dev/null
-#!/bin/sh
-# script args: source_file target_file
-
-use_clusters='no'
-if [ ! -z "$USE_CLUSTERS" ]; then
- use_clusters=$USE_CLUSTERS
-fi
-
-# args: file snippet
-# file will be modified in place
-include_dot_snippet ()
-{
- echo "Adding to $1 graphviz snippet $2 ..."
- sed -i "/digraph/r $2" $1
-}
-
-# args: stats file
-# file will be modified in place
-include_loc_stats ()
-{
- echo "Adding to $1 KLOCs stats from $2 ..."
- tmp=`mktemp tmp.stats.XXXXXX`
- for l in `cat $2`; do
- module=$(basename $(echo $l | cut -d : -f 1))
- stat=$(echo $l | cut -d : -f 2)
- if [ "$stat" = "LOC" ]; then
- locs=$(echo $l | cut -d : -f 3)
- klocs=$(echo "scale=1; $locs / 1000" | bc)
- if [ "$klocs" = "0" ]; then klocs=".1"; fi
- printf ' %s [label="%s\\n%s klocs"];\n' $module $module $klocs >> $tmp
- fi
- done
- include_dot_snippet $1 $tmp
- rm $tmp
-}
-
-# args: file patch
-apply_patch ()
-{
- if [ -f "$2" ]; then
- echo "Applying to $1 patch $2 ..."
- patch $1 $2
- fi
-}
-
-cp $1 $2
-include_loc_stats $2 .stats
-apply_patch $2 STATS/deps.patch
-include_dot_snippet $2 STATS/daemons.dot
-if [ "$use_clusters" = "yes" ]; then
- include_dot_snippet $2 STATS/clusters.dot
-fi
-
+++ /dev/null
-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
+++ /dev/null
-PACKAGE = acic_content
-PREDICATES =
-
-INTERFACE_FILES = \
- content.mli \
- contentPp.mli \
- acic2content.mli \
- content2cic.mli \
- cicNotationUtil.mli \
- cicNotationEnv.mli \
- cicNotationPp.mli \
- acic2astMatcher.mli \
- termAcicContent.mli \
- $(NULL)
-IMPLEMENTATION_FILES = \
- cicNotationPt.ml \
- $(INTERFACE_FILES:%.mli=%.ml)
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(**************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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 context,term =
- (match
- build_subproofs_and_args
- seed ~ids_to_inner_types ~ids_to_inner_sorts [te]
- with
- l,[t] -> l,t
- | _ -> assert false) in
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [];
- K.proof_apply_context = serialize seed context;
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "Case";
- K.conclude_args =
- (K.Aux (UriManager.string_of_uri uri))::
- (K.Aux (string_of_int typeno))::(K.Term ty)::term::pp;
- K.conclude_conclusion =
- try Some
- (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found -> None
- }
- }
- | C.AFix (id, no, funs) ->
- let proofs =
- List.map
- (function (_,name,_,_,bo) -> `Proof (aux ~name bo)) funs in
- let fun_name =
- List.nth (List.map (fun (_,name,_,_,_) -> name) funs) no
- in
- let decreasing_args =
- List.map (function (_,_,n,_,_) -> n) funs in
- let jo =
- { K.joint_id = gen_id joint_prefix seed;
- K.joint_kind = `Recursive decreasing_args;
- K.joint_defs = proofs
- }
- in
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [`Joint jo];
- K.proof_apply_context = [];
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "Exact";
- K.conclude_args =
- [ K.Premise
- { K.premise_id = gen_id premise_prefix seed;
- K.premise_xref = jo.K.joint_id;
- K.premise_binder = Some fun_name;
- K.premise_n = Some no;
- }
- ];
- K.conclude_conclusion =
- try Some
- (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found -> None
- }
- }
- | C.ACoFix (id,no,funs) ->
- let proofs =
- List.map
- (function (_,name,_,bo) -> `Proof (aux ~name bo)) funs in
- let jo =
- { K.joint_id = gen_id joint_prefix seed;
- K.joint_kind = `CoRecursive;
- K.joint_defs = proofs
- }
- in
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [`Joint jo];
- K.proof_apply_context = [];
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "Exact";
- K.conclude_args =
- [ K.Premise
- { K.premise_id = gen_id premise_prefix seed;
- K.premise_xref = jo.K.joint_id;
- K.premise_binder = Some "tiralo fuori";
- K.premise_n = Some no;
- }
- ];
- K.conclude_conclusion =
- try Some
- (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found -> None
- };
- }
- in
- let id = get_id t in
- generate_conversion seed false id t1 ~ids_to_inner_types
-in aux ?name t
-
-and inductive seed name id li ~ids_to_inner_types ~ids_to_inner_sorts =
- let aux ?name = acic2content seed ~ids_to_inner_types ~ids_to_inner_sorts in
- let module C2A = Cic2acic in
- let module K = Content in
- let module C = Cic in
- match li with
- C.AConst (idc,uri,exp_named_subst)::args ->
- let uri_str = UriManager.string_of_uri uri in
- let suffix = Str.regexp_string "_ind.con" in
- let len = String.length uri_str in
- let n = (try (Str.search_backward suffix uri_str len)
- with Not_found -> -1) in
- if n<0 then raise NotApplicable
- else
- let method_name =
- if UriManager.eq uri HelmLibraryObjects.Logic.ex_ind_URI then "Exists"
- else if UriManager.eq uri HelmLibraryObjects.Logic.and_ind_URI then "AndInd"
- else if UriManager.eq uri HelmLibraryObjects.Logic.false_ind_URI then "FalseInd"
- else "ByInduction" in
- let prefix = String.sub uri_str 0 n in
- let ind_str = (prefix ^ ".ind") in
- let ind_uri = UriManager.uri_of_string ind_str in
- let inductive_types,noparams =
- (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph ind_uri in
- match o with
- | Cic.InductiveDefinition (l,_,n,_) -> (l,n)
- | _ -> assert false
- ) in
- let rec split n l =
- if n = 0 then ([],l) else
- let p,a = split (n-1) (List.tl l) in
- ((List.hd l::p),a) in
- let params_and_IP,tail_args = split (noparams+1) args in
- let constructors =
- (match inductive_types with
- [(_,_,_,l)] -> l
- | _ -> raise NotApplicable) (* don't care for mutual ind *) in
- let constructors1 =
- let rec clean_up n t =
- if n = 0 then t else
- (match t with
- (label,Cic.Prod (_,_,t)) -> clean_up (n-1) (label,t)
- | _ -> assert false) in
- List.map (clean_up noparams) constructors in
- let no_constructors= List.length constructors in
- let args_for_cases, other_args =
- split no_constructors tail_args in
- let subproofs,other_method_args =
- build_subproofs_and_args seed other_args
- ~ids_to_inner_types ~ids_to_inner_sorts in
- let method_args=
- let rec build_method_args =
- function
- [],_-> [] (* extra args are ignored ???? *)
- | (name,ty)::tlc,arg::tla ->
- let idarg = get_id arg in
- let sortarg =
- (try (Hashtbl.find ids_to_inner_sorts idarg)
- with Not_found -> `Type (CicUniv.fresh())) in
- let hdarg =
- if sortarg = `Prop then
- let (co,bo) =
- let rec bc =
- function
- Cic.Prod (_,s,t),Cic.ALambda(idl,n,s1,t1) ->
- let ce =
- build_decl_item
- seed idl n s1 ~ids_to_inner_sorts in
- if (occur ind_uri s) then
- ( match t1 with
- Cic.ALambda(id2,n2,s2,t2) ->
- let inductive_hyp =
- `Hypothesis
- { K.dec_name = name_of n2;
- K.dec_id =
- gen_id declaration_prefix seed;
- K.dec_inductive = true;
- K.dec_aref = id2;
- K.dec_type = s2
- } in
- let (context,body) = bc (t,t2) in
- (ce::inductive_hyp::context,body)
- | _ -> assert false)
- else
- (
- let (context,body) = bc (t,t1) in
- (ce::context,body))
- | _ , t -> ([],aux t) in
- bc (ty,arg) in
- K.ArgProof
- { bo with
- K.proof_name = Some name;
- K.proof_context = co;
- };
- else (K.Term arg) in
- hdarg::(build_method_args (tlc,tla))
- | _ -> assert false in
- build_method_args (constructors1,args_for_cases) in
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [];
- K.proof_apply_context = serialize seed subproofs;
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = method_name;
- K.conclude_args =
- K.Aux (string_of_int no_constructors)
- ::K.Term (C.AAppl(id,((C.AConst(idc,uri,exp_named_subst))::params_and_IP)))
- ::method_args@other_method_args;
- K.conclude_conclusion =
- try Some
- (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found -> None
- }
- }
- | _ -> raise NotApplicable
-
-and rewrite seed name id li ~ids_to_inner_types ~ids_to_inner_sorts =
- let aux ?name = acic2content seed ~ids_to_inner_types ~ids_to_inner_sorts in
- let module C2A = Cic2acic in
- let module K = Content in
- let module C = Cic in
- match li with
- C.AConst (sid,uri,exp_named_subst)::args ->
- if UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_URI or
- UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_r_URI or
- LibraryObjects.is_eq_ind_URI uri or
- LibraryObjects.is_eq_ind_r_URI uri then
- let subproofs,arg =
- (match
- build_subproofs_and_args
- seed ~ids_to_inner_types ~ids_to_inner_sorts [List.nth args 3]
- with
- l,[p] -> l,p
- | _,_ -> assert false) in
- let method_args =
- let rec ma_aux n = function
- [] -> []
- | a::tl ->
- let hd =
- if n = 0 then arg
- else
- let aid = get_id a in
- let asort = (try (Hashtbl.find ids_to_inner_sorts aid)
- with Not_found -> `Type (CicUniv.fresh())) in
- if asort = `Prop then
- K.ArgProof (aux a)
- else K.Term a in
- hd::(ma_aux (n-1) tl) in
- (ma_aux 3 args) in
- { K.proof_name = name;
- K.proof_id = gen_id proof_prefix seed;
- K.proof_context = [];
- K.proof_apply_context = serialize seed subproofs;
- K.proof_conclude =
- { K.conclude_id = gen_id conclude_prefix seed;
- K.conclude_aref = id;
- K.conclude_method = "Rewrite";
- K.conclude_args =
- K.Term (C.AConst (sid,uri,exp_named_subst))::method_args;
- K.conclude_conclusion =
- try Some
- (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
- with Not_found -> None
- }
- }
- else raise NotApplicable
- | _ -> raise NotApplicable
-;;
-
-let map_conjectures
- seed ~ids_to_inner_sorts ~ids_to_inner_types (id,n,context,ty)
-=
- let module K = Content in
- let context' =
- List.map
- (function
- (id,None) -> None
- | (id,Some (name,Cic.ADecl t)) ->
- Some
- (* We should call build_decl_item, but we have not computed *)
- (* the inner-types ==> we always produce a declaration *)
- (`Declaration
- { K.dec_name = name_of name;
- K.dec_id = gen_id declaration_prefix seed;
- K.dec_inductive = false;
- K.dec_aref = get_id t;
- K.dec_type = t
- })
- | (id,Some (name,Cic.ADef t)) ->
- Some
- (* We should call build_def_item, but we have not computed *)
- (* the inner-types ==> we always produce a declaration *)
- (`Definition
- { K.def_name = name_of name;
- K.def_id = gen_id definition_prefix seed;
- K.def_aref = get_id t;
- K.def_term = t
- })
- ) context
- in
- (id,n,context',ty)
-;;
-
-(* map_sequent is similar to map_conjectures, but the for the hid
-of the hypothesis, which are preserved instead of generating
-fresh ones. We shall have to adopt a uniform policy, soon or later *)
-
-let map_sequent ((id,n,context,ty):Cic.annconjecture) =
- let module K = Content in
- let context' =
- List.map
- (function
- (id,None) -> None
- | (id,Some (name,Cic.ADecl t)) ->
- Some
- (* We should call build_decl_item, but we have not computed *)
- (* the inner-types ==> we always produce a declaration *)
- (`Declaration
- { K.dec_name = name_of name;
- K.dec_id = id;
- K.dec_inductive = false;
- K.dec_aref = get_id t;
- K.dec_type = t
- })
- | (id,Some (name,Cic.ADef t)) ->
- Some
- (* We should call build_def_item, but we have not computed *)
- (* the inner-types ==> we always produce a declaration *)
- (`Definition
- { K.def_name = name_of name;
- K.def_id = id;
- K.def_aref = get_id t;
- K.def_term = t
- })
- ) context
- in
- (id,n,context',ty)
-;;
-
-let rec annobj2content ~ids_to_inner_sorts ~ids_to_inner_types =
- let module C = Cic in
- let module K = Content in
- let module C2A = Cic2acic in
- let seed = ref 0 in
- function
- C.ACurrentProof (_,_,n,conjectures,bo,ty,params,_) ->
- (gen_id object_prefix seed, params,
- Some
- (List.map
- (map_conjectures seed ~ids_to_inner_sorts ~ids_to_inner_types)
- conjectures),
- `Def (K.Const,ty,
- build_def_item seed (get_id bo) (C.Name n) bo
- ~ids_to_inner_sorts ~ids_to_inner_types))
- | C.AConstant (_,_,n,Some bo,ty,params,_) ->
- (gen_id object_prefix seed, params, None,
- `Def (K.Const,ty,
- build_def_item seed (get_id bo) (C.Name n) bo
- ~ids_to_inner_sorts ~ids_to_inner_types))
- | C.AConstant (id,_,n,None,ty,params,_) ->
- (gen_id object_prefix seed, params, None,
- `Decl (K.Const,
- build_decl_item seed id (C.Name n) ty
- ~ids_to_inner_sorts))
- | C.AVariable (_,n,Some bo,ty,params,_) ->
- (gen_id object_prefix seed, params, None,
- `Def (K.Var,ty,
- build_def_item seed (get_id bo) (C.Name n) bo
- ~ids_to_inner_sorts ~ids_to_inner_types))
- | C.AVariable (id,n,None,ty,params,_) ->
- (gen_id object_prefix seed, params, None,
- `Decl (K.Var,
- build_decl_item seed id (C.Name n) ty
- ~ids_to_inner_sorts))
- | C.AInductiveDefinition (id,l,params,nparams,_) ->
- (gen_id object_prefix seed, params, None,
- `Joint
- { K.joint_id = gen_id joint_prefix seed;
- K.joint_kind = `Inductive nparams;
- K.joint_defs = List.map (build_inductive seed) l
- })
-
-and
- build_inductive seed =
- let module K = Content in
- fun (_,n,b,ty,l) ->
- `Inductive
- { K.inductive_id = gen_id inductive_prefix seed;
- K.inductive_name = n;
- K.inductive_kind = b;
- K.inductive_type = ty;
- K.inductive_constructors = build_constructors seed l
- }
-
-and
- build_constructors seed l =
- let module K = Content in
- List.map
- (fun (n,t) ->
- { K.dec_name = Some n;
- K.dec_id = gen_id declaration_prefix seed;
- K.dec_inductive = false;
- K.dec_aref = "";
- K.dec_type = t
- }) l
-;;
-
-(*
-and 'term cinductiveType =
- id * string * bool * 'term * (* typename, inductive, arity *)
- 'term cconstructor list (* constructors *)
-
-and 'term cconstructor =
- string * 'term
-*)
-
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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))
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(**************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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 *)
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-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 *)
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(**************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti <asperti@cs.unibo.it> *)
-(* 27/6/2003 *)
-(* *)
-(**************************************************************************)
-
-val cobj2obj : Cic.annterm Content.cobj -> Cic.obj
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* 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
-;;
-
-
-
-
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val print_proof: Cic.annterm Content.proof -> unit
-
-val print_obj: Cic.annterm Content.cobj -> unit
-
-val parg: int -> Cic.annterm Content.arg ->unit
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-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
+++ /dev/null
-PACKAGE = cic
-PREDICATES =
-
-INTERFACE_FILES = \
- unshare.mli \
- cicUniv.mli \
- deannotate.mli \
- cicParser.mli \
- cicUtil.mli \
- helmLibraryObjects.mli \
- libraryObjects.mli \
- discrimination_tree.mli \
- path_indexing.mli
-IMPLEMENTATION_FILES = \
- cic.ml $(INTERFACE_FILES:%.mli=%.ml)
-EXTRA_OBJECTS_TO_INSTALL = cic.ml cic.cmi
-EXTRA_OBJECTS_TO_CLEAN =
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*****************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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)
-;;
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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,obj_attributes)
- | _ ->
- raise (Parser_failure (sprintf "no constant found in %s, %s"
- filename filenamebody)))
-
-let obj_of_xml uri filename filenamebody =
- Deannotate.deannotate_obj (annobj_of_xml uri filename filenamebody)
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*****************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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
-
-(*****************************************************************************)
-(** Benchmarking **)
-(*****************************************************************************)
-let time_spent = ref 0.0;;
-let partial = ref 0.0 ;;
-
-let reset_spent_time () = time_spent := 0.0;;
-let get_spent_time () = !time_spent ;;
-let begin_spending () =
- (*assert (!partial = 0.0);*)
- partial := Unix.gettimeofday ()
-;;
-
-let end_spending () =
- assert (!partial > 0.0);
- let interval = (Unix.gettimeofday ()) -. !partial in
- partial := 0.0;
- time_spent := !time_spent +. interval
-;;
-
-
-(*****************************************************************************)
-(** Helpers **)
-(*****************************************************************************)
-
-(* find the repr *)
-let repr u m =
- try
- MAL.find u m
- with
- Not_found -> empty_entry
-
-(* FIXME: May be faster if we make it by hand *)
-let merge_closures f nodes m =
- SOF.fold (fun x i -> SOF.union (f (repr x m)) i ) nodes SOF.empty
-
-\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, already_contained) l uri =
- let fill_empty_universe u =
- match u with
- (i,None) -> (i,Some uri)
- | (i,Some _) as u -> u
- in
- let fill_empty_set s =
- SOF.fold (fun e s -> SOF.add (fill_empty_universe e) s) s SOF.empty
- in
- let fill_empty_entry e = {
- eq_closure = (fill_empty_set e.eq_closure) ;
- ge_closure = (fill_empty_set e.ge_closure) ;
- gt_closure = (fill_empty_set e.gt_closure) ;
- in_gegt_of = (fill_empty_set e.in_gegt_of) ;
- one_s_eq = (fill_empty_set e.one_s_eq) ;
- one_s_ge = (fill_empty_set e.one_s_ge) ;
- one_s_gt = (fill_empty_set e.one_s_gt) ;
- } in
- let m = g in
- let m' = MAL.fold (
- fun k v m ->
- MAL.add (fill_empty_universe k) (fill_empty_entry v) m) m MAL.empty
- in
- let l' = List.map fill_empty_universe l in
- (m', already_contained),l'
-
-
-(*****************************************************************************)
-(** World interface **)
-(*****************************************************************************)
-
-type universe_graph = bag * UriManager.UriSet.t
-(* the graph , the cache of already merged ugraphs *)
-
-let empty_ugraph = empty_bag, UriManager.UriSet.empty
-
-let current_index_anon = ref (-1)
-let current_index_named = ref (-1)
-
-let restart_numbering () = current_index_named := (-1)
-
-let fresh ?uri ?id () =
- let i =
- match uri,id with
- | None,None ->
- current_index_anon := !current_index_anon + 1;
- !current_index_anon
- | None, Some _ -> assert false
- | Some _, None ->
- current_index_named := !current_index_named + 1;
- !current_index_named
- | Some _, Some id -> id
- in
- (i,uri)
-
-let name_universe u uri =
- match u with
- | (i, None) -> (i, Some uri)
- | _ -> u
-
-let print_ugraph (g, _) =
- prerr_endline (string_of_bag g)
-
-let add_eq ?(fast=(!fast_implementation)) u v b =
- (* should we check to no add twice the same?? *)
- let m = b in
- let ru = repr u m in
- if SOF.mem v ru.gt_closure then
- error ("EQ",u,v) v "GT" u ru.gt_closure
- else
- begin
- let rv = repr v m in
- if SOF.mem u rv.gt_closure then
- error ("EQ",u,v) u "GT" v rv.gt_closure
- else
- add_eq fast u v b
- end
-
-let add_ge ?(fast=(!fast_implementation)) u v b =
- (* should we check to no add twice the same?? *)
- let m = b in
- let rv = repr v m in
- if SOF.mem u rv.gt_closure then
- error ("GE",u,v) u "GT" v rv.gt_closure
- else
- add_ge fast u v b
-
-let add_gt ?(fast=(!fast_implementation)) u v b =
- (* should we check to no add twice the same?? *)
- (*
- FIXME : check the thesis... no need to check GT and EQ closure since the
- GE is a superset of both
- *)
- let m = b in
- let rv = repr v m in
-
- if u = v then
- error ("GT",u,v) u "==" v SOF.empty
- else
-
- (*if SOF.mem u rv.gt_closure then
- error ("GT",u,v) u "GT" v rv.gt_closure
- else
- begin*)
- if SOF.mem u rv.ge_closure then
- error ("GT",u,v) u "GE" v rv.ge_closure
- else
-(* begin
- if SOF.mem u rv.eq_closure then
- error ("GT",u,v) u "EQ" v rv.eq_closure
- else*)
- add_gt fast u v b
-(* end
- end*)
-
-(*****************************************************************************)
-(** START: Decomment this for performance comparisons **)
-(*****************************************************************************)
-
-let add_eq ?(fast=(!fast_implementation)) u v (b,already_contained) =
- (*prerr_endline "add_eq";*)
- begin_spending ();
- let rc = add_eq ~fast u v b in
- end_spending ();
- rc,already_contained
-
-let add_ge ?(fast=(!fast_implementation)) u v (b,already_contained) =
-(* prerr_endline "add_ge"; *)
- begin_spending ();
- let rc = add_ge ~fast u v b in
- end_spending ();
- rc,already_contained
-
-let add_gt ?(fast=(!fast_implementation)) u v (b,already_contained) =
-(* prerr_endline "add_gt"; *)
- begin_spending ();
- let rc = add_gt ~fast u v b in
- end_spending ();
- rc,already_contained
-
-let profiler_eq = HExtlib.profile "CicUniv.add_eq"
-let profiler_ge = HExtlib.profile "CicUniv.add_ge"
-let profiler_gt = HExtlib.profile "CicUniv.add_gt"
-let add_gt ?fast u v b =
- profiler_gt.HExtlib.profile (fun _ -> add_gt ?fast u v b) ()
-let add_ge ?fast u v b =
- profiler_ge.HExtlib.profile (fun _ -> add_ge ?fast u v b) ()
-let add_eq ?fast u v b =
- profiler_eq.HExtlib.profile (fun _ -> add_eq ?fast u v b) ()
-
-(*****************************************************************************)
-(** END: Decomment this for performance comparisons **)
-(*****************************************************************************)
-
-let merge_ugraphs ~base_ugraph ~increment:(increment, uri_of_increment) =
- let merge_brutal (u,_) v =
- let m1 = u in
- let m2 = v in
- MAL.fold (
- fun k v x ->
- (SOF.fold (
- fun u x ->
- let m = add_gt k u x in m)
- (SOF.union v.one_s_gt v.gt_closure)
- (SOF.fold (
- fun u x ->
- let m = add_ge k u x in m)
- (SOF.union v.one_s_ge v.ge_closure)
- (SOF.fold (
- fun u x ->
- let m = add_eq k u x in m)
- (SOF.union v.one_s_eq v.eq_closure) x)))
- ) m1 m2
- in
- let base, already_contained = base_ugraph in
- if MAL.is_empty base then
- increment
- else if
- MAL.is_empty (fst increment) ||
- UriManager.UriSet.mem uri_of_increment already_contained
- then
- base_ugraph
- else
- fst (merge_brutal increment base_ugraph),
- UriManager.UriSet.add uri_of_increment already_contained
-
-let profiler_merge = HExtlib.profile "CicUniv.merge_graphs"
-let merge_ugraphs ~base_ugraph ~increment =
- profiler_merge.HExtlib.profile
- (fun _ -> merge_ugraphs ~base_ugraph ~increment) ()
-
-(*****************************************************************************)
-(** Xml sesialization and parsing **)
-(*****************************************************************************)
-
-let xml_of_universe name u =
- match u with
- | (i,Some u) ->
- Xml.xml_empty name [
- None,"id",(string_of_int i) ;
- None,"uri",(UriManager.string_of_uri u)]
- | (_,None) ->
- raise (Failure "we can serialize only universes with uri")
-
-let xml_of_set s =
- let l =
- List.map (xml_of_universe "node") (SOF.elements s)
- in
- List.fold_left (fun s x -> [< s ; x >] ) [<>] l
-
-let xml_of_entry_content e =
- let stream_of_field f name =
- let eq_c = xml_of_set f in
- if eq_c != [<>] then
- Xml.xml_nempty name [] eq_c
- else
- [<>]
- in
- [<
- (stream_of_field e.eq_closure "eq_closure");
- (stream_of_field e.gt_closure "gt_closure");
- (stream_of_field e.ge_closure "ge_closure");
- (stream_of_field e.in_gegt_of "in_gegt_of");
- (stream_of_field e.one_s_eq "one_s_eq");
- (stream_of_field e.one_s_gt "one_s_gt");
- (stream_of_field e.one_s_ge "one_s_ge")
- >]
-
-let xml_of_entry u e =
- let (i,u') = u in
- let u'' =
- match u' with
- Some x -> x
- | None ->
- raise (Failure "we can serialize only universes (entry) with uri")
- in
- let ent = Xml.xml_nempty "entry" [
- None,"id",(string_of_int i) ;
- None,"uri",(UriManager.string_of_uri u'')] in
- let content = xml_of_entry_content e in
- ent content
-
-let write_xml_of_ugraph filename (m,_) l =
- let tokens =
- [<
- Xml.xml_cdata "<?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,already_contained) f =
- let m' =
- MAL.fold (fun k v x -> if (f k) then MAL.add k v x else x ) m MAL.empty in
- let m'' = MAL.fold (fun k v x ->
- let v' = {
- eq_closure = SOF.filter f v.eq_closure;
- ge_closure = SOF.filter f v.ge_closure;
- gt_closure = SOF.filter f v.gt_closure;
- in_gegt_of = SOF.filter f v.in_gegt_of;
- one_s_eq = SOF.filter f v.one_s_eq;
- one_s_ge = SOF.filter f v.one_s_ge;
- one_s_gt = SOF.filter f v.one_s_gt
- } in
- MAL.add k v' x ) m' MAL.empty in
- let e_l =
- MAL.fold (fun k v l -> if v = empty_entry && not(f k) then
- begin
- k::l end else l) m'' []
- in
- if e_l != [] then
- clean_ugraph
- (m'', already_contained) (fun u -> (f u) && not (List.mem u e_l))
- else
- MAL.fold
- (fun k v x -> if v <> empty_entry then MAL.add k v x else x)
- m'' MAL.empty,
- already_contained
-
-let clean_ugraph g l =
- clean_ugraph g (fun u -> List.mem u l)
-
-let assigner_of =
- function
- "ge_closure" -> (fun e u->{e with ge_closure=SOF.add u e.ge_closure})
- | "gt_closure" -> (fun e u->{e with gt_closure=SOF.add u e.gt_closure})
- | "eq_closure" -> (fun e u->{e with eq_closure=SOF.add u e.eq_closure})
- | "in_gegt_of" -> (fun e u->{e with in_gegt_of =SOF.add u e.in_gegt_of})
- | "one_s_ge" -> (fun e u->{e with one_s_ge =SOF.add u e.one_s_ge})
- | "one_s_gt" -> (fun e u->{e with one_s_gt =SOF.add u e.one_s_gt})
- | "one_s_eq" -> (fun e u->{e with one_s_eq =SOF.add u e.one_s_eq})
- | s -> raise (Failure ("unsupported tag " ^ s))
-;;
-
-let cb_factory m l =
- let module XPP = XmlPushParser in
- let current_node = ref (0,None) in
- let current_entry = ref empty_entry in
- let current_assign = ref (assigner_of "in_gegt_of") in
- { XPP.default_callbacks with
- XPP.end_element = Some( fun name ->
- match name with
- | "entry" ->
- m := MAL.add !current_node !current_entry !m;
- current_entry := empty_entry
- | _ -> ()
- );
- XPP.start_element = Some( fun name attlist ->
- match name with
- | "ugraph" -> ()
- | "entry" ->
- let id = List.assoc "id" attlist in
- let uri = List.assoc "uri" attlist in
- current_node := (int_of_string id,Some (UriManager.uri_of_string uri))
- | "node" ->
- let id = int_of_string (List.assoc "id" attlist) in
- let uri = List.assoc "uri" attlist in
- current_entry := !current_assign !current_entry
- (id,Some (UriManager.uri_of_string uri))
- | "owned_node" ->
- let id = int_of_string (List.assoc "id" attlist) in
- let uri = List.assoc "uri" attlist in
- l := (id,Some (UriManager.uri_of_string uri)) :: !l
- | s -> current_assign := assigner_of s
- )
- }
-;;
-
-let ugraph_and_univlist_of_xml filename =
- let module XPP = XmlPushParser in
- let result_map = ref MAL.empty in
- let result_list = ref [] in
- let cb = cb_factory result_map result_list in
- let xml_parser = XPP.create_parser cb in
- let xml_source = `Gzip_file filename in
- (try XPP.parse xml_parser xml_source
- with (XPP.Parse_error err) as exn -> raise exn);
- (!result_map,UriManager.UriSet.empty), !result_list
-
-\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,uriset) =
- MAL.fold
- (fun universe entry map ->
- MAL.add (recons_univ universe) (recons_entry entry) map)
- graph
- MAL.empty,
- UriManager.UriSet.fold
- (fun u acc ->
- UriManager.UriSet.add
- (UriManager.uri_of_string (UriManager.string_of_uri u)) acc)
- uriset UriManager.UriSet.empty
-
-let assert_univ u =
- match u with
- | (_,None) -> raise (UniverseInconsistency "This universe graph has a hole")
- | _ -> ()
-
-let assert_univs_have_uri (graph,_) univlist =
- let assert_set s =
- SOF.iter (fun u -> assert_univ u) s
- in
- let assert_entry e =
- assert_set e.eq_closure;
- assert_set e.ge_closure;
- assert_set e.gt_closure;
- assert_set e.in_gegt_of;
- assert_set e.one_s_eq;
- assert_set e.one_s_ge;
- assert_set e.one_s_gt;
- in
- MAL.iter (fun k v -> assert_univ k; assert_entry v)graph;
- List.iter assert_univ univlist
-
-let eq u1 u2 =
- match u1,u2 with
- | (id1, Some uri1),(id2, Some uri2) ->
- id1 = id2 && UriManager.eq uri1 uri2
- | (id1, None),(id2, None) -> id1 = id2
- | _ -> false
-
-let compare (id1, uri1) (id2, uri2) =
- let cmp = id1 - id2 in
- if cmp = 0 then
- match uri1,uri2 with
- | None, None -> 0
- | Some _, None -> 1
- | None, Some _ -> ~-1
- | Some uri1, Some uri2 -> UriManager.compare uri1 uri2
- else
- cmp
-
-(* EOF *)
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-
-(*
- The strings contains an unreadable message
-*)
-exception UniverseInconsistency of string
-
-(*
- Cic.Type of universe
-*)
-type universe
-
-(*
- Opaque data structure you will use to store constraints
-*)
-type universe_graph
-
-(*
- returns a fresh universe
-*)
-val fresh:
- ?uri:UriManager.uri ->
- ?id:int ->
- unit ->
- universe
-
- (* names a universe if unnamed *)
-val name_universe: universe -> UriManager.uri -> universe
-
-(*
- really useful at the begin and in all the functions that don't care
- of universes
-*)
-val empty_ugraph: universe_graph
-
-(*
- These are the real functions to add eq/ge/gt constraints
- to the passed graph, returning an updated graph or raising
- UniverseInconsistency
-*)
-val add_eq:
- ?fast:bool -> universe -> universe -> universe_graph -> universe_graph
-val add_ge:
- ?fast:bool -> universe -> universe -> universe_graph -> universe_graph
-val add_gt:
- ?fast:bool -> universe -> universe -> universe_graph -> universe_graph
-
-(*
- debug function to print the graph to standard error
-*)
-val print_ugraph:
- universe_graph -> unit
-
-(*
- does what expected, but I don't remember why this was exported
-*)
-val string_of_universe:
- universe -> string
-
-(*
- given the list of visible universes (see universes_of_obj) returns a
- cleaned graph (cleaned from the not visible nodes)
-*)
-val clean_ugraph:
- universe_graph -> universe list -> universe_graph
-
-(*
- Since fresh() can't add the right uri to each node, you
- must fill empty nodes with the uri before you serialize the graph to xml
-
- these empty nodes are also filled in the universe list
-*)
-val fill_empty_nodes_with_uri:
- universe_graph -> universe list -> UriManager.uri ->
- universe_graph * universe list
-
-(*
- makes a union.
- TODO:
- - remember already merged uri so that we completely skip already merged
- graphs, this may include a dependecy graph (not merge a subpart of an
- already merged graph)
-*)
-val merge_ugraphs:
- base_ugraph:universe_graph ->
- increment:(universe_graph * UriManager.uri) -> universe_graph
-
-(*
- ugraph to xml file and viceversa
-*)
-val write_xml_of_ugraph:
- string -> universe_graph -> universe list -> unit
-
-(*
- given a filename parses the xml and returns the data structure
-*)
-val ugraph_and_univlist_of_xml:
- string -> universe_graph * universe list
-val restart_numbering:
- unit -> unit
-
-(*
- returns the universe number (used to save it do xml)
-*)
-val univno: universe -> int
-
- (** re-hash-cons URIs contained in the given universe so that phisicaly
- * equality could be enforced. Mainly used by
- * CicEnvironment.restore_from_channel *)
-val recons_graph: universe_graph -> universe_graph
-
- (** re-hash-cons a single universe *)
-val recons_univ: universe -> universe
-
- (** consistency chek that should be done before committin the graph to the
- * cache *)
-val assert_univs_have_uri: universe_graph -> universe list-> unit
-
- (** asserts the universe is named *)
-val assert_univ: universe -> unit
-
-val compare: universe -> universe -> int
-val eq: universe -> universe -> bool
-
-(*
- Benchmarking stuff
-*)
-val get_spent_time: unit -> float
-val reset_spent_time: unit -> unit
-
+++ /dev/null
-(* 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)
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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)
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 29/11/2000 *)
-(* *)
-(******************************************************************************)
-
-val deannotate_term : Cic.annterm -> Cic.term
-val deannotate_obj : Cic.annobj -> Cic.obj
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-module DiscriminationTreeIndexing =
- functor (A:Set.S) ->
- struct
-
- type path_string_elem = Cic.term;;
- type path_string = path_string_elem list;;
-
-
- (* needed by the retrieve_* functions, to know the arities of the "functions" *)
-
- let arities = Hashtbl.create 11;;
-
-
- let rec path_string_of_term = function
- | Cic.Meta _ -> [Cic.Implicit None]
- | Cic.Appl ((hd::tl) as l) ->
- if not (Hashtbl.mem arities hd) then
- Hashtbl.add arities hd (List.length tl);
- List.concat (List.map path_string_of_term l)
- | term -> [term]
- ;;
-
-
- module OrderedPathStringElement = struct
- type t = path_string_elem
-
- let compare = Pervasives.compare
- end
-
- module PSMap = Map.Make(OrderedPathStringElement);;
-
- type key = PSMap.key
-
- module DiscriminationTree = Trie.Make(PSMap);;
-
- type t = A.t DiscriminationTree.t
- let empty = DiscriminationTree.empty
-
-(*
- module OrderedPosEquality = struct
- type t = Utils.pos * Inference.equality
- let compare = Pervasives.compare
- end
-
- module PosEqSet = Set.Make(OrderedPosEquality);;
-
- let string_of_discrimination_tree tree =
- let rec to_string level = function
- | DiscriminationTree.Node (value, map) ->
- let s =
- match value with
- | Some v ->
- (String.make (2 * level) ' ') ^
- "{" ^ (String.concat "; "
- (List.map
- (fun (p, e) ->
- "(" ^ (Utils.string_of_pos p) ^ ", " ^
- (Inference.string_of_equality e) ^ ")")
- (PosEqSet.elements v))) ^ "}"
- | None -> ""
- in
- let rest =
- String.concat "\n"
- (PSMap.fold
- (fun k v s ->
- let ks = CicPp.ppterm k in
- let rs = to_string (level+1) v in
- ((String.make (2 * level) ' ') ^ ks ^ "\n" ^ rs)::s)
- map [])
- in
- s ^ rest
- in
- to_string 0 tree
- ;;
-*)
-
- let index tree term info =
- let ps = path_string_of_term term in
- let ps_set =
- try DiscriminationTree.find ps tree
- with Not_found -> A.empty in
- let tree =
- DiscriminationTree.add ps (A.add info ps_set) tree in
- tree
-
-(*
- let index tree equality =
- let _, _, (_, l, r, ordering), _, _ = equality in
- let psl = path_string_of_term l
- and psr = path_string_of_term r in
- let index pos tree ps =
- let ps_set =
- try DiscriminationTree.find ps tree with Not_found -> PosEqSet.empty in
- let tree =
- DiscriminationTree.add ps (PosEqSet.add (pos, equality) ps_set) tree in
- tree
- in
- match ordering with
- | Utils.Gt -> index Utils.Left tree psl
- | Utils.Lt -> index Utils.Right tree psr
- | _ ->
- let tree = index Utils.Left tree psl in
- index Utils.Right tree psr
- ;;
-*)
-
- let remove_index tree term info =
- let ps = path_string_of_term term in
- try
- let ps_set =
- A.remove info (DiscriminationTree.find ps tree) in
- if A.is_empty ps_set then
- DiscriminationTree.remove ps tree
- else
- DiscriminationTree.add ps ps_set tree
- with Not_found ->
- tree
-
-(*
-let remove_index tree equality =
- let _, _, (_, l, r, ordering), _, _ = equality in
- let psl = path_string_of_term l
- and psr = path_string_of_term r in
- let remove_index pos tree ps =
- try
- let ps_set =
- PosEqSet.remove (pos, equality) (DiscriminationTree.find ps tree) in
- if PosEqSet.is_empty ps_set then
- DiscriminationTree.remove ps tree
- else
- DiscriminationTree.add ps ps_set tree
- with Not_found ->
- tree
- in
- match ordering with
- | Utils.Gt -> remove_index Utils.Left tree psl
- | Utils.Lt -> remove_index Utils.Right tree psr
- | _ ->
- let tree = remove_index Utils.Left tree psl in
- remove_index Utils.Right tree psr
-;;
-*)
-
-
- let in_index tree term test =
- let ps = path_string_of_term term in
- try
- let ps_set = DiscriminationTree.find ps tree in
- A.exists test ps_set
- with Not_found ->
- false
-
-(*
- let in_index tree equality =
- let _, _, (_, l, r, ordering), _, _ = equality in
- let psl = path_string_of_term l
- and psr = path_string_of_term r in
- let meta_convertibility = Inference.meta_convertibility_eq equality in
- let ok ps =
- try
- let set = DiscriminationTree.find ps tree in
- PosEqSet.exists (fun (p, e) -> meta_convertibility e) set
- with Not_found ->
- false
- in
- (ok psl) || (ok psr)
-;;
-*)
-
-
- let head_of_term = function
- | Cic.Appl (hd::tl) -> hd
- | term -> term
- ;;
-
-
- let rec subterm_at_pos pos term =
- match pos with
- | [] -> term
- | index::pos ->
- match term with
- | Cic.Appl l ->
- (try subterm_at_pos pos (List.nth l index)
- with Failure _ -> raise Not_found)
- | _ -> raise Not_found
- ;;
-
-
- let rec after_t pos term =
- let pos' =
- match pos with
- | [] -> raise Not_found
- | pos -> List.fold_right (fun i r -> if r = [] then [i+1] else i::r) pos []
- in
- try
- ignore(subterm_at_pos pos' term ); pos'
- with Not_found ->
- let pos, _ =
- List.fold_right
- (fun i (r, b) -> if b then (i::r, true) else (r, true)) pos ([], false)
- in
- after_t pos term
- ;;
-
-
- let next_t pos term =
- let t = subterm_at_pos pos term in
- try
- let _ = subterm_at_pos [1] t in
- pos @ [1]
- with Not_found ->
- match pos with
- | [] -> [1]
- | pos -> after_t pos term
- ;;
-
-
- let retrieve_generalizations tree term =
- let rec retrieve tree term pos =
- match tree with
- | DiscriminationTree.Node (Some s, _) when pos = [] -> s
- | DiscriminationTree.Node (_, map) ->
- let res =
- try
- let hd_term = head_of_term (subterm_at_pos pos term) in
- let n = PSMap.find hd_term map in
- match n with
- | DiscriminationTree.Node (Some s, _) -> s
- | DiscriminationTree.Node (None, _) ->
- let newpos = try next_t pos term with Not_found -> [] in
- retrieve n term newpos
- with Not_found ->
- A.empty
- in
- try
- let n = PSMap.find (Cic.Implicit None) map in
- let newpos = try after_t pos term with Not_found -> [-1] in
- if newpos = [-1] then
- match n with
- | DiscriminationTree.Node (Some s, _) -> A.union s res
- | _ -> res
- else
- A.union res (retrieve n term newpos)
- with Not_found ->
- res
- in
- retrieve tree term []
- ;;
-
-
- let jump_list = function
- | DiscriminationTree.Node (value, map) ->
- let rec get n tree =
- match tree with
- | DiscriminationTree.Node (v, m) ->
- if n = 0 then
- [tree]
- else
- PSMap.fold
- (fun k v res ->
- let a = try Hashtbl.find arities k with Not_found -> 0 in
- (get (n-1 + a) v) @ res) m []
- in
- PSMap.fold
- (fun k v res ->
- let arity = try Hashtbl.find arities k with Not_found -> 0 in
- (get arity v) @ res)
- map []
- ;;
-
-
- let retrieve_unifiables tree term =
- let rec retrieve tree term pos =
- match tree with
- | DiscriminationTree.Node (Some s, _) when pos = [] -> s
- | DiscriminationTree.Node (_, map) ->
- let subterm =
- try Some (subterm_at_pos pos term) with Not_found -> None
- in
- match subterm with
- | None -> A.empty
- | Some (Cic.Meta _) ->
- let newpos = try next_t pos term with Not_found -> [] in
- let jl = jump_list tree in
- List.fold_left
- (fun r s -> A.union r s)
- A.empty
- (List.map (fun t -> retrieve t term newpos) jl)
- | Some subterm ->
- let res =
- try
- let hd_term = head_of_term subterm in
- let n = PSMap.find hd_term map in
- match n with
- | DiscriminationTree.Node (Some s, _) -> s
- | DiscriminationTree.Node (None, _) ->
- retrieve n term (next_t pos term)
- with Not_found ->
- A.empty
- in
- try
- let n = PSMap.find (Cic.Implicit None) map in
- let newpos = try after_t pos term with Not_found -> [-1] in
- if newpos = [-1] then
- match n with
- | DiscriminationTree.Node (Some s, _) -> A.union s res
- | _ -> res
- else
- A.union res (retrieve n term newpos)
- with Not_found ->
- res
- in
- retrieve tree term []
- end
-;;
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-(**** TABLES ****)
-
-let default_eq_URIs =
- [HelmLibraryObjects.Logic.eq_URI,
- HelmLibraryObjects.Logic.sym_eq_URI,
- HelmLibraryObjects.Logic.trans_eq_URI,
- HelmLibraryObjects.Logic.eq_ind_URI,
- HelmLibraryObjects.Logic.eq_ind_r_URI];;
-
-let default_true_URIs = [HelmLibraryObjects.Logic.true_URI]
-let default_false_URIs = [HelmLibraryObjects.Logic.false_URI]
-let default_absurd_URIs = [HelmLibraryObjects.Logic.absurd_URI]
-
-(* eq, sym_eq, trans_eq, eq_ind, eq_ind_R *)
-let eq_URIs_ref =
- ref [HelmLibraryObjects.Logic.eq_URI,
- HelmLibraryObjects.Logic.sym_eq_URI,
- HelmLibraryObjects.Logic.trans_eq_URI,
- HelmLibraryObjects.Logic.eq_ind_URI,
- HelmLibraryObjects.Logic.eq_ind_r_URI];;
-
-let true_URIs_ref = ref [HelmLibraryObjects.Logic.true_URI]
-let false_URIs_ref = ref [HelmLibraryObjects.Logic.false_URI]
-let absurd_URIs_ref = ref [HelmLibraryObjects.Logic.absurd_URI]
-
-
-(**** SET_DEFAULT ****)
-
-exception NotRecognized;;
-
-(* insert an element in front of the list, removing from the list all the
- previous elements with the same key associated *)
-let insert_unique e extract l =
- let uri = extract e in
- let l' =
- List.filter (fun x -> let uri' = extract x in not (UriManager.eq uri uri')) l
- in
- e :: l'
-
-let set_default what l =
- match what,l with
- "equality",[eq_URI;sym_eq_URI;trans_eq_URI;eq_ind_URI;eq_ind_r_URI] ->
- eq_URIs_ref :=
- insert_unique (eq_URI,sym_eq_URI,trans_eq_URI,eq_ind_URI,eq_ind_r_URI)
- (fun x,_,_,_,_ -> x) !eq_URIs_ref
- | "true",[true_URI] ->
- true_URIs_ref := insert_unique true_URI (fun x -> x) !true_URIs_ref
- | "false",[false_URI] ->
- false_URIs_ref := insert_unique false_URI (fun x -> x) !false_URIs_ref
- | "absurd",[absurd_URI] ->
- absurd_URIs_ref := insert_unique absurd_URI (fun x -> x) !absurd_URIs_ref
- | _,_ -> raise NotRecognized
-
-let reset_defaults () =
- eq_URIs_ref := default_eq_URIs;
- true_URIs_ref := default_true_URIs;
- false_URIs_ref := default_false_URIs;
- absurd_URIs_ref := default_absurd_URIs
-
-(**** LOOKUP FUNCTIONS ****)
-
-let eq_URI () = let eq,_,_,_,_ = List.hd !eq_URIs_ref in eq
-
-let is_eq_URI uri =
- List.exists (fun (eq,_,_,_,_) -> UriManager.eq eq uri) !eq_URIs_ref
-
-let is_eq_ind_URI uri =
- List.exists (fun (_,_,_,eq_ind,_) -> UriManager.eq eq_ind uri) !eq_URIs_ref
-
-let is_eq_ind_r_URI uri =
- List.exists (fun (_,_,_,_,eq_ind_r) -> UriManager.eq eq_ind_r uri) !eq_URIs_ref
-
-let sym_eq_URI ~eq:uri =
- try
- let _,x,_,_,_ = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x
- with Not_found -> raise NotRecognized
-
-let trans_eq_URI ~eq:uri =
- try
- let _,_,x,_,_ = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x
- with Not_found -> raise NotRecognized
-
-let eq_ind_URI ~eq:uri =
- try
- let _,_,_,x,_ = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x
- with Not_found -> raise NotRecognized
-
-let eq_ind_r_URI ~eq:uri =
- try
- let _,_,_,_,x = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x
- with Not_found -> raise NotRecognized
-
-let true_URI () = List.hd !true_URIs_ref
-let false_URI () = List.hd !false_URIs_ref
-let absurd_URI () = List.hd !absurd_URIs_ref
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-val set_default : string -> UriManager.uri list -> unit
-val reset_defaults : unit -> unit
-
-val eq_URI : unit -> UriManager.uri
-
-val is_eq_URI : UriManager.uri -> bool
-val is_eq_ind_URI : UriManager.uri -> bool
-val is_eq_ind_r_URI : UriManager.uri -> bool
-
-exception NotRecognized;;
-
-val eq_ind_URI : eq:UriManager.uri -> UriManager.uri
-val eq_ind_r_URI : eq:UriManager.uri -> UriManager.uri
-val trans_eq_URI : eq:UriManager.uri -> UriManager.uri
-val sym_eq_URI : eq:UriManager.uri -> UriManager.uri
-
-
-val false_URI : unit -> UriManager.uri
-val true_URI : unit -> UriManager.uri
-val absurd_URI : unit -> UriManager.uri
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 -> ()
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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)
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val unshare : Cic.term -> Cic.term
+++ /dev/null
-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
+++ /dev/null
-PACKAGE = cic_acic
-PREDICATES =
-
-INTERFACE_FILES = \
- eta_fixing.mli \
- doubleTypeInference.mli \
- cic2acic.mli \
- cic2Xml.mli \
- $(NULL)
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* 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 [<>]
- )
- >]
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception 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
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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)
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception 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
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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
-;;
+++ /dev/null
-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
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val eta_fix : Cic.metasenv -> Cic.context -> Cic.term -> Cic.term
-
-
+++ /dev/null
-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
+++ /dev/null
-
-PACKAGE = cic_disambiguation
-NOTATIONS = number
-INTERFACE_FILES = \
- disambiguateTypes.mli \
- disambiguateChoices.mli \
- disambiguate.mli
-IMPLEMENTATION_FILES = \
- $(patsubst %.mli, %.ml, $(INTERFACE_FILES)) \
- $(patsubst %,%_notation.ml,$(NOTATIONS))
-
-all:
-
-clean:
-distclean:
- rm -f macro_table.dump
-
-include ../../Makefile.defs
-include ../Makefile.common
-
-OCAMLARCHIVEOPTIONS += -linkall
-
-disambiguateTypes.cmi: disambiguateTypes.mli
- @echo " OCAMLC -rectypes $<"
- @$(OCAMLC) -c -rectypes $<
-disambiguateTypes.cmo: disambiguateTypes.ml disambiguateTypes.cmi
- @echo " OCAMLC -rectypes $<"
- @$(OCAMLC) -c -rectypes $<
-disambiguateTypes.cmx: disambiguateTypes.ml disambiguateTypes.cmi
- @echo " OCAMLOPT -rectypes $<"
- @$(OCAMLOPT) -c -rectypes $<
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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)))
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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)
+++ /dev/null
-(* 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
-*)
+++ /dev/null
-
-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)
-
+++ /dev/null
-(* 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))
-
+++ /dev/null
-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"
+++ /dev/null
-\forall n. \forall m. n + m = n
+++ /dev/null
-[\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 []
-
+++ /dev/null
-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
+++ /dev/null
-
-PACKAGE = cic_proof_checking
-PREDICATES =
-
-REDUCTION_IMPLEMENTATION = cicReductionMachine.ml
-
-INTERFACE_FILES = \
- cicLogger.mli \
- cicEnvironment.mli \
- cicPp.mli \
- cicUnivUtils.mli \
- cicSubstitution.mli \
- cicMiniReduction.mli \
- cicReduction.mli \
- cicTypeChecker.mli \
- freshNamesGenerator.mli \
- $(NULL)
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-
-# Metadata tools only need zeta-reduction
-EXTRA_OBJECTS_TO_INSTALL = \
- cicSubstitution.cmo cicSubstitution.cmx cicSubstitution.o \
- cicMiniReduction.cmo cicMiniReduction.cmx cicMiniReduction.o
-EXTRA_OBJECTS_TO_CLEAN =
-
-include ../../Makefile.defs
-include ../Makefile.common
-
-cicReduction.cmo: OCAMLOPTIONS+=-rectypes
-cicReduction.cmx: OCAMLOPTIONS+=-rectypes
-
-all: all_utilities
-opt: opt_utilities
-
-all_utilities:
- @$(MAKE) -C utilities/ all
-opt_utilities:
- @$(MAKE) -C utilities/ opt
-
-clean: clean_utilities
-clean_utilities:
- @$(MAKE) -C utilities/ clean
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*****************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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_ugraph uri =
- try
- (* the object should be in the cacheOfCookedObjects *)
- let o,u,l = Cache.find_cooked uri in
- o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)),l
- with Not_found ->
- (* this should be an error case, but if we trust the uri... *)
- if trust && trust_obj uri then
- (* trusting means that we will fetch cook it on the fly *)
- let o,u,l = add_trusted_uri_to_cache uri in
- o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)),l
- else
- (* we don't trust the uri, so we fail *)
- begin
- debug_print (lazy ("CACHE MISS: " ^ (UriManager.string_of_uri uri)));
- raise Not_found
- end
-
-let get_cooked_obj ?trust base_ugraph uri =
- let o,g,_ = get_cooked_obj_with_univlist ?trust base_ugraph uri in
- o,g
-
-(* This has not the old semantic :( but is what the name suggests
- *
- * let is_type_checked ?(trust=true) uri =
- * try
- * let _ = Cache.find_cooked uri in
- * true
- * with
- * Not_found ->
- * trust && trust_obj uri
- * ;;
- *
- * as the get_cooked_obj but returns a type_checked_obj
- *
- *)
-let is_type_checked ?(trust=true) base_ugraph uri =
- try
- let o,u,_ = Cache.find_cooked uri in
- CheckedObj (o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)))
- with Not_found ->
- (* this should return UncheckedObj *)
- if trust && trust_obj uri then
- (* trusting means that we will fetch cook it on the fly *)
- let o,u,_ = add_trusted_uri_to_cache uri in
- CheckedObj ( o, CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri))
- else
- let o,u,_ = find_or_add_to_unchecked uri in
- Cache.unchecked_to_frozen uri;
- UncheckedObj o
-;;
-
-(* as the get cooked, but if not present the object is only fetched,
- * not unfreezed and committed
- *)
-let get_obj base_ugraph uri =
- try
- (* the object should be in the cacheOfCookedObjects *)
- let o,u,_ = Cache.find_cooked uri in
- o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri))
- with Not_found ->
- (* this should be an error case, but if we trust the uri... *)
- let o,u,_ = find_or_add_to_unchecked uri in
- o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri))
-;;
-
-let in_cache uri =
- Cache.is_in_cooked uri || Cache.is_in_frozen uri || Cache.is_in_unchecked uri
-
-let add_type_checked_obj uri (obj,ugraph,univlist) =
- Cache.add_cooked ~key:uri (obj,ugraph,univlist)
-
-let in_library uri = in_cache uri || Http_getter.exists' uri
-
-let remove_obj = Cache.remove
-
-let list_uri () =
- Cache.list_all_cooked_uris ()
-;;
-
-let list_obj () =
- try
- List.map (fun u ->
- let o,ug = get_obj CicUniv.empty_ugraph u in
- (u,o,ug))
- (list_uri ())
- with
- Not_found ->
- debug_print (lazy "Who has removed the uri in the meanwhile?");
- raise Not_found
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(****************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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 *)
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-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
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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)
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val letin_nf : Cic.term -> Cic.term
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*****************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* This module implements a very simple Coq-like pretty printer that, given *)
-(* an object of cic (internal representation) returns a string describing *)
-(* the object in a syntax similar to that of coq *)
-(* *)
-(* It also contains the utility functions to check a name w.r.t the Matita *)
-(* naming policy *)
-(* *)
-(*****************************************************************************)
-
-(* $Id$ *)
-
-exception CicPpInternalError;;
-exception NotEnoughElements;;
-
-(* Utility functions *)
-
-let ppname =
- function
- Cic.Name s -> s
- | Cic.Anonymous -> "_"
-;;
-
-(* get_nth l n returns the nth element of the list l if it exists or *)
-(* raises NotEnoughElements if l has less than n elements *)
-let rec get_nth l n =
- match (n,l) with
- (1, he::_) -> he
- | (n, he::tail) when n > 1 -> get_nth tail (n-1)
- | (_,_) -> raise NotEnoughElements
-;;
-
-(* pp t l *)
-(* pretty-prints a term t of cic in an environment l where l is a list of *)
-(* identifier names used to resolve DeBrujin indexes. The head of l is the *)
-(* name associated to the greatest DeBrujin index in t *)
-let rec pp t l =
- let module C = Cic in
- match t with
- C.Rel n ->
- begin
- try
- (match get_nth l n with
- Some (C.Name s) -> s
- | Some C.Anonymous -> "__" ^ string_of_int n
- | None -> "_hidden_" ^ string_of_int n
- )
- with
- NotEnoughElements -> string_of_int (List.length l - n)
- end
- | C.Var (uri,exp_named_subst) ->
- UriManager.string_of_uri (*UriManager.name_of_uri*) uri ^ pp_exp_named_subst exp_named_subst l
- | C.Meta (n,l1) ->
- "?" ^ (string_of_int n) ^ "[" ^
- String.concat " ; "
- (List.rev_map (function None -> "_" | Some t -> pp t l) l1) ^
- "]"
- | C.Sort s ->
- (match s with
- C.Prop -> "Prop"
- | C.Set -> "Set"
- | C.Type _ -> "Type"
- (*| C.Type u -> ("Type" ^ CicUniv.string_of_universe u)*)
- | C.CProp -> "CProp"
- )
- | C.Implicit (Some `Hole) -> "%"
- | C.Implicit _ -> "?"
- | C.Prod (b,s,t) ->
- (match b with
- C.Name n -> "(" ^ n ^ ":" ^ pp s l ^ ")" ^ pp t ((Some b)::l)
- | C.Anonymous -> "(" ^ pp s l ^ "->" ^ pp t ((Some b)::l) ^ ")"
- )
- | C.Cast (v,t) -> "(" ^ pp v l ^ ":" ^ pp t l ^ ")"
- | C.Lambda (b,s,t) ->
- "(\\lambda " ^ ppname b ^ ":" ^ pp s l ^ "." ^ pp t ((Some b)::l) ^ ")"
- | C.LetIn (b,s,t) ->
- "[" ^ ppname b ^ ":=" ^ pp s l ^ "]" ^ pp t ((Some b)::l)
- | C.Appl li ->
- "(" ^
- (List.fold_right
- (fun x i -> pp x l ^ (match i with "" -> "" | _ -> " ") ^ i)
- li ""
- ) ^ ")"
- | C.Const (uri,exp_named_subst) ->
- UriManager.name_of_uri uri ^ pp_exp_named_subst exp_named_subst l
- | C.MutInd (uri,n,exp_named_subst) ->
- (try
- match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with
- C.InductiveDefinition (dl,_,_,_) ->
- let (name,_,_,_) = get_nth dl (n+1) in
- name ^ pp_exp_named_subst exp_named_subst l
- | _ -> raise CicPpInternalError
- with
- _ -> UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n + 1)
- )
- | C.MutConstruct (uri,n1,n2,exp_named_subst) ->
- (try
- match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with
- C.InductiveDefinition (dl,_,_,_) ->
- let (_,_,_,cons) = get_nth dl (n1+1) in
- let (id,_) = get_nth cons n2 in
- id ^ pp_exp_named_subst exp_named_subst l
- | _ -> raise CicPpInternalError
- with
- _ ->
- UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n1 + 1) ^ "/" ^
- string_of_int n2
- )
- | C.MutCase (uri,n1,ty,te,patterns) ->
- let connames =
- (match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with
- C.InductiveDefinition (dl,_,_,_) ->
- let (_,_,_,cons) = get_nth dl (n1+1) in
- List.map (fun (id,_) -> id) cons
- | _ -> raise CicPpInternalError
- )
- in
- let connames_and_patterns =
- let rec combine =
- function
- [],[] -> []
- | [],l -> List.map (fun x -> "???",Some x) l
- | l,[] -> List.map (fun x -> x,None) l
- | x::tlx,y::tly -> (x,Some y)::(combine (tlx,tly))
- in
- combine (connames,patterns)
- in
- "\n<" ^ pp ty l ^ ">Cases " ^ pp te l ^ " of " ^
- List.fold_right
- (fun (x,y) i -> "\n " ^ x ^ " => " ^
- (match y with None -> "" | Some y -> pp y l) ^ i)
- connames_and_patterns "" ^
- "\nend"
- | C.Fix (no, funs) ->
- let snames = List.map (fun (name,_,_,_) -> name) funs in
- let names =
- List.rev (List.map (function name -> Some (C.Name name)) snames)
- in
- "\nFix " ^ get_nth snames (no + 1) ^ " {" ^
- List.fold_right
- (fun (name,ind,ty,bo) i -> "\n" ^ name ^ " / " ^ string_of_int ind ^
- " : " ^ pp ty l ^ " := \n" ^
- pp bo (names@l) ^ i)
- funs "" ^
- "}\n"
- | C.CoFix (no,funs) ->
- let snames = List.map (fun (name,_,_) -> name) funs in
- let names =
- List.rev (List.map (function name -> Some (C.Name name)) snames)
- in
- "\nCoFix " ^ get_nth snames (no + 1) ^ " {" ^
- List.fold_right
- (fun (name,ty,bo) i -> "\n" ^ name ^
- " : " ^ pp ty l ^ " := \n" ^
- pp bo (names@l) ^ i)
- funs "" ^
- "}\n"
-and pp_exp_named_subst exp_named_subst l =
- if exp_named_subst = [] then "" else
- "\\subst[" ^
- String.concat " ; " (
- List.map
- (function (uri,t) -> UriManager.name_of_uri uri ^ " \\Assign " ^ pp t l)
- exp_named_subst
- ) ^ "]"
-;;
-
-let ppterm t =
- pp t []
-;;
-
-(* ppinductiveType (typename, inductive, arity, cons) *)
-(* pretty-prints a single inductive definition *)
-(* (typename, inductive, arity, cons) *)
-let ppinductiveType (typename, inductive, arity, cons) =
- (if inductive then "\nInductive " else "\nCoInductive ") ^ typename ^ ": " ^
- pp arity [] ^ " =\n " ^
- List.fold_right
- (fun (id,ty) i -> id ^ " : " ^ pp ty [] ^
- (if i = "" then "\n" else "\n | ") ^ i)
- cons ""
-;;
-
-let ppcontext ?(sep = "\n") context =
- let separate s = if s = "" then "" else s ^ sep in
- fst (List.fold_right
- (fun context_entry (i,name_context) ->
- match context_entry with
- Some (n,Cic.Decl t) ->
- Printf.sprintf "%s%s : %s" (separate i) (ppname n)
- (pp t name_context), (Some n)::name_context
- | Some (n,Cic.Def (bo,ty)) ->
- Printf.sprintf "%s%s : %s := %s" (separate i) (ppname n)
- (match ty with
- None -> "_"
- | Some ty -> pp ty name_context)
- (pp bo name_context), (Some n)::name_context
- | None ->
- Printf.sprintf "%s_ :? _" (separate i), None::name_context
- ) context ("",[]))
-
-(* ppobj obj returns a string with describing the cic object obj in a syntax *)
-(* similar to the one used by Coq *)
-let ppobj obj =
- let module C = Cic in
- let module U = UriManager in
- match obj with
- C.Constant (name, Some t1, t2, params, _) ->
- "Definition of " ^ name ^
- "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^
- ")" ^ ":\n" ^ pp t1 [] ^ " : " ^ pp t2 []
- | C.Constant (name, None, ty, params, _) ->
- "Axiom " ^ name ^
- "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^
- "):\n" ^ pp ty []
- | C.Variable (name, bo, ty, params, _) ->
- "Variable " ^ name ^
- "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^
- ")" ^ ":\n" ^
- pp ty [] ^ "\n" ^
- (match bo with None -> "" | Some bo -> ":= " ^ pp bo [])
- | C.CurrentProof (name, conjectures, value, ty, params, _) ->
- "Current Proof of " ^ name ^
- "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^
- ")" ^ ":\n" ^
- let separate s = if s = "" then "" else s ^ " ; " in
- List.fold_right
- (fun (n, context, t) i ->
- let conjectures',name_context =
- List.fold_right
- (fun context_entry (i,name_context) ->
- (match context_entry with
- Some (n,C.Decl at) ->
- (separate i) ^
- ppname n ^ ":" ^ pp at name_context ^ " ",
- (Some n)::name_context
- | Some (n,C.Def (at,None)) ->
- (separate i) ^
- ppname n ^ ":= " ^ pp at name_context ^ " ",
- (Some n)::name_context
- | None ->
- (separate i) ^ "_ :? _ ", None::name_context
- | _ -> assert false)
- ) context ("",[])
- in
- conjectures' ^ " |- " ^ "?" ^ (string_of_int n) ^ ": " ^
- pp t name_context ^ "\n" ^ i
- ) conjectures "" ^
- "\n" ^ pp value [] ^ " : " ^ pp ty []
- | C.InductiveDefinition (l, params, nparams, _) ->
- "Parameters = " ^
- String.concat ";" (List.map UriManager.string_of_uri params) ^ "\n" ^
- "NParams = " ^ string_of_int nparams ^ "\n" ^
- List.fold_right (fun x i -> ppinductiveType x ^ i) l ""
-;;
-
-let ppsort = function
- | Cic.Prop -> "Prop"
- | Cic.Set -> "Set"
- | Cic.Type _ -> "Type"
- | Cic.CProp -> "CProp"
-
-
-(* MATITA NAMING CONVENTION *)
-
-let is_prefix prefix string =
- let len = String.length prefix in
- let len1 = String.length string in
- if len <= len1 then
- begin
- let head = String.sub string 0 len in
- if
- (String.compare (String.lowercase head) (String.lowercase prefix)=0) then
- begin
- let diff = len1-len in
- let tail = String.sub string len diff in
- if ((diff > 0) && (String.rcontains_from tail 0 '_')) then
- Some (String.sub tail 1 (diff-1))
- else Some tail
- end
- else None
- end
- else None
-
-let remove_prefix prefix (last,string) =
- if prefix="append" then
- begin
- prerr_endline last;
- prerr_endline string;
- end;
- if string = "" then (last,string)
- else
- match is_prefix prefix string with
- None ->
- if last <> "" then
- match is_prefix last prefix with
- None -> (last,string)
- | Some _ ->
- (match is_prefix prefix (last^string) with
- None -> (last,string)
- | Some tail -> (prefix,tail))
- else (last,string)
- | Some tail -> (prefix, tail)
-
-let legal_suffix string =
- if string = "" then true else
- begin
- let legal_s = Str.regexp "_?\\([0-9]+\\|r\\|l\\|'\\|\"\\)" in
- (Str.string_match legal_s string 0) && (Str.matched_string string = string)
- end
-
-(** check if a prefix of string_name is legal for term and returns the tail.
- chec_rec cannot fail: at worst it return string_name.
- The algorithm is greedy, but last contains the last name matched, providing
- a one slot buffer.
- string_name is here a pair (last,string_name).*)
-
-let rec check_rec ctx string_name =
- function
- | Cic.Rel m ->
- (match List.nth ctx (m-1) with
- Cic.Name name ->
- remove_prefix name string_name
- | Cic.Anonymous -> string_name)
- | Cic.Meta _ -> string_name
- | Cic.Sort sort -> remove_prefix (ppsort sort) string_name
- | Cic.Implicit _ -> string_name
- | Cic.Cast (te,ty) -> check_rec ctx string_name te
- | Cic.Prod (name,so,dest) ->
- let l_string_name = check_rec ctx string_name so in
- check_rec (name::ctx) string_name dest
- | Cic.Lambda (name,so,dest) ->
- let string_name =
- match name with
- Cic.Anonymous -> string_name
- | Cic.Name name -> remove_prefix name string_name in
- let l_string_name = check_rec ctx string_name so in
- check_rec (name::ctx) l_string_name dest
- | Cic.LetIn (name,so,dest) ->
- let string_name = check_rec ctx string_name so in
- check_rec (name::ctx) string_name dest
- | Cic.Appl l ->
- List.fold_left (check_rec ctx) string_name l
- | Cic.Var (uri,exp_named_subst) ->
- let name = UriManager.name_of_uri uri in
- remove_prefix name string_name
- | Cic.Const (uri,exp_named_subst) ->
- let name = UriManager.name_of_uri uri in
- remove_prefix name string_name
- | Cic.MutInd (uri,_,exp_named_subst) ->
- let name = UriManager.name_of_uri uri in
- remove_prefix name string_name
- | Cic.MutConstruct (uri,n,m,exp_named_subst) ->
- let name =
- (match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with
- Cic.InductiveDefinition (dl,_,_,_) ->
- let (_,_,_,cons) = get_nth dl (n+1) in
- let (id,_) = get_nth cons m in
- id
- | _ -> assert false) in
- remove_prefix name string_name
- | Cic.MutCase (_,_,_,te,pl) ->
- let strig_name = remove_prefix "match" string_name in
- let string_name = check_rec ctx string_name te in
- List.fold_right (fun t s -> check_rec ctx s t) pl string_name
- | Cic.Fix (_,fl) ->
- let strig_name = remove_prefix "fix" string_name in
- let names = List.map (fun (name,_,_,_) -> name) fl in
- let onames =
- List.rev (List.map (function name -> Cic.Name name) names)
- in
- List.fold_right
- (fun (_,_,_,bo) s -> check_rec (onames@ctx) s bo) fl string_name
- | Cic.CoFix (_,fl) ->
- let strig_name = remove_prefix "cofix" string_name in
- let names = List.map (fun (name,_,_) -> name) fl in
- let onames =
- List.rev (List.map (function name -> Cic.Name name) names)
- in
- List.fold_right
- (fun (_,_,bo) s -> check_rec (onames@ctx) s bo) fl string_name
-
-let check_name ?(allow_suffix=false) ctx name term =
- let (_,tail) = check_rec ctx ("",name) term in
- if (not allow_suffix) then (String.length tail = 0)
- else legal_suffix tail
-
-let check_elim ctx conclusion_name =
- let elim = Str.regexp "_elim\\|_case" in
- if (Str.string_match elim conclusion_name 0) then
- let len = String.length conclusion_name in
- let tail = String.sub conclusion_name 5 (len-5) in
- legal_suffix tail
- else false
-
-let rec check_names ctx hyp_names conclusion_name t =
- match t with
- | Cic.Prod (name,s,t) ->
- (match hyp_names with
- [] -> check_names (name::ctx) hyp_names conclusion_name t
- | hd::tl ->
- if check_name ctx hd s then
- check_names (name::ctx) tl conclusion_name t
- else
- check_names (name::ctx) hyp_names conclusion_name t)
- | Cic.Appl ((Cic.Rel n)::args) ->
- (match hyp_names with
- | [] ->
- (check_name ~allow_suffix:true ctx conclusion_name t) ||
- (check_elim ctx conclusion_name)
- | [what_to_elim] ->
- (* what to elim could be an argument
- of the predicate: e.g. leb_elim *)
- let (last,tail) =
- List.fold_left (check_rec ctx) ("",what_to_elim) args in
- (tail = "" && check_elim ctx conclusion_name)
- | _ -> false)
- | Cic.MutCase (_,_,Cic.Lambda(name,so,ty),te,_) ->
- (match hyp_names with
- | [] ->
- (match is_prefix "match" conclusion_name with
- None -> check_name ~allow_suffix:true ctx conclusion_name t
- | Some tail -> check_name ~allow_suffix:true ctx tail t)
- | [what_to_match] ->
- (* what to match could be the term te or its type so; in this case the
- conclusion name should match ty *)
- check_name ~allow_suffix:true (name::ctx) conclusion_name ty &&
- (check_name ctx what_to_match te || check_name ctx what_to_match so)
- | _ -> false)
- | _ ->
- hyp_names=[] && check_name ~allow_suffix:true ctx conclusion_name t
-
-let check name term =
-(* prerr_endline name;
- prerr_endline (ppterm term); *)
- let names = Str.split (Str.regexp_string "_to_") name in
- let hyp_names,conclusion_name =
- match List.rev names with
- [] -> assert false
- | hd::tl ->
- let elim = Str.regexp "_elim\\|_case" in
- let len = String.length hd in
- try
- let pos = Str.search_backward elim hd len in
- let hyp = String.sub hd 0 pos in
- let concl = String.sub hd pos (len-pos) in
- List.rev (hyp::tl),concl
- with Not_found -> (List.rev tl),hd in
- check_names [] hyp_names conclusion_name term
-;;
-
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*****************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-(* TODO unify exceptions *)
-
-exception WrongUriToInductiveDefinition;;
-exception Impossible of int;;
-exception ReferenceToConstant;;
-exception ReferenceToVariable;;
-exception ReferenceToCurrentProof;;
-exception ReferenceToInductiveDefinition;;
-
-let debug = false
-let profile = false
-let debug_print s = if debug then prerr_endline (Lazy.force s)
-
-let fdebug = ref 1;;
-let debug t env s =
- let rec debug_aux t i =
- let module C = Cic in
- let module U = UriManager in
- CicPp.ppobj (C.Variable ("DEBUG", None, t, [], [])) ^ "\n" ^ i
- in
- if !fdebug = 0 then
- debug_print (lazy (s ^ "\n" ^ List.fold_right debug_aux (t::env) ""))
-;;
-
-module type Strategy =
- sig
- type stack_term
- type env_term
- type ens_term
- type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
- val to_env : config -> env_term
- val to_ens : config -> ens_term
- val from_stack : stack_term -> config
- val from_stack_list_for_unwind :
- unwind: (config -> Cic.term) ->
- stack_term list -> Cic.term list
- val from_env : env_term -> config
- val from_env_for_unwind :
- unwind: (config -> Cic.term) ->
- env_term -> Cic.term
- val from_ens : ens_term -> config
- val from_ens_for_unwind :
- unwind: (config -> Cic.term) ->
- ens_term -> Cic.term
- val stack_to_env :
- reduce: (config -> config) ->
- unwind: (config -> Cic.term) ->
- stack_term -> env_term
- val compute_to_env :
- reduce: (config -> config) ->
- unwind: (config -> Cic.term) ->
- int -> env_term list -> ens_term Cic.explicit_named_substitution ->
- Cic.term -> env_term
- val compute_to_stack :
- reduce: (config -> config) ->
- unwind: (config -> Cic.term) ->
- config -> stack_term
- end
-;;
-
-module CallByValueByNameForUnwind =
- struct
- type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
- and stack_term = config
- and env_term = config * config (* cbv, cbn *)
- and ens_term = config * config (* cbv, cbn *)
-
- let to_env c = c,c
- let to_ens c = c,c
- let from_stack config = config
- let from_stack_list_for_unwind ~unwind l = List.map unwind l
- let from_env (c,_) = c
- let from_ens (c,_) = c
- let from_env_for_unwind ~unwind (_,c) = unwind c
- let from_ens_for_unwind ~unwind (_,c) = unwind c
- let stack_to_env ~reduce ~unwind config = reduce config, (0,[],[],unwind config,[])
- let compute_to_env ~reduce ~unwind k e ens t = (k,e,ens,t,[]), (k,e,ens,t,[])
- let compute_to_stack ~reduce ~unwind config = config
- end
-;;
-
-
-module CallByNameStrategy =
- struct
- type stack_term = Cic.term
- type env_term = Cic.term
- type ens_term = Cic.term
- type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
- let to_env v = v
- let to_ens v = v
- let from_stack ~unwind v = v
- let from_stack_list ~unwind l = l
- let from_env v = v
- let from_ens v = v
- let from_env_for_unwind ~unwind v = v
- let from_ens_for_unwind ~unwind v = v
- let stack_to_env ~reduce ~unwind v = v
- let compute_to_stack ~reduce ~unwind k e ens t = unwind k e ens t
- let compute_to_env ~reduce ~unwind k e ens t = unwind k e ens t
- end
-;;
-
-module CallByValueStrategy =
- struct
- type stack_term = Cic.term
- type env_term = Cic.term
- type ens_term = Cic.term
- type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
- let to_env v = v
- let to_ens v = v
- let from_stack ~unwind v = v
- let from_stack_list ~unwind l = l
- let from_env v = v
- let from_ens v = v
- let from_env_for_unwind ~unwind v = v
- let from_ens_for_unwind ~unwind v = v
- let stack_to_env ~reduce ~unwind v = v
- let compute_to_stack ~reduce ~unwind k e ens t = reduce (k,e,ens,t,[])
- let compute_to_env ~reduce ~unwind k e ens t = reduce (k,e,ens,t,[])
- end
-;;
-
-module CallByValueStrategyByNameOnConstants =
- struct
- type stack_term = Cic.term
- type env_term = Cic.term
- type ens_term = Cic.term
- type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
- let to_env v = v
- let to_ens v = v
- let from_stack ~unwind v = v
- let from_stack_list ~unwind l = l
- let from_env v = v
- let from_ens v = v
- let from_env_for_unwind ~unwind v = v
- let from_ens_for_unwind ~unwind v = v
- let stack_to_env ~reduce ~unwind v = v
- let compute_to_stack ~reduce ~unwind k e ens =
- function
- Cic.Const _ as t -> unwind k e ens t
- | t -> reduce (k,e,ens,t,[])
- let compute_to_env ~reduce ~unwind k e ens =
- function
- Cic.Const _ as t -> unwind k e ens t
- | t -> reduce (k,e,ens,t,[])
- end
-;;
-
-module LazyCallByValueStrategy =
- struct
- type stack_term = Cic.term lazy_t
- type env_term = Cic.term lazy_t
- type ens_term = Cic.term lazy_t
- type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
- let to_env v = lazy v
- let to_ens v = lazy v
- let from_stack ~unwind v = Lazy.force v
- let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
- let from_env v = Lazy.force v
- let from_ens v = Lazy.force v
- let from_env_for_unwind ~unwind v = Lazy.force v
- let from_ens_for_unwind ~unwind v = Lazy.force v
- let stack_to_env ~reduce ~unwind v = v
- let compute_to_stack ~reduce ~unwind k e ens t = lazy (reduce (k,e,ens,t,[]))
- let compute_to_env ~reduce ~unwind k e ens t = lazy (reduce (k,e,ens,t,[]))
- end
-;;
-
-module LazyCallByValueStrategyByNameOnConstants =
- struct
- type stack_term = Cic.term lazy_t
- type env_term = Cic.term lazy_t
- type ens_term = Cic.term lazy_t
- type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
- let to_env v = lazy v
- let to_ens v = lazy v
- let from_stack ~unwind v = Lazy.force v
- let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
- let from_env v = Lazy.force v
- let from_ens v = Lazy.force v
- let from_env_for_unwind ~unwind v = Lazy.force v
- let from_ens_for_unwind ~unwind v = Lazy.force v
- let stack_to_env ~reduce ~unwind v = v
- let compute_to_stack ~reduce ~unwind k e ens t =
- lazy (
- match t with
- Cic.Const _ as t -> unwind k e ens t
- | t -> reduce (k,e,ens,t,[]))
- let compute_to_env ~reduce ~unwind k e ens t =
- lazy (
- match t with
- Cic.Const _ as t -> unwind k e ens t
- | t -> reduce (k,e,ens,t,[]))
- end
-;;
-
-module LazyCallByNameStrategy =
- struct
- type stack_term = Cic.term lazy_t
- type env_term = Cic.term lazy_t
- type ens_term = Cic.term lazy_t
- type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
- let to_env v = lazy v
- let to_ens v = lazy v
- let from_stack ~unwind v = Lazy.force v
- let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
- let from_env v = Lazy.force v
- let from_ens v = Lazy.force v
- let from_env_for_unwind ~unwind v = Lazy.force v
- let from_ens_for_unwind ~unwind v = Lazy.force v
- let stack_to_env ~reduce ~unwind v = v
- let compute_to_stack ~reduce ~unwind k e ens t = lazy (unwind k e ens t)
- let compute_to_env ~reduce ~unwind k e ens t = lazy (unwind k e ens t)
- end
-;;
-
-module
- LazyCallByValueByNameOnConstantsWhenFromStack_ByNameStrategyWhenFromEnvOrEns
-=
- struct
- type stack_term = reduce:bool -> Cic.term
- type env_term = reduce:bool -> Cic.term
- type ens_term = reduce:bool -> Cic.term
- type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
- let to_env v =
- let value = lazy v in
- fun ~reduce -> Lazy.force value
- let to_ens v =
- let value = lazy v in
- fun ~reduce -> Lazy.force value
- let from_stack ~unwind v = (v ~reduce:false)
- let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
- let from_env v = (v ~reduce:true)
- let from_ens v = (v ~reduce:true)
- let from_env_for_unwind ~unwind v = (v ~reduce:true)
- let from_ens_for_unwind ~unwind v = (v ~reduce:true)
- let stack_to_env ~reduce ~unwind v = v
- let compute_to_stack ~reduce ~unwind k e ens t =
- let svalue =
- lazy (
- match t with
- Cic.Const _ as t -> unwind k e ens t
- | t -> reduce (k,e,ens,t,[])
- ) in
- let lvalue =
- lazy (unwind k e ens t)
- in
- fun ~reduce ->
- if reduce then Lazy.force svalue else Lazy.force lvalue
- let compute_to_env ~reduce ~unwind k e ens t =
- let svalue =
- lazy (
- match t with
- Cic.Const _ as t -> unwind k e ens t
- | t -> reduce (k,e,ens,t,[])
- ) in
- let lvalue =
- lazy (unwind k e ens t)
- in
- fun ~reduce ->
- if reduce then Lazy.force svalue else Lazy.force lvalue
- end
-;;
-
-module ClosuresOnStackByValueFromEnvOrEnsStrategy =
- struct
- type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
- and stack_term = config
- and env_term = config
- and ens_term = config
-
- let to_env config = config
- let to_ens config = config
- let from_stack config = config
- let from_stack_list_for_unwind ~unwind l = List.map unwind l
- let from_env v = v
- let from_ens v = v
- let from_env_for_unwind ~unwind config = unwind config
- let from_ens_for_unwind ~unwind config = unwind config
- let stack_to_env ~reduce ~unwind config = reduce config
- let compute_to_env ~reduce ~unwind k e ens t = (k,e,ens,t,[])
- let compute_to_stack ~reduce ~unwind config = config
- end
-;;
-
-module ClosuresOnStackByValueFromEnvOrEnsByNameOnConstantsStrategy =
- struct
- type stack_term =
- int * Cic.term list * Cic.term Cic.explicit_named_substitution * Cic.term
- type env_term = Cic.term
- type ens_term = Cic.term
- type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
- let to_env v = v
- let to_ens v = v
- let from_stack ~unwind (k,e,ens,t) = unwind k e ens t
- let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
- let from_env v = v
- let from_ens v = v
- let from_env_for_unwind ~unwind v = v
- let from_ens_for_unwind ~unwind v = v
- let stack_to_env ~reduce ~unwind (k,e,ens,t) =
- match t with
- Cic.Const _ as t -> unwind k e ens t
- | t -> reduce (k,e,ens,t,[])
- let compute_to_env ~reduce ~unwind k e ens t =
- unwind k e ens t
- let compute_to_stack ~reduce ~unwind k e ens t = (k,e,ens,t)
- end
-;;
-
-module Reduction(RS : Strategy) =
- struct
- type env = RS.env_term list
- type ens = RS.ens_term Cic.explicit_named_substitution
- type stack = RS.stack_term list
- type config = int * env * ens * Cic.term * stack
-
- (* k is the length of the environment e *)
- (* m is the current depth inside the term *)
- let rec unwind' m k e ens t =
- let module C = Cic in
- let module S = CicSubstitution in
- if k = 0 && ens = [] then
- t
- else
- let rec unwind_aux m =
- function
- C.Rel n as t ->
- if n <= m then t else
- let d =
- try
- Some (RS.from_env_for_unwind ~unwind (List.nth e (n-m-1)))
- with _ -> None
- in
- (match d with
- Some t' ->
- if m = 0 then t' else S.lift m t'
- | None -> C.Rel (n-k)
- )
- | C.Var (uri,exp_named_subst) ->
-(*
-debug_print (lazy ("%%%%%UWVAR " ^ String.concat " ; " (List.map (function (uri,t) -> UriManager.string_of_uri uri ^ " := " ^ CicPp.ppterm t) ens))) ;
-*)
- if List.exists (function (uri',_) -> UriManager.eq uri' uri) ens then
- CicSubstitution.lift m (RS.from_ens_for_unwind ~unwind (List.assq uri ens))
- else
- let params =
- let o,_ =
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
- in
- (match o with
- C.Constant _ -> raise ReferenceToConstant
- | C.Variable (_,_,_,params,_) -> params
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- in
- let exp_named_subst' =
- substaux_in_exp_named_subst params exp_named_subst m
- in
- C.Var (uri,exp_named_subst')
- | C.Meta (i,l) ->
- let l' =
- List.map
- (function
- None -> None
- | Some t -> Some (unwind_aux m t)
- ) l
- in
- C.Meta (i, l')
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (unwind_aux m te, unwind_aux m ty) (*CSC ???*)
- | C.Prod (n,s,t) -> C.Prod (n, unwind_aux m s, unwind_aux (m + 1) t)
- | C.Lambda (n,s,t) -> C.Lambda (n, unwind_aux m s, unwind_aux (m + 1) t)
- | C.LetIn (n,s,t) -> C.LetIn (n, unwind_aux m s, unwind_aux (m + 1) t)
- | C.Appl l -> C.Appl (List.map (unwind_aux m) l)
- | C.Const (uri,exp_named_subst) ->
- let params =
- let o,_ =
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
- in
- (match o with
- C.Constant (_,_,_,params,_) -> params
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof (_,_,_,_,params,_) -> params
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- in
- let exp_named_subst' =
- substaux_in_exp_named_subst params exp_named_subst m
- in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,i,exp_named_subst) ->
- let params =
- let o,_ =
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
- in
- (match o with
- C.Constant _ -> raise ReferenceToConstant
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition (_,params,_,_) -> params
- )
- in
- let exp_named_subst' =
- substaux_in_exp_named_subst params exp_named_subst m
- in
- C.MutInd (uri,i,exp_named_subst')
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let params =
- let o,_ =
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
- in
- (match o with
- C.Constant _ -> raise ReferenceToConstant
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition (_,params,_,_) -> params
- )
- in
- let exp_named_subst' =
- substaux_in_exp_named_subst params exp_named_subst m
- in
- C.MutConstruct (uri,i,j,exp_named_subst')
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i,unwind_aux m outt, unwind_aux m t,
- List.map (unwind_aux m) pl)
- | C.Fix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) ->
- (name, i, unwind_aux m ty, unwind_aux (m+len) bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (name, unwind_aux m ty, unwind_aux (m+len) bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- and substaux_in_exp_named_subst params exp_named_subst' m =
- (*CSC: Idea di Andrea di ordinare compatibilmente con l'ordine dei params
- let ens' =
- List.map (function (uri,t) -> uri, unwind_aux m t) exp_named_subst' @
- (*CSC: qui liftiamo tutti gli ens anche se magari me ne servono la meta'!!! *)
- List.map (function (uri,t) -> uri, CicSubstitution.lift m t) ens
- in
- let rec filter_and_lift =
- function
- [] -> []
- | uri::tl ->
- let r = filter_and_lift tl in
- (try
- (uri,(List.assq uri ens'))::r
- with
- Not_found -> r
- )
- in
- filter_and_lift params
- *)
-
- (*CSC: invece di concatenare sarebbe meglio rispettare l'ordine dei params *)
- (*CSC: e' vero???? una veloce prova non sembra confermare la teoria *)
-
- (*CSC: codice copiato e modificato dalla cicSubstitution.subst_vars *)
- (*CSC: codice altamente inefficiente *)
- let rec filter_and_lift already_instantiated =
- function
- [] -> []
- | (uri,t)::tl when
- List.for_all
- (function (uri',_)-> not (UriManager.eq uri uri')) exp_named_subst'
- &&
- not (List.mem uri already_instantiated)
- &&
- List.mem uri params
- ->
- (uri,CicSubstitution.lift m (RS.from_ens_for_unwind ~unwind t)) ::
- (filter_and_lift (uri::already_instantiated) tl)
- | _::tl -> filter_and_lift already_instantiated tl
-(*
- | (uri,_)::tl ->
-debug_print (lazy ("---- SKIPPO " ^ UriManager.string_of_uri uri)) ;
-if List.for_all (function (uri',_) -> not (UriManager.eq uri uri'))
-exp_named_subst' then debug_print (lazy "---- OK1") ;
-debug_print (lazy ("++++ uri " ^ UriManager.string_of_uri uri ^ " not in " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ;
-if List.mem uri params then debug_print (lazy "---- OK2") ;
- filter_and_lift tl
-*)
- in
- List.map (function (uri,t) -> uri, unwind_aux m t) exp_named_subst' @
- (filter_and_lift [] (List.rev ens))
- in
- unwind_aux m t
-
- and unwind (k,e,ens,t,s) =
- let t' = unwind' 0 k e ens t in
- if s = [] then t' else Cic.Appl (t'::(RS.from_stack_list_for_unwind ~unwind s))
- ;;
-
-(*
- let unwind =
- let profiler_unwind = HExtlib.profile ~enable:profile "are_convertible.unwind" in
- fun k e ens t ->
- profiler_unwind.HExtlib.profile (unwind k e ens) t
- ;;
-*)
-
- let reduce ~delta ?(subst = []) context : config -> config =
- let module C = Cic in
- let module S = CicSubstitution in
- let rec reduce =
- function
- (k, e, _, C.Rel n, s) as config ->
- let config' =
- try
- Some (RS.from_env (List.nth e (n-1)))
- with
- Failure _ ->
- try
- begin
- match List.nth context (n - 1 - k) with
- None -> assert false
- | Some (_,C.Decl _) -> None
- | Some (_,C.Def (x,_)) -> Some (0,[],[],S.lift (n - k) x,[])
- end
- with
- Failure _ -> None
- in
- (match config' with
- Some (k',e',ens',t',s') -> reduce (k',e',ens',t',s'@s)
- | None -> config)
- | (k, e, ens, C.Var (uri,exp_named_subst), s) as config ->
- if List.exists (function (uri',_) -> UriManager.eq uri' uri) ens then
- let (k',e',ens',t',s') = RS.from_ens (List.assq uri ens) in
- reduce (k',e',ens',t',s'@s)
- else
- ( let o,_ =
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
- in
- match o with
- C.Constant _ -> raise ReferenceToConstant
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- | C.Variable (_,None,_,_,_) -> config
- | C.Variable (_,Some body,_,_,_) ->
- let ens' = push_exp_named_subst k e ens exp_named_subst in
- reduce (0, [], ens', body, s)
- )
- | (k, e, ens, C.Meta (n,l), s) as config ->
- (try
- let (_, term,_) = CicUtil.lookup_subst n subst in
- reduce (k, e, ens,CicSubstitution.subst_meta l term,s)
- with CicUtil.Subst_not_found _ -> config)
- | (_, _, _, C.Sort _, _)
- | (_, _, _, C.Implicit _, _) as config -> config
- | (k, e, ens, C.Cast (te,ty), s) ->
- reduce (k, e, ens, te, s)
- | (_, _, _, C.Prod _, _) as config -> config
- | (_, _, _, C.Lambda _, []) as config -> config
- | (k, e, ens, C.Lambda (_,_,t), p::s) ->
- reduce (k+1, (RS.stack_to_env ~reduce ~unwind p)::e, ens, t,s)
- | (k, e, ens, C.LetIn (_,m,t), s) ->
- let m' = RS.compute_to_env ~reduce ~unwind k e ens m in
- reduce (k+1, m'::e, ens, t, s)
- | (_, _, _, C.Appl [], _) -> assert false
- | (k, e, ens, C.Appl (he::tl), s) ->
- let tl' =
- List.map
- (function t -> RS.compute_to_stack ~reduce ~unwind (k,e,ens,t,[])) tl
- in
- reduce (k, e, ens, he, (List.append tl') s)
- | (_, _, _, C.Const _, _) as config when delta=false-> config
- | (k, e, ens, C.Const (uri,exp_named_subst), s) as config ->
- (let o,_ =
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
- in
- match o with
- C.Constant (_,Some body,_,_,_) ->
- let ens' = push_exp_named_subst k e ens exp_named_subst in
- (* constants are closed *)
- reduce (0, [], ens', body, s)
- | C.Constant (_,None,_,_,_) -> config
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof (_,_,body,_,_,_) ->
- let ens' = push_exp_named_subst k e ens exp_named_subst in
- (* constants are closed *)
- reduce (0, [], ens', body, s)
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- | (_, _, _, C.MutInd _, _)
- | (_, _, _, C.MutConstruct _, _) as config -> config
- | (k, e, ens, C.MutCase (mutind,i,outty,term,pl),s) as config ->
- let decofix =
- function
- (k, e, ens, C.CoFix (i,fl), s) ->
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- reduce (k,e,ens,body',s)
- | config -> config
- in
- (match decofix (reduce (k,e,ens,term,[])) with
- (k', e', ens', C.MutConstruct (_,_,j,_), []) ->
- reduce (k, e, ens, (List.nth pl (j-1)), [])
- | (k', e', ens', C.MutConstruct (_,_,j,_), s') ->
- let (arity, r) =
- let o,_ =
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph mutind
- in
- match o with
- C.InductiveDefinition (s,ingredients,r,_) ->
- let (_,_,arity,_) = List.nth s i in
- (arity,r)
- | _ -> raise WrongUriToInductiveDefinition
- in
- let ts =
- let num_to_eat = r in
- let rec eat_first =
- function
- (0,l) -> l
- | (n,he::s) when n > 0 -> eat_first (n - 1, s)
- | _ -> raise (Impossible 5)
- in
- eat_first (num_to_eat,s')
- in
- reduce (k, e, ens, (List.nth pl (j-1)), ts@s)
- | (_, _, _, C.Cast _, _)
- | (_, _, _, C.Implicit _, _) ->
- raise (Impossible 2) (* we don't trust our whd ;-) *)
- | config' ->
- (*CSC: here I am unwinding the configuration and for sure I
- will do it twice; to avoid this unwinding I should push the
- "match [] with _" continuation on the stack;
- another possibility is to just return the original configuration,
- partially undoing the weak-head computation *)
- (*this code is uncorrect since term' lives in e' <> e
- let term' = unwind config' in
- (k, e, ens, C.MutCase (mutind,i,outty,term',pl),s)
- *)
- config)
- | (k, e, ens, C.Fix (i,fl), s) as config ->
- let (_,recindex,_,body) = List.nth fl i in
- let recparam =
- try
- Some (RS.from_stack (List.nth s recindex))
- with
- _ -> None
- in
- (match recparam with
- Some recparam ->
- (match reduce recparam with
- (_,_,_,C.MutConstruct _,_) as config ->
- let leng = List.length fl in
- let new_env =
- let counter = ref 0 in
- let rec build_env e =
- if !counter = leng then e
- else
- (incr counter ;
- build_env
- ((RS.to_env (k,e,ens,C.Fix (!counter -1, fl),[]))::e))
- in
- build_env e
- in
- let rec replace i s t =
- match i,s with
- 0,_::tl -> t::tl
- | n,he::tl -> he::(replace (n - 1) tl t)
- | _,_ -> assert false in
- let new_s =
- replace recindex s (RS.compute_to_stack ~reduce ~unwind config)
- in
- reduce (k+leng, new_env, ens, body, new_s)
- | _ -> config)
- | None -> config
- )
- | (_,_,_,C.CoFix _,_) as config -> config
- and push_exp_named_subst k e ens =
- function
- [] -> ens
- | (uri,t)::tl ->
- push_exp_named_subst k e ((uri,RS.to_ens (k,e,ens,t,[]))::ens) tl
- in
- reduce
- ;;
-
- let whd ?(delta=true) ?(subst=[]) context t =
- unwind (reduce ~delta ~subst context (0, [], [], t, []))
- ;;
-
- end
-;;
-
-
-(* ROTTO = rompe l'unificazione poiche' riduce gli argomenti di un'applicazione
- senza ridurre la testa
-module R = Reduction CallByNameStrategy;; OK 56.368s
-module R = Reduction CallByValueStrategy;; ROTTO
-module R = Reduction CallByValueStrategyByNameOnConstants;; ROTTO
-module R = Reduction LazyCallByValueStrategy;; ROTTO
-module R = Reduction LazyCallByValueStrategyByNameOnConstants;; ROTTO
-module R = Reduction LazyCallByNameStrategy;; OK 0m56.398s
-module R = Reduction
- LazyCallByValueByNameOnConstantsWhenFromStack_ByNameStrategyWhenFromEnvOrEns;;
- OK 59.058s
-module R = Reduction ClosuresOnStackByValueFromEnvOrEnsStrategy;; OK 58.583s
-module R = Reduction
- ClosuresOnStackByValueFromEnvOrEnsByNameOnConstantsStrategy;; OK 58.094s
-module R = Reduction(ClosuresOnStackByValueFromEnvOrEnsStrategy);; OK 58.127s
-*)
-module R = Reduction(CallByValueByNameForUnwind);;
-(*module R = Reduction(ClosuresOnStackByValueFromEnvOrEnsStrategy);;*)
-module U = UriManager;;
-
-let whd = R.whd
-
-(*
-let whd =
- let profiler_whd = HExtlib.profile ~enable:profile "are_convertible.whd" in
- fun ?(delta=true) ?(subst=[]) context t ->
- profiler_whd.HExtlib.profile (whd ~delta ~subst context) t
-*)
-
- (* mimic ocaml (<< 3.08) "=" behaviour. Tests physical equality first then
- * fallbacks to structural equality *)
-let (===) x y =
- Pervasives.compare x y = 0
-
-(* t1, t2 must be well-typed *)
-let are_convertible whd ?(subst=[]) ?(metasenv=[]) =
- let rec aux test_equality_only context t1 t2 ugraph =
- let aux2 test_equality_only t1 t2 ugraph =
-
- (* this trivial euristic cuts down the total time of about five times ;-) *)
- (* this because most of the time t1 and t2 are "sintactically" the same *)
- if t1 === t2 then
- true,ugraph
- else
- begin
- let module C = Cic in
- match (t1,t2) with
- (C.Rel n1, C.Rel n2) -> (n1 = n2),ugraph
- | (C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2)) ->
- if U.eq uri1 uri2 then
- (try
- List.fold_right2
- (fun (uri1,x) (uri2,y) (b,ugraph) ->
- let b',ugraph' = aux test_equality_only context x y ugraph in
- (U.eq uri1 uri2 && b' && b),ugraph'
- ) exp_named_subst1 exp_named_subst2 (true,ugraph)
- with
- Invalid_argument _ -> false,ugraph
- )
- else
- false,ugraph
- | (C.Meta (n1,l1), C.Meta (n2,l2)) ->
- if n1 = n2 then
- let b2, ugraph1 =
- let l1 = CicUtil.clean_up_local_context subst metasenv n1 l1 in
- let l2 = CicUtil.clean_up_local_context subst metasenv n2 l2 in
- List.fold_left2
- (fun (b,ugraph) t1 t2 ->
- if b then
- match t1,t2 with
- None,_
- | _,None -> true,ugraph
- | Some t1',Some t2' ->
- aux test_equality_only context t1' t2' ugraph
- else
- false,ugraph
- ) (true,ugraph) l1 l2
- in
- if b2 then true,ugraph1 else false,ugraph
- else
- false,ugraph
- (* TASSI: CONSTRAINTS *)
- | (C.Sort (C.Type t1), C.Sort (C.Type t2)) when test_equality_only ->
- true,(CicUniv.add_eq t2 t1 ugraph)
- (* TASSI: CONSTRAINTS *)
- | (C.Sort (C.Type t1), C.Sort (C.Type t2)) ->
- true,(CicUniv.add_ge t2 t1 ugraph)
- (* TASSI: CONSTRAINTS *)
- | (C.Sort s1, C.Sort (C.Type _)) -> (not test_equality_only),ugraph
- (* TASSI: CONSTRAINTS *)
- | (C.Sort s1, C.Sort s2) -> (s1 = s2),ugraph
- | (C.Prod (name1,s1,t1), C.Prod(_,s2,t2)) ->
- let b',ugraph' = aux true context s1 s2 ugraph in
- if b' then
- aux test_equality_only ((Some (name1, (C.Decl s1)))::context)
- t1 t2 ugraph'
- else
- false,ugraph
- | (C.Lambda (name1,s1,t1), C.Lambda(_,s2,t2)) ->
- let b',ugraph' = aux test_equality_only context s1 s2 ugraph in
- if b' then
- aux test_equality_only ((Some (name1, (C.Decl s1)))::context)
- t1 t2 ugraph'
- else
- false,ugraph
- | (C.LetIn (name1,s1,t1), C.LetIn(_,s2,t2)) ->
- let b',ugraph' = aux test_equality_only context s1 s2 ugraph in
- if b' then
- aux test_equality_only
- ((Some (name1, (C.Def (s1,None))))::context) t1 t2 ugraph'
- else
- false,ugraph
- | (C.Appl l1, C.Appl l2) ->
- (try
- List.fold_right2
- (fun x y (b,ugraph) ->
- if b then
- aux test_equality_only context x y ugraph
- else
- false,ugraph) l1 l2 (true,ugraph)
- with
- Invalid_argument _ -> false,ugraph
- )
- | (C.Const (uri1,exp_named_subst1), C.Const (uri2,exp_named_subst2)) ->
- let b' = U.eq uri1 uri2 in
- if b' then
- (try
- List.fold_right2
- (fun (uri1,x) (uri2,y) (b,ugraph) ->
- if b && U.eq uri1 uri2 then
- aux test_equality_only context x y ugraph
- else
- false,ugraph
- ) exp_named_subst1 exp_named_subst2 (true,ugraph)
- with
- Invalid_argument _ -> false,ugraph
- )
- else
- false,ugraph
- | (C.MutInd (uri1,i1,exp_named_subst1),
- C.MutInd (uri2,i2,exp_named_subst2)
- ) ->
- let b' = U.eq uri1 uri2 && i1 = i2 in
- if b' then
- (try
- List.fold_right2
- (fun (uri1,x) (uri2,y) (b,ugraph) ->
- if b && U.eq uri1 uri2 then
- aux test_equality_only context x y ugraph
- else
- false,ugraph
- ) exp_named_subst1 exp_named_subst2 (true,ugraph)
- with
- Invalid_argument _ -> false,ugraph
- )
- else
- false,ugraph
- | (C.MutConstruct (uri1,i1,j1,exp_named_subst1),
- C.MutConstruct (uri2,i2,j2,exp_named_subst2)
- ) ->
- let b' = U.eq uri1 uri2 && i1 = i2 && j1 = j2 in
- if b' then
- (try
- List.fold_right2
- (fun (uri1,x) (uri2,y) (b,ugraph) ->
- if b && U.eq uri1 uri2 then
- aux test_equality_only context x y ugraph
- else
- false,ugraph
- ) exp_named_subst1 exp_named_subst2 (true,ugraph)
- with
- Invalid_argument _ -> false,ugraph
- )
- else
- false,ugraph
- | (C.MutCase (uri1,i1,outtype1,term1,pl1),
- C.MutCase (uri2,i2,outtype2,term2,pl2)) ->
- let b' = U.eq uri1 uri2 && i1 = i2 in
- if b' then
- let b'',ugraph''=aux test_equality_only context
- outtype1 outtype2 ugraph in
- if b'' then
- let b''',ugraph'''= aux test_equality_only context
- term1 term2 ugraph'' in
- List.fold_right2
- (fun x y (b,ugraph) ->
- if b then
- aux test_equality_only context x y ugraph
- else
- false,ugraph)
- pl1 pl2 (b''',ugraph''')
- else
- false,ugraph
- else
- false,ugraph
- | (C.Fix (i1,fl1), C.Fix (i2,fl2)) ->
- let tys =
- List.map (function (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl1
- in
- if i1 = i2 then
- List.fold_right2
- (fun (_,recindex1,ty1,bo1) (_,recindex2,ty2,bo2) (b,ugraph) ->
- if b && recindex1 = recindex2 then
- let b',ugraph' = aux test_equality_only context ty1 ty2
- ugraph in
- if b' then
- aux test_equality_only (tys@context) bo1 bo2 ugraph'
- else
- false,ugraph
- else
- false,ugraph)
- fl1 fl2 (true,ugraph)
- else
- false,ugraph
- | (C.CoFix (i1,fl1), C.CoFix (i2,fl2)) ->
- let tys =
- List.map (function (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl1
- in
- if i1 = i2 then
- List.fold_right2
- (fun (_,ty1,bo1) (_,ty2,bo2) (b,ugraph) ->
- if b then
- let b',ugraph' = aux test_equality_only context ty1 ty2
- ugraph in
- if b' then
- aux test_equality_only (tys@context) bo1 bo2 ugraph'
- else
- false,ugraph
- else
- false,ugraph)
- fl1 fl2 (true,ugraph)
- else
- false,ugraph
- | (C.Cast _, _) | (_, C.Cast _)
- | (C.Implicit _, _) | (_, C.Implicit _) -> assert false
- | (_,_) -> false,ugraph
- end
- in
- debug t1 [t2] "PREWHD";
- let t1' = whd ?delta:(Some true) ?subst:(Some subst) context t1 in
- let t2' = whd ?delta:(Some true) ?subst:(Some subst) context t2 in
- debug t1' [t2'] "POSTWHD";
- aux2 test_equality_only t1' t2' ugraph
- in
- aux false (*c t1 t2 ugraph *)
-;;
-
-(* DEBUGGING ONLY
-let whd ?(delta=true) ?(subst=[]) context t =
- let res = whd ~delta ~subst context t in
- let rescsc = CicReductionNaif.whd ~delta ~subst context t in
- if not (fst (are_convertible CicReductionNaif.whd ~subst context res rescsc CicUniv.empty_ugraph)) then
- begin
- debug_print (lazy ("PRIMA: " ^ CicPp.ppterm t)) ;
- flush stderr ;
- debug_print (lazy ("DOPO: " ^ CicPp.ppterm res)) ;
- flush stderr ;
- debug_print (lazy ("CSC: " ^ CicPp.ppterm rescsc)) ;
- flush stderr ;
-fdebug := 0 ;
-let _ = are_convertible CicReductionNaif.whd ~subst context res rescsc CicUniv.empty_ugraph in
- assert false ;
- end
- else
- res
-;;
-*)
-
-let are_convertible = are_convertible whd
-
-let whd = R.whd
-
-(*
-let profiler_other_whd = HExtlib.profile ~enable:profile "~are_convertible.whd"
-let whd ?(delta=true) ?(subst=[]) context t =
- let foo () =
- whd ~delta ~subst context t
- in
- profiler_other_whd.HExtlib.profile foo ()
-*)
-
-let rec normalize ?(delta=true) ?(subst=[]) ctx term =
- let module C = Cic in
- let t = whd ~delta ~subst ctx term in
- let aux = normalize ~delta ~subst in
- let decl name t = Some (name, C.Decl t) in
- match t with
- | C.Rel n -> t
- | C.Var (uri,exp_named_subst) ->
- C.Var (uri, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst)
- | C.Meta (i,l) ->
- C.Meta (i,List.map (function Some t -> Some (aux ctx t) | None -> None) l)
- | C.Sort _ -> t
- | C.Implicit _ -> t
- | C.Cast (te,ty) -> C.Cast (aux ctx te, aux ctx ty)
- | C.Prod (n,s,t) ->
- let s' = aux ctx s in
- C.Prod (n, s', aux ((decl n s')::ctx) t)
- | C.Lambda (n,s,t) ->
- let s' = aux ctx s in
- C.Lambda (n, s', aux ((decl n s')::ctx) t)
- | C.LetIn (n,s,t) ->
- (* the term is already in weak head normal form *)
- assert false
- | C.Appl (h::l) -> C.Appl (h::(List.map (aux ctx) l))
- | C.Appl [] -> assert false
- | C.Const (uri,exp_named_subst) ->
- C.Const (uri, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst)
- | C.MutInd (uri,typeno,exp_named_subst) ->
- C.MutInd (uri,typeno, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst)
- | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
- C.MutConstruct (uri, typeno, consno,
- List.map (fun (n,t) -> n,aux ctx t) exp_named_subst)
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i, aux ctx outt, aux ctx t, List.map (aux ctx) pl)
-(*CSC: to be completed, I suppose *)
- | C.Fix _ -> t
- | C.CoFix _ -> t
-
-let normalize ?delta ?subst ctx term =
-(* prerr_endline ("NORMALIZE:" ^ CicPp.ppterm term); *)
- let t = normalize ?delta ?subst ctx term in
-(* prerr_endline ("NORMALIZED:" ^ CicPp.ppterm t); *)
- t
-
-
-(* performs an head beta/cast reduction *)
-let rec head_beta_reduce =
- function
- (Cic.Appl (Cic.Lambda (_,_,t)::he'::tl')) ->
- let he'' = CicSubstitution.subst he' t in
- if tl' = [] then
- he''
- else
- let he''' =
- match he'' with
- Cic.Appl l -> Cic.Appl (l@tl')
- | _ -> Cic.Appl (he''::tl')
- in
- head_beta_reduce he'''
- | Cic.Cast (te,_) -> head_beta_reduce te
- | t -> t
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception 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
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-exception CannotSubstInMeta;;
-exception RelToHiddenHypothesis;;
-exception ReferenceToVariable;;
-exception ReferenceToConstant;;
-exception ReferenceToCurrentProof;;
-exception ReferenceToInductiveDefinition;;
-
-let debug_print = fun _ -> ()
-
-let lift_from k n =
- let rec liftaux k =
- let module C = Cic in
- function
- C.Rel m ->
- if m < k then
- C.Rel m
- else
- C.Rel (m + n)
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
- in
- C.Var (uri,exp_named_subst')
- | C.Meta (i,l) ->
- let l' =
- List.map
- (function
- None -> None
- | Some t -> Some (liftaux k t)
- ) l
- in
- C.Meta(i,l')
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (liftaux k te, liftaux k ty)
- | C.Prod (n,s,t) -> C.Prod (n, liftaux k s, liftaux (k+1) t)
- | C.Lambda (n,s,t) -> C.Lambda (n, liftaux k s, liftaux (k+1) t)
- | C.LetIn (n,s,t) -> C.LetIn (n, liftaux k s, liftaux (k+1) t)
- | C.Appl l -> C.Appl (List.map (liftaux k) l)
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
- in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,tyno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
- in
- C.MutInd (uri,tyno,exp_named_subst')
- | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
- in
- C.MutConstruct (uri,tyno,consno,exp_named_subst')
- | C.MutCase (sp,i,outty,t,pl) ->
- C.MutCase (sp, i, liftaux k outty, liftaux k t,
- List.map (liftaux k) pl)
- | C.Fix (i, fl) ->
- let len = List.length fl in
- let liftedfl =
- List.map
- (fun (name, i, ty, bo) -> (name, i, liftaux k ty, liftaux (k+len) bo))
- fl
- in
- C.Fix (i, liftedfl)
- | C.CoFix (i, fl) ->
- let len = List.length fl in
- let liftedfl =
- List.map
- (fun (name, ty, bo) -> (name, liftaux k ty, liftaux (k+len) bo))
- fl
- in
- C.CoFix (i, liftedfl)
- in
- liftaux k
-
-let lift n t =
- if n = 0 then
- t
- else
- lift_from 1 n t
-;;
-
-let subst arg =
- let rec substaux k =
- let module C = Cic in
- function
- C.Rel n as t ->
- (match n with
- n when n = k -> lift (k - 1) arg
- | n when n < k -> t
- | _ -> C.Rel (n - 1)
- )
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst
- in
- C.Var (uri,exp_named_subst')
- | C.Meta (i, l) ->
- let l' =
- List.map
- (function
- None -> None
- | Some t -> Some (substaux k t)
- ) l
- in
- C.Meta(i,l')
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
- | C.Prod (n,s,t) -> C.Prod (n, substaux k s, substaux (k + 1) t)
- | C.Lambda (n,s,t) -> C.Lambda (n, substaux k s, substaux (k + 1) t)
- | C.LetIn (n,s,t) -> C.LetIn (n, substaux k s, substaux (k + 1) t)
- | C.Appl (he::tl) ->
- (* Invariant: no Appl applied to another Appl *)
- let tl' = List.map (substaux k) tl in
- begin
- match substaux k he with
- C.Appl l -> C.Appl (l@tl')
- | _ as he' -> C.Appl (he'::tl')
- end
- | C.Appl _ -> assert false
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst
- in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,typeno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst
- in
- C.MutInd (uri,typeno,exp_named_subst')
- | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst
- in
- C.MutConstruct (uri,typeno,consno,exp_named_subst')
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i,substaux k outt, substaux k t,
- List.map (substaux k) pl)
- | C.Fix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) -> (name, i, substaux k ty, substaux (k+len) bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (name, substaux k ty, substaux (k+len) bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- in
- substaux 1
-;;
-
-(*CSC: i controlli di tipo debbono essere svolti da destra a *)
-(*CSC: sinistra: i{B/A;b/a} ==> a{B/A;b/a} ==> a{b/a{B/A}} ==> b *)
-(*CSC: la sostituzione ora e' implementata in maniera simultanea, ma *)
-(*CSC: dovrebbe diventare da sinistra verso destra: *)
-(*CSC: t{a=a/A;b/a} ==> \H:a=a.H{b/a} ==> \H:b=b.H *)
-(*CSC: per la roba che proviene da Coq questo non serve! *)
-let subst_vars exp_named_subst t =
-(*
-debug_print (lazy ("@@@POSSIBLE BUG: SUBSTITUTION IS NOT SIMULTANEOUS")) ;
-*)
- let rec substaux k =
- let module C = Cic in
- function
- C.Rel _ as t -> t
- | C.Var (uri,exp_named_subst') ->
- (try
- let (_,arg) =
- List.find
- (function (varuri,_) -> UriManager.eq uri varuri) exp_named_subst
- in
- lift (k -1) arg
- with
- Not_found ->
- let params =
- let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- (match obj with
- C.Constant _ -> raise ReferenceToConstant
- | C.Variable (_,_,_,params,_) -> params
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- in
-(*
-debug_print (lazy "\n\n---- BEGIN ") ;
-debug_print (lazy ("----params: " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ;
-debug_print (lazy ("----S(" ^ UriManager.string_of_uri uri ^ "): " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst))) ;
-debug_print (lazy ("----P: " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst'))) ;
-*)
- let exp_named_subst'' =
- substaux_in_exp_named_subst uri k exp_named_subst' params
- in
-(*
-debug_print (lazy ("----D: " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst''))) ;
-debug_print (lazy "---- END\n\n ") ;
-*)
- C.Var (uri,exp_named_subst'')
- )
- | C.Meta (i, l) ->
- let l' =
- List.map
- (function
- None -> None
- | Some t -> Some (substaux k t)
- ) l
- in
- C.Meta(i,l')
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
- | C.Prod (n,s,t) -> C.Prod (n, substaux k s, substaux (k + 1) t)
- | C.Lambda (n,s,t) -> C.Lambda (n, substaux k s, substaux (k + 1) t)
- | C.LetIn (n,s,t) -> C.LetIn (n, substaux k s, substaux (k + 1) t)
- | C.Appl (he::tl) ->
- (* Invariant: no Appl applied to another Appl *)
- let tl' = List.map (substaux k) tl in
- begin
- match substaux k he with
- C.Appl l -> C.Appl (l@tl')
- | _ as he' -> C.Appl (he'::tl')
- end
- | C.Appl _ -> assert false
- | C.Const (uri,exp_named_subst') ->
- let params =
- let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- (match obj with
- C.Constant (_,_,_,params,_) -> params
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof (_,_,_,_,params,_) -> params
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- in
- let exp_named_subst'' =
- substaux_in_exp_named_subst uri k exp_named_subst' params
- in
- C.Const (uri,exp_named_subst'')
- | C.MutInd (uri,typeno,exp_named_subst') ->
- let params =
- let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- (match obj with
- C.Constant _ -> raise ReferenceToConstant
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition (_,params,_,_) -> params
- )
- in
- let exp_named_subst'' =
- substaux_in_exp_named_subst uri k exp_named_subst' params
- in
- C.MutInd (uri,typeno,exp_named_subst'')
- | C.MutConstruct (uri,typeno,consno,exp_named_subst') ->
- let params =
- let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- (match obj with
- C.Constant _ -> raise ReferenceToConstant
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition (_,params,_,_) -> params
- )
- in
- let exp_named_subst'' =
- substaux_in_exp_named_subst uri k exp_named_subst' params
- in
- C.MutConstruct (uri,typeno,consno,exp_named_subst'')
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i,substaux k outt, substaux k t,
- List.map (substaux k) pl)
- | C.Fix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) -> (name, i, substaux k ty, substaux (k+len) bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (name, substaux k ty, substaux (k+len) bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- and substaux_in_exp_named_subst uri k exp_named_subst' params =
-(*CSC: invece di concatenare sarebbe meglio rispettare l'ordine dei params *)
-(*CSC: e' vero???? una veloce prova non sembra confermare la teoria *)
- let rec filter_and_lift =
- function
- [] -> []
- | (uri,t)::tl when
- List.for_all
- (function (uri',_) -> not (UriManager.eq uri uri')) exp_named_subst'
- &&
- List.mem uri params
- ->
- (uri,lift (k-1) t)::(filter_and_lift tl)
- | _::tl -> filter_and_lift tl
-(*
- | (uri,_)::tl ->
-debug_print (lazy ("---- SKIPPO " ^ UriManager.string_of_uri uri)) ;
-if List.for_all (function (uri',_) -> not (UriManager.eq uri uri'))
-exp_named_subst' then debug_print (lazy "---- OK1") ;
-debug_print (lazy ("++++ uri " ^ UriManager.string_of_uri uri ^ " not in " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ;
-if List.mem uri params then debug_print (lazy "---- OK2") ;
- filter_and_lift tl
-*)
- in
- List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst' @
- (filter_and_lift exp_named_subst)
- in
- if exp_named_subst = [] then t
- else substaux 1 t
-;;
-
-(* subst_meta [t_1 ; ... ; t_n] t *)
-(* returns the term [t] where [Rel i] is substituted with [t_i] *)
-(* [t_i] is lifted as usual when it crosses an abstraction *)
-let subst_meta l t =
- let module C = Cic in
- if l = [] then t else
- let rec aux k = function
- C.Rel n as t ->
- if n <= k then t else
- (try
- match List.nth l (n-k-1) with
- None -> raise RelToHiddenHypothesis
- | Some t -> lift k t
- with
- (Failure _) -> assert false
- )
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
- in
- C.Var (uri,exp_named_subst')
- | C.Meta (i,l) ->
- let l' =
- List.map
- (function
- None -> None
- | Some t ->
- try
- Some (aux k t)
- with
- RelToHiddenHypothesis -> None
- ) l
- in
- C.Meta(i,l')
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty) (*CSC ??? *)
- | C.Prod (n,s,t) -> C.Prod (n, aux k s, aux (k + 1) t)
- | C.Lambda (n,s,t) -> C.Lambda (n, aux k s, aux (k + 1) t)
- | C.LetIn (n,s,t) -> C.LetIn (n, aux k s, aux (k + 1) t)
- | C.Appl l -> C.Appl (List.map (aux k) l)
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
- in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,typeno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
- in
- C.MutInd (uri,typeno,exp_named_subst')
- | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
- in
- C.MutConstruct (uri,typeno,consno,exp_named_subst')
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i,aux k outt, aux k t, List.map (aux k) pl)
- | C.Fix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) -> (name, i, aux k ty, aux (k+len) bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (name, aux k ty, aux (k+len) bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- in
- aux 0 t
-;;
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception 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
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-(* TODO factorize functions to frequent errors (e.g. "Unknwon mutual inductive
- * ...") *)
-
-open Printf
-
-exception AssertFailure of string Lazy.t;;
-exception TypeCheckerFailure of string Lazy.t;;
-
-let fdebug = ref 0;;
-let debug t context =
- let rec debug_aux t i =
- let module C = Cic in
- let module U = UriManager in
- CicPp.ppobj (C.Variable ("DEBUG", None, t, [], [])) ^ "\n" ^ i
- in
- if !fdebug = 0 then
- raise (TypeCheckerFailure (lazy (List.fold_right debug_aux (t::context) "")))
-;;
-
-let debug_print = fun _ -> ();;
-
-let rec split l n =
- match (l,n) with
- (l,0) -> ([], l)
- | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2)
- | (_,_) ->
- raise (TypeCheckerFailure (lazy "Parameters number < left parameters number"))
-;;
-
-let debrujin_constructor ?(cb=fun _ _ -> ()) uri number_of_types =
- let rec aux k t =
- let module C = Cic in
- let res =
- match t with
- C.Rel n as t when n <= k -> t
- | C.Rel _ ->
- raise (TypeCheckerFailure (lazy "unbound variable found in constructor type"))
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
- in
- C.Var (uri,exp_named_subst')
- | C.Meta (i,l) ->
- let l' = List.map (function None -> None | Some t -> Some (aux k t)) l in
- C.Meta (i,l')
- | C.Sort _
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty)
- | C.Prod (n,s,t) -> C.Prod (n, aux k s, aux (k+1) t)
- | C.Lambda (n,s,t) -> C.Lambda (n, aux k s, aux (k+1) t)
- | C.LetIn (n,s,t) -> C.LetIn (n, aux k s, aux (k+1) t)
- | C.Appl l -> C.Appl (List.map (aux k) l)
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
- in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri',tyno,exp_named_subst) when UriManager.eq uri uri' ->
- if exp_named_subst != [] then
- raise (TypeCheckerFailure
- (lazy ("non-empty explicit named substitution is applied to "^
- "a mutual inductive type which is being defined"))) ;
- C.Rel (k + number_of_types - tyno) ;
- | C.MutInd (uri',tyno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
- in
- C.MutInd (uri',tyno,exp_named_subst')
- | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
- in
- C.MutConstruct (uri,tyno,consno,exp_named_subst')
- | C.MutCase (sp,i,outty,t,pl) ->
- C.MutCase (sp, i, aux k outty, aux k t,
- List.map (aux k) pl)
- | C.Fix (i, fl) ->
- let len = List.length fl in
- let liftedfl =
- List.map
- (fun (name, i, ty, bo) -> (name, i, aux k ty, aux (k+len) bo))
- fl
- in
- C.Fix (i, liftedfl)
- | C.CoFix (i, fl) ->
- let len = List.length fl in
- let liftedfl =
- List.map
- (fun (name, ty, bo) -> (name, aux k ty, aux (k+len) bo))
- fl
- in
- C.CoFix (i, liftedfl)
- in
- cb t res;
- res
- in
- aux 0
-;;
-
-exception CicEnvironmentError;;
-
-let rec type_of_constant ~logger uri ugraph =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let cobj,ugraph =
- match CicEnvironment.is_type_checked ~trust:true ugraph uri with
- CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph'
- | CicEnvironment.UncheckedObj uobj ->
- logger#log (`Start_type_checking uri) ;
- (* let's typecheck the uncooked obj *)
-
-(****************************************************************
- TASSI: FIXME qui e' inutile ricordarselo,
- tanto poi lo richiediamo alla cache che da quello su disco
-*****************************************************************)
-
- let ugraph_dust =
- (match uobj with
- C.Constant (_,Some te,ty,_,_) ->
- let _,ugraph = type_of ~logger ty ugraph in
- let type_of_te,ugraph' = type_of ~logger te ugraph in
- let b',ugraph'' = (R.are_convertible [] type_of_te ty ugraph') in
- if not b' then
- raise (TypeCheckerFailure (lazy (sprintf
- "the constant %s is not well typed because the type %s of the body is not convertible to the declared type %s"
- (U.string_of_uri uri) (CicPp.ppterm type_of_te)
- (CicPp.ppterm ty))))
- else
- ugraph'
- | C.Constant (_,None,ty,_,_) ->
- (* only to check that ty is well-typed *)
- let _,ugraph' = type_of ~logger ty ugraph in
- ugraph'
- | C.CurrentProof (_,conjs,te,ty,_,_) ->
- let _,ugraph1 =
- List.fold_left
- (fun (metasenv,ugraph) ((_,context,ty) as conj) ->
- let _,ugraph' =
- type_of_aux' ~logger metasenv context ty ugraph
- in
- (metasenv @ [conj],ugraph')
- ) ([],ugraph) conjs
- in
- let _,ugraph2 = type_of_aux' ~logger conjs [] ty ugraph1 in
- let type_of_te,ugraph3 =
- type_of_aux' ~logger conjs [] te ugraph2
- in
- let b,ugraph4 = (R.are_convertible [] type_of_te ty ugraph3) in
- if not b then
- raise (TypeCheckerFailure (lazy (sprintf
- "the current proof %s is not well typed because the type %s of the body is not convertible to the declared type %s"
- (U.string_of_uri uri) (CicPp.ppterm type_of_te)
- (CicPp.ppterm ty))))
- else
- ugraph4
- | _ ->
- raise
- (TypeCheckerFailure (lazy ("Unknown constant:" ^ U.string_of_uri uri))))
- in
- try
- CicEnvironment.set_type_checking_info uri;
- logger#log (`Type_checking_completed uri) ;
- match CicEnvironment.is_type_checked ~trust:false ugraph uri with
- CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph'
- | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError
- with Invalid_argument s ->
- (*debug_print (lazy s);*)
- uobj,ugraph_dust
- in
- match cobj,ugraph with
- (C.Constant (_,_,ty,_,_)),g -> ty,g
- | (C.CurrentProof (_,_,_,ty,_,_)),g -> ty,g
- | _ ->
- raise (TypeCheckerFailure (lazy ("Unknown constant:" ^ U.string_of_uri uri)))
-
-and type_of_variable ~logger uri ugraph =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- (* 0 because a variable is never cooked => no partial cooking at one level *)
- match CicEnvironment.is_type_checked ~trust:true ugraph uri with
- CicEnvironment.CheckedObj ((C.Variable (_,_,ty,_,_)),ugraph') -> ty,ugraph'
- | CicEnvironment.UncheckedObj (C.Variable (_,bo,ty,_,_)) ->
- logger#log (`Start_type_checking uri) ;
- (* only to check that ty is well-typed *)
- let _,ugraph1 = type_of ~logger ty ugraph in
- let ugraph2 =
- (match bo with
- None -> ugraph
- | Some bo ->
- let ty_bo,ugraph' = type_of ~logger bo ugraph1 in
- let b,ugraph'' = (R.are_convertible [] ty_bo ty ugraph') in
- if not b then
- raise (TypeCheckerFailure
- (lazy ("Unknown variable:" ^ U.string_of_uri uri)))
- else
- ugraph'')
- in
- (try
- CicEnvironment.set_type_checking_info uri ;
- logger#log (`Type_checking_completed uri) ;
- match CicEnvironment.is_type_checked ~trust:false ugraph uri with
- CicEnvironment.CheckedObj ((C.Variable (_,_,ty,_,_)),ugraph') ->
- ty,ugraph'
- | CicEnvironment.CheckedObj _
- | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError
- with Invalid_argument s ->
- (*debug_print (lazy s);*)
- ty,ugraph2)
- | _ ->
- raise (TypeCheckerFailure (lazy ("Unknown variable:" ^ U.string_of_uri uri)))
-
-and does_not_occur ?(subst=[]) context n nn te =
- let module C = Cic in
- (*CSC: whd sembra essere superflua perche' un caso in cui l'occorrenza *)
- (*CSC: venga mangiata durante la whd sembra presentare problemi di *)
- (*CSC: universi *)
- match CicReduction.whd ~subst context te with
- C.Rel m when m > n && m <= nn -> false
- | C.Rel _
- | C.Sort _
- | C.Implicit _ -> true
- | C.Meta (_,l) ->
- List.fold_right
- (fun x i ->
- match x with
- None -> i
- | Some x -> i && does_not_occur ~subst context n nn x) l true
- | C.Cast (te,ty) ->
- does_not_occur ~subst context n nn te && does_not_occur ~subst context n nn ty
- | C.Prod (name,so,dest) ->
- does_not_occur ~subst context n nn so &&
- does_not_occur ~subst ((Some (name,(C.Decl so)))::context) (n + 1)
- (nn + 1) dest
- | C.Lambda (name,so,dest) ->
- does_not_occur ~subst context n nn so &&
- does_not_occur ~subst ((Some (name,(C.Decl so)))::context) (n + 1) (nn + 1)
- dest
- | C.LetIn (name,so,dest) ->
- does_not_occur ~subst context n nn so &&
- does_not_occur ~subst ((Some (name,(C.Def (so,None))))::context)
- (n + 1) (nn + 1) dest
- | C.Appl l ->
- List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) l true
- | C.Var (_,exp_named_subst)
- | C.Const (_,exp_named_subst)
- | C.MutInd (_,_,exp_named_subst)
- | C.MutConstruct (_,_,_,exp_named_subst) ->
- List.fold_right (fun (_,x) i -> i && does_not_occur ~subst context n nn x)
- exp_named_subst true
- | C.MutCase (_,_,out,te,pl) ->
- does_not_occur ~subst context n nn out && does_not_occur ~subst context n nn te &&
- List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) pl true
- | C.Fix (_,fl) ->
- let len = List.length fl in
- let n_plus_len = n + len in
- let nn_plus_len = nn + len in
- let tys =
- List.map (fun (n,_,ty,_) -> Some (C.Name n,(Cic.Decl ty))) fl
- in
- List.fold_right
- (fun (_,_,ty,bo) i ->
- i && does_not_occur ~subst context n nn ty &&
- does_not_occur ~subst (tys @ context) n_plus_len nn_plus_len bo
- ) fl true
- | C.CoFix (_,fl) ->
- let len = List.length fl in
- let n_plus_len = n + len in
- let nn_plus_len = nn + len in
- let tys =
- List.map (fun (n,ty,_) -> Some (C.Name n,(Cic.Decl ty))) fl
- in
- List.fold_right
- (fun (_,ty,bo) i ->
- i && does_not_occur ~subst context n nn ty &&
- does_not_occur ~subst (tys @ context) n_plus_len nn_plus_len bo
- ) fl true
-
-(*CSC l'indice x dei tipi induttivi e' t.c. n < x <= nn *)
-(*CSC questa funzione e' simile alla are_all_occurrences_positive, ma fa *)
-(*CSC dei controlli leggermente diversi. Viene invocata solamente dalla *)
-(*CSC strictly_positive *)
-(*CSC definizione (giusta???) tratta dalla mail di Hugo ;-) *)
-and weakly_positive context n nn uri te =
- let module C = Cic in
-(*CSC: Che schifo! Bisogna capire meglio e trovare una soluzione ragionevole!*)
- let dummy_mutind =
- C.MutInd (HelmLibraryObjects.Datatypes.nat_URI,0,[])
- in
- (*CSC: mettere in cicSubstitution *)
- let rec subst_inductive_type_with_dummy_mutind =
- function
- C.MutInd (uri',0,_) when UriManager.eq uri' uri ->
- dummy_mutind
- | C.Appl ((C.MutInd (uri',0,_))::tl) when UriManager.eq uri' uri ->
- dummy_mutind
- | C.Cast (te,ty) -> subst_inductive_type_with_dummy_mutind te
- | C.Prod (name,so,ta) ->
- C.Prod (name, subst_inductive_type_with_dummy_mutind so,
- subst_inductive_type_with_dummy_mutind ta)
- | C.Lambda (name,so,ta) ->
- C.Lambda (name, subst_inductive_type_with_dummy_mutind so,
- subst_inductive_type_with_dummy_mutind ta)
- | C.Appl tl ->
- C.Appl (List.map subst_inductive_type_with_dummy_mutind tl)
- | C.MutCase (uri,i,outtype,term,pl) ->
- C.MutCase (uri,i,
- subst_inductive_type_with_dummy_mutind outtype,
- subst_inductive_type_with_dummy_mutind term,
- List.map subst_inductive_type_with_dummy_mutind pl)
- | C.Fix (i,fl) ->
- C.Fix (i,List.map (fun (name,i,ty,bo) -> (name,i,
- subst_inductive_type_with_dummy_mutind ty,
- subst_inductive_type_with_dummy_mutind bo)) fl)
- | C.CoFix (i,fl) ->
- C.CoFix (i,List.map (fun (name,ty,bo) -> (name,
- subst_inductive_type_with_dummy_mutind ty,
- subst_inductive_type_with_dummy_mutind bo)) fl)
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map
- (function (uri,t) -> (uri,subst_inductive_type_with_dummy_mutind t))
- exp_named_subst
- in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,typeno,exp_named_subst) ->
- let exp_named_subst' =
- List.map
- (function (uri,t) -> (uri,subst_inductive_type_with_dummy_mutind t))
- exp_named_subst
- in
- C.MutInd (uri,typeno,exp_named_subst')
- | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
- let exp_named_subst' =
- List.map
- (function (uri,t) -> (uri,subst_inductive_type_with_dummy_mutind t))
- exp_named_subst
- in
- C.MutConstruct (uri,typeno,consno,exp_named_subst')
- | t -> t
- in
- match CicReduction.whd context te with
- C.Appl ((C.MutInd (uri',0,_))::tl) when UriManager.eq uri' uri -> true
- | C.MutInd (uri',0,_) when UriManager.eq uri' uri -> true
- | C.Prod (C.Anonymous,source,dest) ->
- strictly_positive context n nn
- (subst_inductive_type_with_dummy_mutind source) &&
- weakly_positive ((Some (C.Anonymous,(C.Decl source)))::context)
- (n + 1) (nn + 1) uri dest
- | C.Prod (name,source,dest) when
- does_not_occur ((Some (name,(C.Decl source)))::context) 0 n dest ->
- (* dummy abstraction, so we behave as in the anonimous case *)
- strictly_positive context n nn
- (subst_inductive_type_with_dummy_mutind source) &&
- weakly_positive ((Some (name,(C.Decl source)))::context)
- (n + 1) (nn + 1) uri dest
- | C.Prod (name,source,dest) ->
- does_not_occur context n nn
- (subst_inductive_type_with_dummy_mutind source)&&
- weakly_positive ((Some (name,(C.Decl source)))::context)
- (n + 1) (nn + 1) uri dest
- | _ ->
- raise (TypeCheckerFailure (lazy "Malformed inductive constructor type"))
-
-(* instantiate_parameters ps (x1:T1)...(xn:Tn)C *)
-(* returns ((x_|ps|:T_|ps|)...(xn:Tn)C){ps_1 / x1 ; ... ; ps_|ps| / x_|ps|} *)
-and instantiate_parameters params c =
- let module C = Cic in
- match (c,params) with
- (c,[]) -> c
- | (C.Prod (_,_,ta), he::tl) ->
- instantiate_parameters tl
- (CicSubstitution.subst he ta)
- | (C.Cast (te,_), _) -> instantiate_parameters params te
- | (t,l) -> raise (AssertFailure (lazy "1"))
-
-and strictly_positive context n nn te =
- let module C = Cic in
- let module U = UriManager in
- match CicReduction.whd context te with
- C.Rel _ -> true
- | C.Cast (te,ty) ->
- (*CSC: bisogna controllare ty????*)
- strictly_positive context n nn te
- | C.Prod (name,so,ta) ->
- does_not_occur context n nn so &&
- strictly_positive ((Some (name,(C.Decl so)))::context) (n+1) (nn+1) ta
- | C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
- List.fold_right (fun x i -> i && does_not_occur context n nn x) tl true
- | C.Appl ((C.MutInd (uri,i,exp_named_subst))::tl) ->
- let (ok,paramsno,ity,cl,name) =
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.InductiveDefinition (tl,_,paramsno,_) ->
- let (name,_,ity,cl) = List.nth tl i in
- (List.length tl = 1, paramsno, ity, cl, name)
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown inductive type:" ^ U.string_of_uri uri)))
- in
- let (params,arguments) = split tl paramsno in
- let lifted_params = List.map (CicSubstitution.lift 1) params in
- let cl' =
- List.map
- (fun (_,te) ->
- instantiate_parameters lifted_params
- (CicSubstitution.subst_vars exp_named_subst te)
- ) cl
- in
- ok &&
- List.fold_right
- (fun x i -> i && does_not_occur context n nn x)
- arguments true &&
- (*CSC: MEGAPATCH3 (sara' quella giusta?)*)
- List.fold_right
- (fun x i ->
- i &&
- weakly_positive
- ((Some (C.Name name,(Cic.Decl ity)))::context) (n+1) (nn+1) uri
- x
- ) cl' true
- | t -> does_not_occur context n nn t
-
-(* the inductive type indexes are s.t. n < x <= nn *)
-and are_all_occurrences_positive context uri indparamsno i n nn te =
- let module C = Cic in
- match CicReduction.whd context te with
- C.Appl ((C.Rel m)::tl) when m = i ->
- (*CSC: riscrivere fermandosi a 0 *)
- (* let's check if the inductive type is applied at least to *)
- (* indparamsno parameters *)
- let last =
- List.fold_left
- (fun k x ->
- if k = 0 then 0
- else
- match CicReduction.whd context x with
- C.Rel m when m = n - (indparamsno - k) -> k - 1
- | _ ->
- raise (TypeCheckerFailure
- (lazy
- ("Non-positive occurence in mutual inductive definition(s) [1]" ^
- UriManager.string_of_uri uri)))
- ) indparamsno tl
- in
- if last = 0 then
- List.fold_right (fun x i -> i && does_not_occur context n nn x) tl true
- else
- raise (TypeCheckerFailure
- (lazy ("Non-positive occurence in mutual inductive definition(s) [2]"^
- UriManager.string_of_uri uri)))
- | C.Rel m when m = i ->
- if indparamsno = 0 then
- true
- else
- raise (TypeCheckerFailure
- (lazy ("Non-positive occurence in mutual inductive definition(s) [3]"^
- UriManager.string_of_uri uri)))
- | C.Prod (C.Anonymous,source,dest) ->
- strictly_positive context n nn source &&
- are_all_occurrences_positive
- ((Some (C.Anonymous,(C.Decl source)))::context) uri indparamsno
- (i+1) (n + 1) (nn + 1) dest
- | C.Prod (name,source,dest) when
- does_not_occur ((Some (name,(C.Decl source)))::context) 0 n dest ->
- (* dummy abstraction, so we behave as in the anonimous case *)
- strictly_positive context n nn source &&
- are_all_occurrences_positive
- ((Some (name,(C.Decl source)))::context) uri indparamsno
- (i+1) (n + 1) (nn + 1) dest
- | C.Prod (name,source,dest) ->
- does_not_occur context n nn source &&
- are_all_occurrences_positive ((Some (name,(C.Decl source)))::context)
- uri indparamsno (i+1) (n + 1) (nn + 1) dest
- | _ ->
- raise
- (TypeCheckerFailure (lazy ("Malformed inductive constructor type " ^
- (UriManager.string_of_uri uri))))
-
-(* Main function to checks the correctness of a mutual *)
-(* inductive block definition. This is the function *)
-(* exported to the proof-engine. *)
-and typecheck_mutual_inductive_defs ~logger uri (itl,_,indparamsno) ugraph =
- let module U = UriManager in
- (* let's check if the arity of the inductive types are well *)
- (* formed *)
- let ugrap1 = List.fold_left
- (fun ugraph (_,_,x,_) -> let _,ugraph' =
- type_of ~logger x ugraph in ugraph')
- ugraph itl in
-
- (* let's check if the types of the inductive constructors *)
- (* are well formed. *)
- (* In order not to use type_of_aux we put the types of the *)
- (* mutual inductive types at the head of the types of the *)
- (* constructors using Prods *)
- let len = List.length itl in
- let tys =
- List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) itl in
- let _,ugraph2 =
- List.fold_right
- (fun (_,_,_,cl) (i,ugraph) ->
- let ugraph'' =
- List.fold_left
- (fun ugraph (name,te) ->
- let debrujinedte = debrujin_constructor uri len te in
- let augmented_term =
- List.fold_right
- (fun (name,_,ty,_) i -> Cic.Prod (Cic.Name name, ty, i))
- itl debrujinedte
- in
- let _,ugraph' = type_of ~logger augmented_term ugraph in
- (* let's check also the positivity conditions *)
- if
- not
- (are_all_occurrences_positive tys uri indparamsno i 0 len
- debrujinedte)
- then
- raise
- (TypeCheckerFailure
- (lazy ("Non positive occurence in " ^ U.string_of_uri uri)))
- else
- ugraph'
- ) ugraph cl in
- (i + 1),ugraph''
- ) itl (1,ugrap1)
- in
- ugraph2
-
-(* Main function to checks the correctness of a mutual *)
-(* inductive block definition. *)
-and check_mutual_inductive_defs uri obj ugraph =
- match obj with
- Cic.InductiveDefinition (itl, params, indparamsno, _) ->
- typecheck_mutual_inductive_defs uri (itl,params,indparamsno) ugraph
- | _ ->
- raise (TypeCheckerFailure (
- lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
-
-and type_of_mutual_inductive_defs ~logger uri i ugraph =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let cobj,ugraph1 =
- match CicEnvironment.is_type_checked ~trust:true ugraph uri with
- CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph'
- | CicEnvironment.UncheckedObj uobj ->
- logger#log (`Start_type_checking uri) ;
- let ugraph1_dust =
- check_mutual_inductive_defs ~logger uri uobj ugraph
- in
- (* TASSI: FIXME: check ugraph1 == ugraph ritornato da env *)
- try
- CicEnvironment.set_type_checking_info uri ;
- logger#log (`Type_checking_completed uri) ;
- (match CicEnvironment.is_type_checked ~trust:false ugraph uri with
- CicEnvironment.CheckedObj (cobj,ugraph') -> (cobj,ugraph')
- | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError
- )
- with
- Invalid_argument s ->
- (*debug_print (lazy s);*)
- uobj,ugraph1_dust
- in
- match cobj with
- C.InductiveDefinition (dl,_,_,_) ->
- let (_,_,arity,_) = List.nth dl i in
- arity,ugraph1
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^ U.string_of_uri uri)))
-
-and type_of_mutual_inductive_constr ~logger uri i j ugraph =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let cobj,ugraph1 =
- match CicEnvironment.is_type_checked ~trust:true ugraph uri with
- CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph'
- | CicEnvironment.UncheckedObj uobj ->
- logger#log (`Start_type_checking uri) ;
- let ugraph1_dust =
- check_mutual_inductive_defs ~logger uri uobj ugraph
- in
- (* check ugraph1 validity ??? == ugraph' *)
- try
- CicEnvironment.set_type_checking_info uri ;
- logger#log (`Type_checking_completed uri) ;
- (match
- CicEnvironment.is_type_checked ~trust:false ugraph uri
- with
- CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph'
- | CicEnvironment.UncheckedObj _ ->
- raise CicEnvironmentError)
- with
- Invalid_argument s ->
- (*debug_print (lazy s);*)
- uobj,ugraph1_dust
- in
- match cobj with
- C.InductiveDefinition (dl,_,_,_) ->
- let (_,_,_,cl) = List.nth dl i in
- let (_,ty) = List.nth cl (j-1) in
- ty,ugraph1
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^ UriManager.string_of_uri uri)))
-
-and recursive_args context n nn te =
- let module C = Cic in
- match CicReduction.whd context te with
- C.Rel _ -> []
- | C.Var _
- | C.Meta _
- | C.Sort _
- | C.Implicit _
- | C.Cast _ (*CSC ??? *) ->
- raise (AssertFailure (lazy "3")) (* due to type-checking *)
- | C.Prod (name,so,de) ->
- (not (does_not_occur context n nn so)) ::
- (recursive_args ((Some (name,(C.Decl so)))::context) (n+1) (nn + 1) de)
- | C.Lambda _
- | C.LetIn _ ->
- raise (AssertFailure (lazy "4")) (* due to type-checking *)
- | C.Appl _ -> []
- | C.Const _ -> raise (AssertFailure (lazy "5"))
- | C.MutInd _
- | C.MutConstruct _
- | C.MutCase _
- | C.Fix _
- | C.CoFix _ -> raise (AssertFailure (lazy "6")) (* due to type-checking *)
-
-and get_new_safes ~subst context p c rl safes n nn x =
- let module C = Cic in
- let module U = UriManager in
- let module R = CicReduction in
- match (R.whd ~subst context c, R.whd ~subst context p, rl) with
- (C.Prod (_,so,ta1), C.Lambda (name,_,ta2), b::tl) ->
- (* we are sure that the two sources are convertible because we *)
- (* have just checked this. So let's go along ... *)
- let safes' =
- List.map (fun x -> x + 1) safes
- in
- let safes'' =
- if b then 1::safes' else safes'
- in
- get_new_safes ~subst ((Some (name,(C.Decl so)))::context)
- ta2 ta1 tl safes'' (n+1) (nn+1) (x+1)
- | (C.Prod _, (C.MutConstruct _ as e), _)
- | (C.Prod _, (C.Rel _ as e), _)
- | (C.MutInd _, e, [])
- | (C.Appl _, e, []) -> (e,safes,n,nn,x,context)
- | (c,p,l) ->
- (* CSC: If the next exception is raised, it just means that *)
- (* CSC: the proof-assistant allows to use very strange things *)
- (* CSC: as a branch of a case whose type is a Prod. In *)
- (* CSC: particular, this means that a new (C.Prod, x,_) case *)
- (* CSC: must be considered in this match. (e.g. x = MutCase) *)
- raise
- (AssertFailure (lazy
- (Printf.sprintf "Get New Safes: c=%s ; p=%s"
- (CicPp.ppterm c) (CicPp.ppterm p))))
-
-and split_prods ~subst context n te =
- let module C = Cic in
- let module R = CicReduction in
- match (n, R.whd ~subst context te) with
- (0, _) -> context,te
- | (n, C.Prod (name,so,ta)) when n > 0 ->
- split_prods ~subst ((Some (name,(C.Decl so)))::context) (n - 1) ta
- | (_, _) -> raise (AssertFailure (lazy "8"))
-
-and eat_lambdas ~subst context n te =
- let module C = Cic in
- let module R = CicReduction in
- match (n, R.whd ~subst context te) with
- (0, _) -> (te, 0, context)
- | (n, C.Lambda (name,so,ta)) when n > 0 ->
- let (te, k, context') =
- eat_lambdas ~subst ((Some (name,(C.Decl so)))::context) (n - 1) ta
- in
- (te, k + 1, context')
- | (n, te) ->
- raise (AssertFailure (lazy (sprintf "9 (%d, %s)" n (CicPp.ppterm te))))
-
-(*CSC: Tutto quello che segue e' l'intuzione di luca ;-) *)
-and check_is_really_smaller_arg ~subst context n nn kl x safes te =
- (*CSC: forse la whd si puo' fare solo quando serve veramente. *)
- (*CSC: cfr guarded_by_destructors *)
- let module C = Cic in
- let module U = UriManager in
- match CicReduction.whd ~subst context te with
- C.Rel m when List.mem m safes -> true
- | C.Rel _ -> false
- | C.Var _
- | C.Meta _
- | C.Sort _
- | C.Implicit _
- | C.Cast _
-(* | C.Cast (te,ty) ->
- check_is_really_smaller_arg ~subst n nn kl x safes te &&
- check_is_really_smaller_arg ~subst n nn kl x safes ty*)
-(* | C.Prod (_,so,ta) ->
- check_is_really_smaller_arg ~subst n nn kl x safes so &&
- check_is_really_smaller_arg ~subst (n+1) (nn+1) kl (x+1)
- (List.map (fun x -> x + 1) safes) ta*)
- | C.Prod _ -> raise (AssertFailure (lazy "10"))
- | C.Lambda (name,so,ta) ->
- check_is_really_smaller_arg ~subst context n nn kl x safes so &&
- check_is_really_smaller_arg ~subst ((Some (name,(C.Decl so)))::context)
- (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta
- | C.LetIn (name,so,ta) ->
- check_is_really_smaller_arg ~subst context n nn kl x safes so &&
- check_is_really_smaller_arg ~subst ((Some (name,(C.Def (so,None))))::context)
- (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta
- | C.Appl (he::_) ->
- (*CSC: sulla coda ci vogliono dei controlli? secondo noi no, ma *)
- (*CSC: solo perche' non abbiamo trovato controesempi *)
- check_is_really_smaller_arg ~subst context n nn kl x safes he
- | C.Appl [] -> raise (AssertFailure (lazy "11"))
- | C.Const _
- | C.MutInd _ -> raise (AssertFailure (lazy "12"))
- | C.MutConstruct _ -> false
- | C.MutCase (uri,i,outtype,term,pl) ->
- (match term with
- C.Rel m when List.mem m safes || m = x ->
- let (tys,len,isinductive,paramsno,cl) =
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.InductiveDefinition (tl,_,paramsno,_) ->
- let tys =
- List.map
- (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) tl
- in
- let (_,isinductive,_,cl) = List.nth tl i in
- let cl' =
- List.map
- (fun (id,ty) ->
- (id, snd (split_prods ~subst tys paramsno ty))) cl
- in
- (tys,List.length tl,isinductive,paramsno,cl')
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- in
- if not isinductive then
- List.fold_right
- (fun p i ->
- i && check_is_really_smaller_arg ~subst context n nn kl x safes p)
- pl true
- else
- let pl_and_cl =
- try
- List.combine pl cl
- with
- Invalid_argument _ ->
- raise (TypeCheckerFailure (lazy "not enough patterns"))
- in
- List.fold_right
- (fun (p,(_,c)) i ->
- let rl' =
- let debrujinedte = debrujin_constructor uri len c in
- recursive_args tys 0 len debrujinedte
- in
- let (e,safes',n',nn',x',context') =
- get_new_safes ~subst context p c rl' safes n nn x
- in
- i &&
- check_is_really_smaller_arg ~subst context' n' nn' kl x' safes' e
- ) pl_and_cl true
- | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x ->
- let (tys,len,isinductive,paramsno,cl) =
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.InductiveDefinition (tl,_,paramsno,_) ->
- let (_,isinductive,_,cl) = List.nth tl i in
- let tys =
- List.map (fun (n,_,ty,_) ->
- Some(Cic.Name n,(Cic.Decl ty))) tl
- in
- let cl' =
- List.map
- (fun (id,ty) ->
- (id, snd (split_prods ~subst tys paramsno ty))) cl
- in
- (tys,List.length tl,isinductive,paramsno,cl')
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- in
- if not isinductive then
- List.fold_right
- (fun p i ->
- i && check_is_really_smaller_arg ~subst context n nn kl x safes p)
- pl true
- else
- let pl_and_cl =
- try
- List.combine pl cl
- with
- Invalid_argument _ ->
- raise (TypeCheckerFailure (lazy "not enough patterns"))
- in
- (*CSC: supponiamo come prima che nessun controllo sia necessario*)
- (*CSC: sugli argomenti di una applicazione *)
- List.fold_right
- (fun (p,(_,c)) i ->
- let rl' =
- let debrujinedte = debrujin_constructor uri len c in
- recursive_args tys 0 len debrujinedte
- in
- let (e, safes',n',nn',x',context') =
- get_new_safes ~subst context p c rl' safes n nn x
- in
- i &&
- check_is_really_smaller_arg ~subst context' n' nn' kl x' safes' e
- ) pl_and_cl true
- | _ ->
- List.fold_right
- (fun p i ->
- i && check_is_really_smaller_arg ~subst context n nn kl x safes p
- ) pl true
- )
- | C.Fix (_, fl) ->
- let len = List.length fl in
- let n_plus_len = n + len
- and nn_plus_len = nn + len
- and x_plus_len = x + len
- and tys = List.map (fun (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl
- and safes' = List.map (fun x -> x + len) safes in
- List.fold_right
- (fun (_,_,ty,bo) i ->
- i &&
- check_is_really_smaller_arg ~subst (tys@context) n_plus_len nn_plus_len kl
- x_plus_len safes' bo
- ) fl true
- | C.CoFix (_, fl) ->
- let len = List.length fl in
- let n_plus_len = n + len
- and nn_plus_len = nn + len
- and x_plus_len = x + len
- and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl
- and safes' = List.map (fun x -> x + len) safes in
- List.fold_right
- (fun (_,ty,bo) i ->
- i &&
- check_is_really_smaller_arg ~subst (tys@context) n_plus_len nn_plus_len kl
- x_plus_len safes' bo
- ) fl true
-
-and guarded_by_destructors ~subst context n nn kl x safes =
- let module C = Cic in
- let module U = UriManager in
- function
- C.Rel m when m > n && m <= nn -> false
- | C.Rel m ->
- (match List.nth context (n-1) with
- Some (_,C.Decl _) -> true
- | Some (_,C.Def (bo,_)) ->
- guarded_by_destructors ~subst context m nn kl x safes
- (CicSubstitution.lift m bo)
- | None -> raise (TypeCheckerFailure (lazy "Reference to deleted hypothesis"))
- )
- | C.Meta _
- | C.Sort _
- | C.Implicit _ -> true
- | C.Cast (te,ty) ->
- guarded_by_destructors ~subst context n nn kl x safes te &&
- guarded_by_destructors ~subst context n nn kl x safes ty
- | C.Prod (name,so,ta) ->
- guarded_by_destructors ~subst context n nn kl x safes so &&
- guarded_by_destructors ~subst ((Some (name,(C.Decl so)))::context)
- (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta
- | C.Lambda (name,so,ta) ->
- guarded_by_destructors ~subst context n nn kl x safes so &&
- guarded_by_destructors ~subst ((Some (name,(C.Decl so)))::context)
- (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta
- | C.LetIn (name,so,ta) ->
- guarded_by_destructors ~subst context n nn kl x safes so &&
- guarded_by_destructors ~subst ((Some (name,(C.Def (so,None))))::context)
- (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta
- | C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
- let k = List.nth kl (m - n - 1) in
- if not (List.length tl > k) then false
- else
- List.fold_right
- (fun param i ->
- i && guarded_by_destructors ~subst context n nn kl x safes param
- ) tl true &&
- check_is_really_smaller_arg ~subst context n nn kl x safes (List.nth tl k)
- | C.Appl tl ->
- List.fold_right
- (fun t i -> i && guarded_by_destructors ~subst context n nn kl x safes t)
- tl true
- | C.Var (_,exp_named_subst)
- | C.Const (_,exp_named_subst)
- | C.MutInd (_,_,exp_named_subst)
- | C.MutConstruct (_,_,_,exp_named_subst) ->
- List.fold_right
- (fun (_,t) i -> i && guarded_by_destructors ~subst context n nn kl x safes t)
- exp_named_subst true
- | C.MutCase (uri,i,outtype,term,pl) ->
- (match CicReduction.whd ~subst context term with
- C.Rel m when List.mem m safes || m = x ->
- let (tys,len,isinductive,paramsno,cl) =
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.InductiveDefinition (tl,_,paramsno,_) ->
- let len = List.length tl in
- let (_,isinductive,_,cl) = List.nth tl i in
- let tys =
- List.map (fun (n,_,ty,_) ->
- Some(Cic.Name n,(Cic.Decl ty))) tl
- in
- let cl' =
- List.map
- (fun (id,ty) ->
- let debrujinedty = debrujin_constructor uri len ty in
- (id, snd (split_prods ~subst tys paramsno ty),
- snd (split_prods ~subst tys paramsno debrujinedty)
- )) cl
- in
- (tys,len,isinductive,paramsno,cl')
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- in
- if not isinductive then
- guarded_by_destructors ~subst context n nn kl x safes outtype &&
- guarded_by_destructors ~subst context n nn kl x safes term &&
- (*CSC: manca ??? il controllo sul tipo di term? *)
- List.fold_right
- (fun p i ->
- i && guarded_by_destructors ~subst context n nn kl x safes p)
- pl true
- else
- let pl_and_cl =
- try
- List.combine pl cl
- with
- Invalid_argument _ ->
- raise (TypeCheckerFailure (lazy "not enough patterns"))
- in
- guarded_by_destructors ~subst context n nn kl x safes outtype &&
- (*CSC: manca ??? il controllo sul tipo di term? *)
- List.fold_right
- (fun (p,(_,c,brujinedc)) i ->
- let rl' = recursive_args tys 0 len brujinedc in
- let (e,safes',n',nn',x',context') =
- get_new_safes ~subst context p c rl' safes n nn x
- in
- i &&
- guarded_by_destructors ~subst context' n' nn' kl x' safes' e
- ) pl_and_cl true
- | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x ->
- let (tys,len,isinductive,paramsno,cl) =
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.InductiveDefinition (tl,_,paramsno,_) ->
- let (_,isinductive,_,cl) = List.nth tl i in
- let tys =
- List.map
- (fun (n,_,ty,_) -> Some(Cic.Name n,(Cic.Decl ty))) tl
- in
- let cl' =
- List.map
- (fun (id,ty) ->
- (id, snd (split_prods ~subst tys paramsno ty))) cl
- in
- (tys,List.length tl,isinductive,paramsno,cl')
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- in
- if not isinductive then
- guarded_by_destructors ~subst context n nn kl x safes outtype &&
- guarded_by_destructors ~subst context n nn kl x safes term &&
- (*CSC: manca ??? il controllo sul tipo di term? *)
- List.fold_right
- (fun p i ->
- i && guarded_by_destructors ~subst context n nn kl x safes p)
- pl true
- else
- let pl_and_cl =
- try
- List.combine pl cl
- with
- Invalid_argument _ ->
- raise (TypeCheckerFailure (lazy "not enough patterns"))
- in
- guarded_by_destructors ~subst context n nn kl x safes outtype &&
- (*CSC: manca ??? il controllo sul tipo di term? *)
- List.fold_right
- (fun t i ->
- i && guarded_by_destructors ~subst context n nn kl x safes t)
- tl true &&
- List.fold_right
- (fun (p,(_,c)) i ->
- let rl' =
- let debrujinedte = debrujin_constructor uri len c in
- recursive_args tys 0 len debrujinedte
- in
- let (e, safes',n',nn',x',context') =
- get_new_safes ~subst context p c rl' safes n nn x
- in
- i &&
- guarded_by_destructors ~subst context' n' nn' kl x' safes' e
- ) pl_and_cl true
- | _ ->
- guarded_by_destructors ~subst context n nn kl x safes outtype &&
- guarded_by_destructors ~subst context n nn kl x safes term &&
- (*CSC: manca ??? il controllo sul tipo di term? *)
- List.fold_right
- (fun p i -> i && guarded_by_destructors ~subst context n nn kl x safes p)
- pl true
- )
- | C.Fix (_, fl) ->
- let len = List.length fl in
- let n_plus_len = n + len
- and nn_plus_len = nn + len
- and x_plus_len = x + len
- and tys = List.map (fun (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl
- and safes' = List.map (fun x -> x + len) safes in
- List.fold_right
- (fun (_,_,ty,bo) i ->
- i && guarded_by_destructors ~subst context n nn kl x_plus_len safes' ty &&
- guarded_by_destructors ~subst (tys@context) n_plus_len nn_plus_len kl
- x_plus_len safes' bo
- ) fl true
- | C.CoFix (_, fl) ->
- let len = List.length fl in
- let n_plus_len = n + len
- and nn_plus_len = nn + len
- and x_plus_len = x + len
- and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl
- and safes' = List.map (fun x -> x + len) safes in
- List.fold_right
- (fun (_,ty,bo) i ->
- i &&
- guarded_by_destructors ~subst context n nn kl x_plus_len safes' ty &&
- guarded_by_destructors ~subst (tys@context) n_plus_len nn_plus_len kl
- x_plus_len safes' bo
- ) fl true
-
-(* the boolean h means already protected *)
-(* args is the list of arguments the type of the constructor that may be *)
-(* found in head position must be applied to. *)
-and guarded_by_constructors ~subst context n nn h te args coInductiveTypeURI =
- let module C = Cic in
- (*CSC: There is a lot of code replication between the cases X and *)
- (*CSC: (C.Appl X tl). Maybe it will be better to define a function *)
- (*CSC: that maps X into (C.Appl X []) when X is not already a C.Appl *)
- match CicReduction.whd ~subst context te with
- C.Rel m when m > n && m <= nn -> h
- | C.Rel _ -> true
- | C.Meta _
- | C.Sort _
- | C.Implicit _
- | C.Cast _
- | C.Prod _
- | C.LetIn _ ->
- (* the term has just been type-checked *)
- raise (AssertFailure (lazy "17"))
- | C.Lambda (name,so,de) ->
- does_not_occur ~subst context n nn so &&
- guarded_by_constructors ~subst ((Some (name,(C.Decl so)))::context)
- (n + 1) (nn + 1) h de args coInductiveTypeURI
- | C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
- h &&
- List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) tl true
- | C.Appl ((C.MutConstruct (uri,i,j,exp_named_subst))::tl) ->
- let consty =
- let obj,_ =
- try
- CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri
- with Not_found -> assert false
- in
- match obj with
- C.InductiveDefinition (itl,_,_,_) ->
- let (_,_,_,cl) = List.nth itl i in
- let (_,cons) = List.nth cl (j - 1) in
- CicSubstitution.subst_vars exp_named_subst cons
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^ UriManager.string_of_uri uri)))
- in
- let rec analyse_branch context ty te =
- match CicReduction.whd ~subst context ty with
- C.Meta _ -> raise (AssertFailure (lazy "34"))
- | C.Rel _
- | C.Var _
- | C.Sort _ ->
- does_not_occur ~subst context n nn te
- | C.Implicit _
- | C.Cast _ ->
- raise (AssertFailure (lazy "24"))(* due to type-checking *)
- | C.Prod (name,so,de) ->
- analyse_branch ((Some (name,(C.Decl so)))::context) de te
- | C.Lambda _
- | C.LetIn _ ->
- raise (AssertFailure (lazy "25"))(* due to type-checking *)
- | C.Appl ((C.MutInd (uri,_,_))::_) when uri == coInductiveTypeURI ->
- guarded_by_constructors ~subst context n nn true te []
- coInductiveTypeURI
- | C.Appl ((C.MutInd (uri,_,_))::_) ->
- guarded_by_constructors ~subst context n nn true te tl
- coInductiveTypeURI
- | C.Appl _ ->
- does_not_occur ~subst context n nn te
- | C.Const _ -> raise (AssertFailure (lazy "26"))
- | C.MutInd (uri,_,_) when uri == coInductiveTypeURI ->
- guarded_by_constructors ~subst context n nn true te []
- coInductiveTypeURI
- | C.MutInd _ ->
- does_not_occur ~subst context n nn te
- | C.MutConstruct _ -> raise (AssertFailure (lazy "27"))
- (*CSC: we do not consider backbones with a MutCase, Fix, Cofix *)
- (*CSC: in head position. *)
- | C.MutCase _
- | C.Fix _
- | C.CoFix _ ->
- raise (AssertFailure (lazy "28"))(* due to type-checking *)
- in
- let rec analyse_instantiated_type context ty l =
- match CicReduction.whd ~subst context ty with
- C.Rel _
- | C.Var _
- | C.Meta _
- | C.Sort _
- | C.Implicit _
- | C.Cast _ -> raise (AssertFailure (lazy "29"))(* due to type-checking *)
- | C.Prod (name,so,de) ->
- begin
- match l with
- [] -> true
- | he::tl ->
- analyse_branch context so he &&
- analyse_instantiated_type
- ((Some (name,(C.Decl so)))::context) de tl
- end
- | C.Lambda _
- | C.LetIn _ ->
- raise (AssertFailure (lazy "30"))(* due to type-checking *)
- | C.Appl _ ->
- List.fold_left
- (fun i x -> i && does_not_occur ~subst context n nn x) true l
- | C.Const _ -> raise (AssertFailure (lazy "31"))
- | C.MutInd _ ->
- List.fold_left
- (fun i x -> i && does_not_occur ~subst context n nn x) true l
- | C.MutConstruct _ -> raise (AssertFailure (lazy "32"))
- (*CSC: we do not consider backbones with a MutCase, Fix, Cofix *)
- (*CSC: in head position. *)
- | C.MutCase _
- | C.Fix _
- | C.CoFix _ ->
- raise (AssertFailure (lazy "33"))(* due to type-checking *)
- in
- let rec instantiate_type args consty =
- function
- [] -> true
- | tlhe::tltl as l ->
- let consty' = CicReduction.whd ~subst context consty in
- match args with
- he::tl ->
- begin
- match consty' with
- C.Prod (_,_,de) ->
- let instantiated_de = CicSubstitution.subst he de in
- (*CSC: siamo sicuri che non sia troppo forte? *)
- does_not_occur ~subst context n nn tlhe &
- instantiate_type tl instantiated_de tltl
- | _ ->
- (*CSC:We do not consider backbones with a MutCase, a *)
- (*CSC:FixPoint, a CoFixPoint and so on in head position.*)
- raise (AssertFailure (lazy "23"))
- end
- | [] -> analyse_instantiated_type context consty' l
- (* These are all the other cases *)
- in
- instantiate_type args consty tl
- | C.Appl ((C.CoFix (_,fl))::tl) ->
- List.fold_left (fun i x -> i && does_not_occur ~subst context n nn x) true tl &&
- let len = List.length fl in
- let n_plus_len = n + len
- and nn_plus_len = nn + len
- (*CSC: Is a Decl of the ty ok or should I use Def of a Fix? *)
- and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl in
- List.fold_right
- (fun (_,ty,bo) i ->
- i && does_not_occur ~subst context n nn ty &&
- guarded_by_constructors ~subst (tys@context) n_plus_len nn_plus_len
- h bo args coInductiveTypeURI
- ) fl true
- | C.Appl ((C.MutCase (_,_,out,te,pl))::tl) ->
- List.fold_left (fun i x -> i && does_not_occur ~subst context n nn x) true tl &&
- does_not_occur ~subst context n nn out &&
- does_not_occur ~subst context n nn te &&
- List.fold_right
- (fun x i ->
- i &&
- guarded_by_constructors ~subst context n nn h x args
- coInductiveTypeURI
- ) pl true
- | C.Appl l ->
- List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) l true
- | C.Var (_,exp_named_subst)
- | C.Const (_,exp_named_subst) ->
- List.fold_right
- (fun (_,x) i -> i && does_not_occur ~subst context n nn x) exp_named_subst true
- | C.MutInd _ -> assert false
- | C.MutConstruct (_,_,_,exp_named_subst) ->
- List.fold_right
- (fun (_,x) i -> i && does_not_occur ~subst context n nn x) exp_named_subst true
- | C.MutCase (_,_,out,te,pl) ->
- does_not_occur ~subst context n nn out &&
- does_not_occur ~subst context n nn te &&
- List.fold_right
- (fun x i ->
- i &&
- guarded_by_constructors ~subst context n nn h x args
- coInductiveTypeURI
- ) pl true
- | C.Fix (_,fl) ->
- let len = List.length fl in
- let n_plus_len = n + len
- and nn_plus_len = nn + len
- (*CSC: Is a Decl of the ty ok or should I use Def of a Fix? *)
- and tys = List.map (fun (n,_,ty,_)-> Some (C.Name n,(C.Decl ty))) fl in
- List.fold_right
- (fun (_,_,ty,bo) i ->
- i && does_not_occur ~subst context n nn ty &&
- does_not_occur ~subst (tys@context) n_plus_len nn_plus_len bo
- ) fl true
- | C.CoFix (_,fl) ->
- let len = List.length fl in
- let n_plus_len = n + len
- and nn_plus_len = nn + len
- (*CSC: Is a Decl of the ty ok or should I use Def of a Fix? *)
- and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl in
- List.fold_right
- (fun (_,ty,bo) i ->
- i && does_not_occur ~subst context n nn ty &&
- guarded_by_constructors ~subst (tys@context) n_plus_len nn_plus_len
- h bo
- args coInductiveTypeURI
- ) fl true
-
-and check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i
- need_dummy ind arity1 arity2 ugraph =
- let module C = Cic in
- let module U = UriManager in
- let arity1 = CicReduction.whd ~subst context arity1 in
- let rec check_allowed_sort_elimination_aux ugraph context arity2 need_dummy =
- match arity1, CicReduction.whd ~subst context arity2 with
- (C.Prod (_,so1,de1), C.Prod (_,so2,de2)) ->
- let b,ugraph1 =
- CicReduction.are_convertible ~subst ~metasenv context so1 so2 ugraph in
- if b then
- check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i
- need_dummy (C.Appl [CicSubstitution.lift 1 ind ; C.Rel 1]) de1 de2
- ugraph1
- else
- false,ugraph1
- | (C.Sort _, C.Prod (name,so,ta)) when not need_dummy ->
- let b,ugraph1 =
- CicReduction.are_convertible ~subst ~metasenv context so ind ugraph in
- if not b then
- false,ugraph1
- else
- check_allowed_sort_elimination_aux ugraph1
- ((Some (name,C.Decl so))::context) ta true
- | (C.Sort C.Prop, C.Sort C.Prop) when need_dummy -> true,ugraph
- | (C.Sort C.Prop, C.Sort C.Set)
- | (C.Sort C.Prop, C.Sort C.CProp)
- | (C.Sort C.Prop, C.Sort (C.Type _) ) when need_dummy ->
- (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.InductiveDefinition (itl,_,paramsno,_) ->
- let itl_len = List.length itl in
- let (name,_,ty,cl) = List.nth itl i in
- let cl_len = List.length cl in
- if (cl_len = 0 || (itl_len = 1 && cl_len = 1)) then
- let non_informative,ugraph =
- if cl_len = 0 then true,ugraph
- else
- is_non_informative ~logger [Some (C.Name name,C.Decl ty)]
- paramsno (snd (List.nth cl 0)) ugraph
- in
- (* is it a singleton or empty non recursive and non informative
- definition? *)
- non_informative, ugraph
- else
- false,ugraph
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- )
- | (C.Sort C.Set, C.Sort C.Prop) when need_dummy -> true , ugraph
- | (C.Sort C.CProp, C.Sort C.Prop) when need_dummy -> true , ugraph
- | (C.Sort C.Set, C.Sort C.Set) when need_dummy -> true , ugraph
- | (C.Sort C.Set, C.Sort C.CProp) when need_dummy -> true , ugraph
- | (C.Sort C.CProp, C.Sort C.Set) when need_dummy -> true , ugraph
- | (C.Sort C.CProp, C.Sort C.CProp) when need_dummy -> true , ugraph
- | ((C.Sort C.Set, C.Sort (C.Type _)) | (C.Sort C.CProp, C.Sort (C.Type _)))
- when need_dummy ->
- (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.InductiveDefinition (itl,_,paramsno,_) ->
- let tys =
- List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) itl
- in
- let (_,_,_,cl) = List.nth itl i in
- (List.fold_right
- (fun (_,x) (i,ugraph) ->
- if i then
- is_small ~logger tys paramsno x ugraph
- else
- false,ugraph
- ) cl (true,ugraph))
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- )
- | (C.Sort (C.Type _), C.Sort _) when need_dummy -> true , ugraph
- | (_,_) -> false,ugraph
- in
- check_allowed_sort_elimination_aux ugraph context arity2 need_dummy
-
-and type_of_branch ~subst context argsno need_dummy outtype term constype =
- let module C = Cic in
- let module R = CicReduction in
- match R.whd ~subst context constype with
- C.MutInd (_,_,_) ->
- if need_dummy then
- outtype
- else
- C.Appl [outtype ; term]
- | C.Appl (C.MutInd (_,_,_)::tl) ->
- let (_,arguments) = split tl argsno
- in
- if need_dummy && arguments = [] then
- outtype
- else
- C.Appl (outtype::arguments@(if need_dummy then [] else [term]))
- | C.Prod (name,so,de) ->
- let term' =
- match CicSubstitution.lift 1 term with
- C.Appl l -> C.Appl (l@[C.Rel 1])
- | t -> C.Appl [t ; C.Rel 1]
- in
- C.Prod (C.Anonymous,so,type_of_branch ~subst
- ((Some (name,(C.Decl so)))::context) argsno need_dummy
- (CicSubstitution.lift 1 outtype) term' de)
- | _ -> raise (AssertFailure (lazy "20"))
-
-(* check_metasenv_consistency checks that the "canonical" context of a
-metavariable is consitent - up to relocation via the relocation list l -
-with the actual context *)
-
-
-and check_metasenv_consistency ~logger ~subst metasenv context
- canonical_context l ugraph
-=
- let module C = Cic in
- let module R = CicReduction in
- let module S = CicSubstitution in
- let lifted_canonical_context =
- let rec aux i =
- function
- [] -> []
- | (Some (n,C.Decl t))::tl ->
- (Some (n,C.Decl (S.subst_meta l (S.lift i t))))::(aux (i+1) tl)
- | (Some (n,C.Def (t,None)))::tl ->
- (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None)))::(aux (i+1) tl)
- | None::tl -> None::(aux (i+1) tl)
- | (Some (n,C.Def (t,Some ty)))::tl ->
- (Some (n,C.Def ((S.subst_meta l (S.lift i t)),Some (S.subst_meta l (S.lift i ty)))))::(aux (i+1) tl)
- in
- aux 1 canonical_context
- in
- List.fold_left2
- (fun ugraph t ct ->
- match (t,ct) with
- | _,None -> ugraph
- | Some t,Some (_,C.Def (ct,_)) ->
- let b,ugraph1 =
- R.are_convertible ~subst ~metasenv context t ct ugraph
- in
- if not b then
- raise
- (TypeCheckerFailure
- (lazy (sprintf "Not well typed metavariable local context: expected a term convertible with %s, found %s" (CicPp.ppterm ct) (CicPp.ppterm t))))
- else
- ugraph1
- | Some t,Some (_,C.Decl ct) ->
- let type_t,ugraph1 =
- type_of_aux' ~logger ~subst metasenv context t ugraph
- in
- let b,ugraph2 =
- R.are_convertible ~subst ~metasenv context type_t ct ugraph1
- in
- if not b then
- raise (TypeCheckerFailure
- (lazy (sprintf "Not well typed metavariable local context: expected a term of type %s, found %s of type %s"
- (CicPp.ppterm ct) (CicPp.ppterm t)
- (CicPp.ppterm type_t))))
- else
- ugraph2
- | None, _ ->
- raise (TypeCheckerFailure
- (lazy ("Not well typed metavariable local context: "^
- "an hypothesis, that is not hidden, is not instantiated")))
- ) ugraph l lifted_canonical_context
-
-
-(*
- type_of_aux' is just another name (with a different scope)
- for type_of_aux
-*)
-
-and type_of_aux' ~logger ?(subst = []) metasenv context t ugraph =
- let rec type_of_aux ~logger context t ugraph =
- let module C = Cic in
- let module R = CicReduction in
- let module S = CicSubstitution in
- let module U = UriManager in
- match t with
- C.Rel n ->
- (try
- match List.nth context (n - 1) with
- Some (_,C.Decl t) -> S.lift n t,ugraph
- | Some (_,C.Def (_,Some ty)) -> S.lift n ty,ugraph
- | Some (_,C.Def (bo,None)) ->
- debug_print (lazy "##### CASO DA INVESTIGARE E CAPIRE") ;
- type_of_aux ~logger context (S.lift n bo) ugraph
- | None -> raise
- (TypeCheckerFailure (lazy "Reference to deleted hypothesis"))
- with
- _ ->
- raise (TypeCheckerFailure (lazy "unbound variable"))
- )
- | C.Var (uri,exp_named_subst) ->
- incr fdebug ;
- let ugraph1 =
- check_exp_named_subst ~logger ~subst context exp_named_subst ugraph
- in
- let ty,ugraph2 = type_of_variable ~logger uri ugraph1 in
- let ty1 = CicSubstitution.subst_vars exp_named_subst ty in
- decr fdebug ;
- ty1,ugraph2
- | C.Meta (n,l) ->
- (try
- let (canonical_context,term,ty) = CicUtil.lookup_subst n subst in
- let ugraph1 =
- check_metasenv_consistency ~logger
- ~subst metasenv context canonical_context l ugraph
- in
- (* assuming subst is well typed !!!!! *)
- ((CicSubstitution.subst_meta l ty), ugraph1)
- (* type_of_aux context (CicSubstitution.subst_meta l term) *)
- with CicUtil.Subst_not_found _ ->
- let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in
- let ugraph1 =
- check_metasenv_consistency ~logger
- ~subst metasenv context canonical_context l ugraph
- in
- ((CicSubstitution.subst_meta l ty),ugraph1))
- (* TASSI: CONSTRAINTS *)
- | C.Sort (C.Type t) ->
- let t' = CicUniv.fresh() in
- let ugraph1 = CicUniv.add_gt t' t ugraph in
- (C.Sort (C.Type t')),ugraph1
- (* TASSI: CONSTRAINTS *)
- | C.Sort s -> (C.Sort (C.Type (CicUniv.fresh ()))),ugraph
- | C.Implicit _ -> raise (AssertFailure (lazy "21"))
- | C.Cast (te,ty) as t ->
- let _,ugraph1 = type_of_aux ~logger context ty ugraph in
- let ty_te,ugraph2 = type_of_aux ~logger context te ugraph1 in
- let b,ugraph3 =
- R.are_convertible ~subst ~metasenv context ty_te ty ugraph2
- in
- if b then
- ty,ugraph3
- else
- raise (TypeCheckerFailure
- (lazy (sprintf "Invalid cast %s" (CicPp.ppterm t))))
- | C.Prod (name,s,t) ->
- let sort1,ugraph1 = type_of_aux ~logger context s ugraph in
- let sort2,ugraph2 =
- type_of_aux ~logger ((Some (name,(C.Decl s)))::context) t ugraph1
- in
- sort_of_prod ~subst context (name,s) (sort1,sort2) ugraph2
- | C.Lambda (n,s,t) ->
- let sort1,ugraph1 = type_of_aux ~logger context s ugraph in
- (match R.whd ~subst context sort1 with
- C.Meta _
- | C.Sort _ -> ()
- | _ ->
- raise
- (TypeCheckerFailure (lazy (sprintf
- "Not well-typed lambda-abstraction: the source %s should be a type; instead it is a term of type %s" (CicPp.ppterm s)
- (CicPp.ppterm sort1))))
- ) ;
- let type2,ugraph2 =
- type_of_aux ~logger ((Some (n,(C.Decl s)))::context) t ugraph1
- in
- (C.Prod (n,s,type2)),ugraph2
- | C.LetIn (n,s,t) ->
- (* only to check if s is well-typed *)
- let ty,ugraph1 = type_of_aux ~logger context s ugraph in
- (* The type of a LetIn is a LetIn. Extremely slow since the computed
- LetIn is later reduced and maybe also re-checked.
- (C.LetIn (n,s, type_of_aux ((Some (n,(C.Def s)))::context) t))
- *)
- (* The type of the LetIn is reduced. Much faster than the previous
- solution. Moreover the inferred type is probably very different
- from the expected one.
- (CicReduction.whd ~subst context
- (C.LetIn (n,s, type_of_aux ((Some (n,(C.Def s)))::context) t)))
- *)
- (* One-step LetIn reduction. Even faster than the previous solution.
- Moreover the inferred type is closer to the expected one. *)
- let ty1,ugraph2 =
- type_of_aux ~logger
- ((Some (n,(C.Def (s,Some ty))))::context) t ugraph1
- in
- (CicSubstitution.subst s ty1),ugraph2
- | C.Appl (he::tl) when List.length tl > 0 ->
- let hetype,ugraph1 = type_of_aux ~logger context he ugraph in
- let tlbody_and_type,ugraph2 =
- List.fold_right (
- fun x (l,ugraph) ->
- let ty,ugraph1 = type_of_aux ~logger context x ugraph in
- let _,ugraph1 = type_of_aux ~logger context ty ugraph1 in
- ((x,ty)::l,ugraph1))
- tl ([],ugraph1)
- in
- (* TASSI: questa c'era nel mio... ma non nel CVS... *)
- (* let _,ugraph2 = type_of_aux context hetype ugraph2 in *)
- eat_prods ~subst context hetype tlbody_and_type ugraph2
- | C.Appl _ -> raise (AssertFailure (lazy "Appl: no arguments"))
- | C.Const (uri,exp_named_subst) ->
- incr fdebug ;
- let ugraph1 =
- check_exp_named_subst ~logger ~subst context exp_named_subst ugraph
- in
- let cty,ugraph2 = type_of_constant ~logger uri ugraph1 in
- let cty1 =
- CicSubstitution.subst_vars exp_named_subst cty
- in
- decr fdebug ;
- cty1,ugraph2
- | C.MutInd (uri,i,exp_named_subst) ->
- incr fdebug ;
- let ugraph1 =
- check_exp_named_subst ~logger ~subst context exp_named_subst ugraph
- in
- (* TASSI: da me c'era anche questa, ma in CVS no *)
- let mty,ugraph2 = type_of_mutual_inductive_defs ~logger uri i ugraph1 in
- (* fine parte dubbia *)
- let cty =
- CicSubstitution.subst_vars exp_named_subst mty
- in
- decr fdebug ;
- cty,ugraph2
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let ugraph1 =
- check_exp_named_subst ~logger ~subst context exp_named_subst ugraph
- in
- (* TASSI: idem come sopra *)
- let mty,ugraph2 =
- type_of_mutual_inductive_constr ~logger uri i j ugraph1
- in
- let cty =
- CicSubstitution.subst_vars exp_named_subst mty
- in
- cty,ugraph2
- | C.MutCase (uri,i,outtype,term,pl) ->
- let outsort,ugraph1 = type_of_aux ~logger context outtype ugraph in
- let (need_dummy, k) =
- let rec guess_args context t =
- let outtype = CicReduction.whd ~subst context t in
- match outtype with
- C.Sort _ -> (true, 0)
- | C.Prod (name, s, t) ->
- let (b, n) =
- guess_args ((Some (name,(C.Decl s)))::context) t in
- if n = 0 then
- (* last prod before sort *)
- match CicReduction.whd ~subst context s with
-(*CSC: for _ see comment below about the missing named_exp_subst ?????????? *)
- C.MutInd (uri',i',_) when U.eq uri' uri && i' = i ->
- (false, 1)
-(*CSC: for _ see comment below about the missing named_exp_subst ?????????? *)
- | C.Appl ((C.MutInd (uri',i',_)) :: _)
- when U.eq uri' uri && i' = i -> (false, 1)
- | _ -> (true, 1)
- else
- (b, n + 1)
- | _ ->
- raise
- (TypeCheckerFailure
- (lazy (sprintf
- "Malformed case analasys' output type %s"
- (CicPp.ppterm outtype))))
- in
-(*
- let (parameters, arguments, exp_named_subst),ugraph2 =
- let ty,ugraph2 = type_of_aux context term ugraph1 in
- match R.whd ~subst context ty with
- (*CSC manca il caso dei CAST *)
-(*CSC: ma servono i parametri (uri,i)? Se si', perche' non serve anche il *)
-(*CSC: parametro exp_named_subst? Se no, perche' non li togliamo? *)
-(*CSC: Hint: nella DTD servono per gli stylesheet. *)
- C.MutInd (uri',i',exp_named_subst) as typ ->
- if U.eq uri uri' && i = i' then
- ([],[],exp_named_subst),ugraph2
- else
- raise
- (TypeCheckerFailure
- (lazy (sprintf
- ("Case analysys: analysed term type is %s, but is expected to be (an application of) %s#1/%d{_}")
- (CicPp.ppterm typ) (U.string_of_uri uri) i)))
- | C.Appl
- ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) as typ' ->
- if U.eq uri uri' && i = i' then
- let params,args =
- split tl (List.length tl - k)
- in (params,args,exp_named_subst),ugraph2
- else
- raise
- (TypeCheckerFailure
- (lazy (sprintf
- ("Case analysys: analysed term type is %s, "^
- "but is expected to be (an application of) "^
- "%s#1/%d{_}")
- (CicPp.ppterm typ') (U.string_of_uri uri) i)))
- | _ ->
- raise
- (TypeCheckerFailure
- (lazy (sprintf
- ("Case analysis: "^
- "analysed term %s is not an inductive one")
- (CicPp.ppterm term))))
-*)
- let (b, k) = guess_args context outsort in
- if not b then (b, k - 1) else (b, k) in
- let (parameters, arguments, exp_named_subst),ugraph2 =
- let ty,ugraph2 = type_of_aux ~logger context term ugraph1 in
- match R.whd ~subst context ty with
- C.MutInd (uri',i',exp_named_subst) as typ ->
- if U.eq uri uri' && i = i' then
- ([],[],exp_named_subst),ugraph2
- else raise
- (TypeCheckerFailure
- (lazy (sprintf
- ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}")
- (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) i)))
- | C.Appl ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) ->
- if U.eq uri uri' && i = i' then
- let params,args =
- split tl (List.length tl - k)
- in (params,args,exp_named_subst),ugraph2
- else raise
- (TypeCheckerFailure
- (lazy (sprintf
- ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}")
- (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) i)))
- | _ ->
- raise
- (TypeCheckerFailure
- (lazy (sprintf
- "Case analysis: analysed term %s is not an inductive one"
- (CicPp.ppterm term))))
- in
- (*
- let's control if the sort elimination is allowed:
- [(I q1 ... qr)|B]
- *)
- let sort_of_ind_type =
- if parameters = [] then
- C.MutInd (uri,i,exp_named_subst)
- else
- C.Appl ((C.MutInd (uri,i,exp_named_subst))::parameters)
- in
- let type_of_sort_of_ind_ty,ugraph3 =
- type_of_aux ~logger context sort_of_ind_type ugraph2 in
- let b,ugraph4 =
- check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i
- need_dummy sort_of_ind_type type_of_sort_of_ind_ty outsort ugraph3
- in
- if not b then
- raise
- (TypeCheckerFailure (lazy ("Case analasys: sort elimination not allowed")));
- (* let's check if the type of branches are right *)
- let parsno =
- let obj,_ =
- try
- CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri
- with Not_found -> assert false
- in
- match obj with
- C.InductiveDefinition (_,_,parsno,_) -> parsno
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- in
- let (_,branches_ok,ugraph5) =
- List.fold_left
- (fun (j,b,ugraph) p ->
- if b then
- let cons =
- if parameters = [] then
- (C.MutConstruct (uri,i,j,exp_named_subst))
- else
- (C.Appl
- (C.MutConstruct (uri,i,j,exp_named_subst)::parameters))
- in
- let ty_p,ugraph1 = type_of_aux ~logger context p ugraph in
- let ty_cons,ugraph3 = type_of_aux ~logger context cons ugraph1 in
- (* 2 is skipped *)
- let ty_branch =
- type_of_branch ~subst context parsno need_dummy outtype cons
- ty_cons in
- let b1,ugraph4 =
- R.are_convertible
- ~subst ~metasenv context ty_p ty_branch ugraph3
- in
- if not b1 then
- debug_print (lazy
- ("#### " ^ CicPp.ppterm ty_p ^
- " <==> " ^ CicPp.ppterm ty_branch));
- (j + 1,b1,ugraph4)
- else
- (j,false,ugraph)
- ) (1,true,ugraph4) pl
- in
- if not branches_ok then
- raise
- (TypeCheckerFailure (lazy "Case analysys: wrong branch type"));
- let arguments' =
- if not need_dummy then outtype::arguments@[term]
- else outtype::arguments in
- let outtype =
- if need_dummy && arguments = [] then outtype
- else CicReduction.head_beta_reduce (C.Appl arguments')
- in
- outtype,ugraph5
- | C.Fix (i,fl) ->
- let types_times_kl,ugraph1 =
- (* WAS: list rev list map *)
- List.fold_left
- (fun (l,ugraph) (n,k,ty,_) ->
- let _,ugraph1 = type_of_aux ~logger context ty ugraph in
- ((Some (C.Name n,(C.Decl ty)),k)::l,ugraph1)
- ) ([],ugraph) fl
- in
- let (types,kl) = List.split types_times_kl in
- let len = List.length types in
- let ugraph2 =
- List.fold_left
- (fun ugraph (name,x,ty,bo) ->
- let ty_bo,ugraph1 =
- type_of_aux ~logger (types@context) bo ugraph
- in
- let b,ugraph2 =
- R.are_convertible ~subst ~metasenv (types@context)
- ty_bo (CicSubstitution.lift len ty) ugraph1 in
- if b then
- begin
- let (m, eaten, context') =
- eat_lambdas ~subst (types @ context) (x + 1) bo
- in
- (*
- let's control the guarded by
- destructors conditions D{f,k,x,M}
- *)
- if not (guarded_by_destructors ~subst context' eaten
- (len + eaten) kl 1 [] m) then
- raise
- (TypeCheckerFailure
- (lazy ("Fix: not guarded by destructors")))
- else
- ugraph2
- end
- else
- raise (TypeCheckerFailure (lazy ("Fix: ill-typed bodies")))
- ) ugraph1 fl in
- (*CSC: controlli mancanti solo su D{f,k,x,M} *)
- let (_,_,ty,_) = List.nth fl i in
- ty,ugraph2
- | C.CoFix (i,fl) ->
- let types,ugraph1 =
- List.fold_left
- (fun (l,ugraph) (n,ty,_) ->
- let _,ugraph1 =
- type_of_aux ~logger context ty ugraph in
- (Some (C.Name n,(C.Decl ty))::l,ugraph1)
- ) ([],ugraph) fl
- in
- let len = List.length types in
- let ugraph2 =
- List.fold_left
- (fun ugraph (_,ty,bo) ->
- let ty_bo,ugraph1 =
- type_of_aux ~logger (types @ context) bo ugraph
- in
- let b,ugraph2 =
- R.are_convertible ~subst ~metasenv (types @ context) ty_bo
- (CicSubstitution.lift len ty) ugraph1
- in
- if b then
- begin
- (* let's control that the returned type is coinductive *)
- match returns_a_coinductive ~subst context ty with
- None ->
- raise
- (TypeCheckerFailure
- (lazy "CoFix: does not return a coinductive type"))
- | Some uri ->
- (*
- let's control the guarded by constructors
- conditions C{f,M}
- *)
- if not (guarded_by_constructors ~subst
- (types @ context) 0 len false bo [] uri) then
- raise
- (TypeCheckerFailure
- (lazy "CoFix: not guarded by constructors"))
- else
- ugraph2
- end
- else
- raise
- (TypeCheckerFailure (lazy "CoFix: ill-typed bodies"))
- ) ugraph1 fl
- in
- let (_,ty,_) = List.nth fl i in
- ty,ugraph2
-
- and check_exp_named_subst ~logger ~subst context ugraph =
- let rec check_exp_named_subst_aux ~logger esubsts l ugraph =
- match l with
- [] -> ugraph
- | ((uri,t) as item)::tl ->
- let ty_uri,ugraph1 = type_of_variable ~logger uri ugraph in
- let typeofvar =
- CicSubstitution.subst_vars esubsts ty_uri in
- let typeoft,ugraph2 = type_of_aux ~logger context t ugraph1 in
- let b,ugraph3 =
- CicReduction.are_convertible ~subst ~metasenv
- context typeoft typeofvar ugraph2
- in
- if b then
- check_exp_named_subst_aux ~logger (esubsts@[item]) tl ugraph3
- else
- begin
- CicReduction.fdebug := 0 ;
- ignore
- (CicReduction.are_convertible
- ~subst ~metasenv context typeoft typeofvar ugraph2) ;
- fdebug := 0 ;
- debug typeoft [typeofvar] ;
- raise (TypeCheckerFailure (lazy "Wrong Explicit Named Substitution"))
- end
- in
- check_exp_named_subst_aux ~logger [] ugraph
-
- and sort_of_prod ~subst context (name,s) (t1, t2) ugraph =
- let module C = Cic in
- let t1' = CicReduction.whd ~subst context t1 in
- let t2' = CicReduction.whd ~subst ((Some (name,C.Decl s))::context) t2 in
- match (t1', t2') with
- (C.Sort s1, C.Sort s2)
- when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) ->
- (* different from Coq manual!!! *)
- C.Sort s2,ugraph
- | (C.Sort (C.Type t1), C.Sort (C.Type t2)) ->
- (* TASSI: CONSRTAINTS: the same in doubletypeinference, cicrefine *)
- let t' = CicUniv.fresh() in
- let ugraph1 = CicUniv.add_ge t' t1 ugraph in
- let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in
- C.Sort (C.Type t'),ugraph2
- | (C.Sort _,C.Sort (C.Type t1)) ->
- (* TASSI: CONSRTAINTS: the same in doubletypeinference, cicrefine *)
- C.Sort (C.Type t1),ugraph (* c'e' bisogno di un fresh? *)
- | (C.Meta _, C.Sort _) -> t2',ugraph
- | (C.Meta _, (C.Meta (_,_) as t))
- | (C.Sort _, (C.Meta (_,_) as t)) when CicUtil.is_closed t ->
- t2',ugraph
- | (_,_) -> raise (TypeCheckerFailure (lazy (sprintf
- "Prod: expected two sorts, found = %s, %s" (CicPp.ppterm t1')
- (CicPp.ppterm t2'))))
-
- and eat_prods ~subst context hetype l ugraph =
- (*CSC: siamo sicuri che le are_convertible non lavorino con termini non *)
- (*CSC: cucinati *)
- match l with
- [] -> hetype,ugraph
- | (hete, hety)::tl ->
- (match (CicReduction.whd ~subst context hetype) with
- Cic.Prod (n,s,t) ->
- let b,ugraph1 =
- CicReduction.are_convertible
- ~subst ~metasenv context hety s ugraph
- in
- if b then
- begin
- CicReduction.fdebug := -1 ;
- eat_prods ~subst context
- (CicSubstitution.subst hete t) tl ugraph1
- (*TASSI: not sure *)
- end
- else
- begin
- CicReduction.fdebug := 0 ;
- ignore (CicReduction.are_convertible
- ~subst ~metasenv context s hety ugraph) ;
- fdebug := 0 ;
- debug s [hety] ;
- raise
- (TypeCheckerFailure
- (lazy (sprintf
- ("Appl: wrong parameter-type, expected %s, found %s")
- (CicPp.ppterm hetype) (CicPp.ppterm s))))
- end
- | _ ->
- raise (TypeCheckerFailure
- (lazy "Appl: this is not a function, it cannot be applied"))
- )
-
- and returns_a_coinductive ~subst context ty =
- let module C = Cic in
- match CicReduction.whd ~subst context ty with
- C.MutInd (uri,i,_) ->
- (*CSC: definire una funzioncina per questo codice sempre replicato *)
- let obj,_ =
- try
- CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri
- with Not_found -> assert false
- in
- (match obj with
- C.InductiveDefinition (itl,_,_,_) ->
- let (_,is_inductive,_,_) = List.nth itl i in
- if is_inductive then None else (Some uri)
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- )
- | C.Appl ((C.MutInd (uri,i,_))::_) ->
- (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.InductiveDefinition (itl,_,_,_) ->
- let (_,is_inductive,_,_) = List.nth itl i in
- if is_inductive then None else (Some uri)
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- )
- | C.Prod (n,so,de) ->
- returns_a_coinductive ~subst ((Some (n,C.Decl so))::context) de
- | _ -> None
-
- in
-(*CSC
-debug_print (lazy ("INIZIO TYPE_OF_AUX " ^ CicPp.ppterm t)) ; flush stderr ;
-let res =
-*)
- type_of_aux ~logger context t ugraph
-(*
-in debug_print (lazy "FINE TYPE_OF_AUX") ; flush stderr ; res
-*)
-
-(* is a small constructor? *)
-(*CSC: ottimizzare calcolando staticamente *)
-and is_small_or_non_informative ~condition ~logger context paramsno c ugraph =
- let rec is_small_or_non_informative_aux ~logger context c ugraph =
- let module C = Cic in
- match CicReduction.whd context c with
- C.Prod (n,so,de) ->
- let s,ugraph1 = type_of_aux' ~logger [] context so ugraph in
- let b = condition s in
- if b then
- is_small_or_non_informative_aux
- ~logger ((Some (n,(C.Decl so)))::context) de ugraph1
- else
- false,ugraph1
- | _ -> true,ugraph (*CSC: we trust the type-checker *)
- in
- let (context',dx) = split_prods ~subst:[] context paramsno c in
- is_small_or_non_informative_aux ~logger context' dx ugraph
-
-and is_small ~logger =
- is_small_or_non_informative
- ~condition:(fun s -> s=Cic.Sort Cic.Prop || s=Cic.Sort Cic.Set)
- ~logger
-
-and is_non_informative ~logger =
- is_small_or_non_informative
- ~condition:(fun s -> s=Cic.Sort Cic.Prop)
- ~logger
-
-and type_of ~logger t ugraph =
-(*CSC
-debug_print (lazy ("INIZIO TYPE_OF_AUX' " ^ CicPp.ppterm t)) ; flush stderr ;
-let res =
-*)
- type_of_aux' ~logger [] [] t ugraph
-(*CSC
-in debug_print (lazy "FINE TYPE_OF_AUX'") ; flush stderr ; res
-*)
-;;
-
-let typecheck_obj0 ~logger uri ugraph =
- let module C = Cic in
- function
- C.Constant (_,Some te,ty,_,_) ->
- let _,ugraph = type_of ~logger ty ugraph in
- let ty_te,ugraph = type_of ~logger te ugraph in
- let b,ugraph = (CicReduction.are_convertible [] ty_te ty ugraph) in
- if not b then
- raise (TypeCheckerFailure
- (lazy
- ("the type of the body is not the one expected:\n" ^
- CicPp.ppterm ty_te ^ "\nvs\n" ^
- CicPp.ppterm ty)))
- else
- ugraph
- | C.Constant (_,None,ty,_,_) ->
- (* only to check that ty is well-typed *)
- let _,ugraph = type_of ~logger ty ugraph in
- ugraph
- | C.CurrentProof (_,conjs,te,ty,_,_) ->
- let _,ugraph =
- List.fold_left
- (fun (metasenv,ugraph) ((_,context,ty) as conj) ->
- let _,ugraph =
- type_of_aux' ~logger metasenv context ty ugraph
- in
- metasenv @ [conj],ugraph
- ) ([],ugraph) conjs
- in
- let _,ugraph = type_of_aux' ~logger conjs [] ty ugraph in
- let type_of_te,ugraph =
- type_of_aux' ~logger conjs [] te ugraph
- in
- let b,ugraph = CicReduction.are_convertible [] type_of_te ty ugraph in
- if not b then
- raise (TypeCheckerFailure (lazy (sprintf
- "the current proof is not well typed because the type %s of the body is not convertible to the declared type %s"
- (CicPp.ppterm type_of_te) (CicPp.ppterm ty))))
- else
- ugraph
- | C.Variable (_,bo,ty,_,_) ->
- (* only to check that ty is well-typed *)
- let _,ugraph = type_of ~logger ty ugraph in
- (match bo with
- None -> ugraph
- | Some bo ->
- let ty_bo,ugraph = type_of ~logger bo ugraph in
- let b,ugraph = CicReduction.are_convertible [] ty_bo ty ugraph in
- if not b then
- raise (TypeCheckerFailure
- (lazy "the body is not the one expected"))
- else
- ugraph
- )
- | (C.InductiveDefinition _ as obj) ->
- check_mutual_inductive_defs ~logger uri obj ugraph
-
-let typecheck uri =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let logger = new CicLogger.logger in
- (* ??? match CicEnvironment.is_type_checked ~trust:true uri with ???? *)
- match CicEnvironment.is_type_checked ~trust:false CicUniv.empty_ugraph uri with
- CicEnvironment.CheckedObj (cobj,ugraph') ->
- (* debug_print (lazy ("NON-INIZIO A TYPECHECKARE " ^ U.string_of_uri uri));*)
- cobj,ugraph'
- | CicEnvironment.UncheckedObj uobj ->
- (* let's typecheck the uncooked object *)
- logger#log (`Start_type_checking uri) ;
- (* debug_print (lazy ("INIZIO A TYPECHECKARE " ^ U.string_of_uri uri)); *)
- let ugraph = typecheck_obj0 ~logger uri CicUniv.empty_ugraph uobj in
- try
- CicEnvironment.set_type_checking_info uri;
- logger#log (`Type_checking_completed uri);
- match CicEnvironment.is_type_checked ~trust:false ugraph uri with
- CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph'
- | _ -> raise CicEnvironmentError
- with
- (*
- this is raised if set_type_checking_info is called on an object
- that has no associated universe file. If we are in univ_maker
- phase this is OK since univ_maker will properly commit the
- object.
- *)
- Invalid_argument s ->
- (*debug_print (lazy s);*)
- uobj,ugraph
-;;
-
-let typecheck_obj ~logger uri obj =
- let ugraph = typecheck_obj0 ~logger uri CicUniv.empty_ugraph obj in
- let ugraph, univlist, obj = CicUnivUtils.clean_and_fill uri obj ugraph in
- CicEnvironment.add_type_checked_obj uri (obj,ugraph,univlist)
-
-(** wrappers which instantiate fresh loggers *)
-
-let type_of_aux' ?(subst = []) metasenv context t ugraph =
- let logger = new CicLogger.logger in
- type_of_aux' ~logger ~subst metasenv context t ugraph
-
-let typecheck_obj uri obj =
- let logger = new CicLogger.logger in
- typecheck_obj ~logger uri obj
-
-(* check_allowed_sort_elimination uri i s1 s2
- This function is used outside the kernel to determine in advance whether
- a MutCase will be allowed or not.
- [uri,i] is the type of the term to match
- [s1] is the sort of the term to eliminate (i.e. the head of the arity
- of the inductive type [uri,i])
- [s2] is the sort of the goal (i.e. the head of the type of the outtype
- of the MutCase) *)
-let check_allowed_sort_elimination uri i s1 s2 =
- fst (check_allowed_sort_elimination ~subst:[] ~metasenv:[]
- ~logger:(new CicLogger.logger) [] uri i true
- (Cic.Implicit None) (* never used *) (Cic.Sort s1) (Cic.Sort s2)
- CicUniv.empty_ugraph)
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* 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
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*****************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
- (** 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
-
+++ /dev/null
-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)
+++ /dev/null
-(* 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)
-;;
+++ /dev/null
-(* 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
+++ /dev/null
-UTILITIES = create_environment parse_library list_uris
-UTILITIES_OPT = $(patsubst %,%.opt,$(UTILITIES))
-LINKOPTS = -linkpkg -thread
-LIBS = helm-cic_proof_checking
-OCAMLC = $(OCAMLFIND) ocamlc $(LINKOPTS) -package $(LIBS)
-OCAMLOPT = $(OCAMLFIND) opt $(LINKOPTS) -package $(LIBS)
-all: $(UTILITIES)
- @echo -n
-opt: $(UTILITIES_OPT)
- @echo -n
-%: %.ml
- @echo " OCAMLC $<"
- @$(OCAMLC) -o $@ $<
-%.opt: %.ml
- @echo " OCAMLOPT $<"
- @$(OCAMLOPT) -o $@ $<
-clean:
- rm -f $(UTILITIES) $(UTILITIES_OPT) *.cm[iox] *.o
-
-include ../../../Makefile.defs
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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 ())
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-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
+++ /dev/null
-PACKAGE = cic_unification
-PREDICATES =
-
-INTERFACE_FILES = \
- cicMetaSubst.mli \
- cicMkImplicit.mli \
- cicUnification.mli \
- cicRefine.mli
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-EXTRA_OBJECTS_TO_INSTALL =
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2003, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-open Printf
-
-(* PROFILING *)
-(*
-let deref_counter = ref 0
-let apply_subst_context_counter = ref 0
-let apply_subst_metasenv_counter = ref 0
-let lift_counter = ref 0
-let subst_counter = ref 0
-let whd_counter = ref 0
-let are_convertible_counter = ref 0
-let metasenv_length = ref 0
-let context_length = ref 0
-let reset_counters () =
- apply_subst_counter := 0;
- apply_subst_context_counter := 0;
- apply_subst_metasenv_counter := 0;
- lift_counter := 0;
- subst_counter := 0;
- whd_counter := 0;
- are_convertible_counter := 0;
- metasenv_length := 0;
- context_length := 0
-let print_counters () =
- debug_print (lazy (Printf.sprintf
-"apply_subst: %d
-apply_subst_context: %d
-apply_subst_metasenv: %d
-lift: %d
-subst: %d
-whd: %d
-are_convertible: %d
-metasenv length: %d (avg = %.2f)
-context length: %d (avg = %.2f)
-"
- !apply_subst_counter !apply_subst_context_counter
- !apply_subst_metasenv_counter !lift_counter !subst_counter !whd_counter
- !are_convertible_counter !metasenv_length
- ((float !metasenv_length) /. (float !apply_subst_metasenv_counter))
- !context_length
- ((float !context_length) /. (float !apply_subst_context_counter))
- ))*)
-
-
-
-exception MetaSubstFailure of string Lazy.t
-exception Uncertain of string Lazy.t
-exception AssertFailure of string Lazy.t
-exception DeliftingARelWouldCaptureAFreeVariable;;
-
-let debug_print = fun _ -> ()
-
-type substitution = (int * (Cic.context * Cic.term)) list
-
-(*
-let rec deref subst =
- let third _,_,a = a in
- function
- Cic.Meta(n,l) as t ->
- (try
- deref subst
- (CicSubstitution.subst_meta
- l (third (CicUtil.lookup_subst n subst)))
- with
- CicUtil.Subst_not_found _ -> t)
- | t -> t
-;;
-*)
-
-let lookup_subst = CicUtil.lookup_subst
-;;
-
-
-(* clean_up_meta take a metasenv and a term and make every local context
-of each occurrence of a metavariable consistent with its canonical context,
-with respect to the hidden hipothesis *)
-
-(*
-let clean_up_meta subst metasenv t =
- let module C = Cic in
- let rec aux t =
- match t with
- C.Rel _
- | C.Sort _ -> t
- | C.Implicit _ -> assert false
- | C.Meta (n,l) as t ->
- let cc =
- (try
- let (cc,_) = lookup_subst n subst in cc
- with CicUtil.Subst_not_found _ ->
- try
- let (_,cc,_) = CicUtil.lookup_meta n metasenv in cc
- with CicUtil.Meta_not_found _ -> assert false) in
- let l' =
- (try
- List.map2
- (fun t1 t2 ->
- match t1,t2 with
- None , _ -> None
- | _ , t -> t) cc l
- with
- Invalid_argument _ -> assert false) in
- C.Meta (n, l')
- | C.Cast (te,ty) -> C.Cast (aux te, aux ty)
- | C.Prod (name,so,dest) -> C.Prod (name, aux so, aux dest)
- | C.Lambda (name,so,dest) -> C.Lambda (name, aux so, aux dest)
- | C.LetIn (name,so,dest) -> C.LetIn (name, aux so, aux dest)
- | C.Appl l -> C.Appl (List.map aux l)
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri,t) -> (uri, aux t)) exp_named_subst
- in
- C.Var (uri, exp_named_subst')
- | C.Const (uri, exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri,t) -> (uri, aux t)) exp_named_subst
- in
- C.Const (uri, exp_named_subst')
- | C.MutInd (uri,tyno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri,t) -> (uri, aux t)) exp_named_subst
- in
- C.MutInd (uri, tyno, exp_named_subst')
- | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri,t) -> (uri, aux t)) exp_named_subst
- in
- C.MutConstruct (uri, tyno, consno, exp_named_subst')
- | C.MutCase (uri,tyno,out,te,pl) ->
- C.MutCase (uri, tyno, aux out, aux te, List.map aux pl)
- | C.Fix (i,fl) ->
- let fl' =
- List.map
- (fun (name,j,ty,bo) -> (name, j, aux ty, aux bo)) fl
- in
- C.Fix (i, fl')
- | C.CoFix (i,fl) ->
- let fl' =
- List.map
- (fun (name,ty,bo) -> (name, aux ty, aux bo)) fl
- in
- C.CoFix (i, fl')
- in
- aux t *)
-
-(*** Functions to apply a substitution ***)
-
-let apply_subst_gen ~appl_fun subst term =
- let rec um_aux =
- let module C = Cic in
- let module S = CicSubstitution in
- function
- C.Rel _ as t -> t
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst
- in
- C.Var (uri, exp_named_subst')
- | C.Meta (i, l) ->
- (try
- let (_, t,_) = lookup_subst i subst in
- um_aux (S.subst_meta l t)
- with CicUtil.Subst_not_found _ ->
- (* unconstrained variable, i.e. free in subst*)
- let l' =
- List.map (function None -> None | Some t -> Some (um_aux t)) l
- in
- C.Meta (i,l'))
- | C.Sort _
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (um_aux te, um_aux ty)
- | C.Prod (n,s,t) -> C.Prod (n, um_aux s, um_aux t)
- | C.Lambda (n,s,t) -> C.Lambda (n, um_aux s, um_aux t)
- | C.LetIn (n,s,t) -> C.LetIn (n, um_aux s, um_aux t)
- | C.Appl (hd :: tl) -> appl_fun um_aux hd tl
- | C.Appl _ -> assert false
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst
- in
- C.Const (uri, exp_named_subst')
- | C.MutInd (uri,typeno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst
- in
- C.MutInd (uri,typeno,exp_named_subst')
- | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst
- in
- C.MutConstruct (uri,typeno,consno,exp_named_subst')
- | C.MutCase (sp,i,outty,t,pl) ->
- let pl' = List.map um_aux pl in
- C.MutCase (sp, i, um_aux outty, um_aux t, pl')
- | C.Fix (i, fl) ->
- let fl' =
- List.map (fun (name, i, ty, bo) -> (name, i, um_aux ty, um_aux bo)) fl
- in
- C.Fix (i, fl')
- | C.CoFix (i, fl) ->
- let fl' =
- List.map (fun (name, ty, bo) -> (name, um_aux ty, um_aux bo)) fl
- in
- C.CoFix (i, fl')
- in
- LibrarySync.merge_coercions (um_aux term)
-;;
-
-let apply_subst =
- let appl_fun um_aux he tl =
- let tl' = List.map um_aux tl in
- let t' =
- match um_aux he with
- Cic.Appl l -> Cic.Appl (l@tl')
- | he' -> Cic.Appl (he'::tl')
- in
- begin
- match he with
- Cic.Meta (m,_) -> CicReduction.head_beta_reduce t'
- | _ -> t'
- end
- in
- fun s t ->
-(* incr apply_subst_counter; *)
- apply_subst_gen ~appl_fun s t
-;;
-
-let rec apply_subst_context subst context =
-(*
- incr apply_subst_context_counter;
- context_length := !context_length + List.length context;
-*)
- List.fold_right
- (fun item context ->
- match item with
- | Some (n, Cic.Decl t) ->
- let t' = apply_subst subst t in
- Some (n, Cic.Decl t') :: context
- | Some (n, Cic.Def (t, ty)) ->
- let ty' =
- match ty with
- | None -> None
- | Some ty -> Some (apply_subst subst ty)
- in
- let t' = apply_subst subst t in
- Some (n, Cic.Def (t', ty')) :: context
- | None -> None :: context)
- context []
-
-let apply_subst_metasenv subst metasenv =
-(*
- incr apply_subst_metasenv_counter;
- metasenv_length := !metasenv_length + List.length metasenv;
-*)
- List.map
- (fun (n, context, ty) ->
- (n, apply_subst_context subst context, apply_subst subst ty))
- (List.filter
- (fun (i, _, _) -> not (List.mem_assoc i subst))
- metasenv)
-
-(***** Pretty printing functions ******)
-
-let ppterm subst term = CicPp.ppterm (apply_subst subst term)
-
-let ppterm_in_name_context subst term name_context =
- CicPp.pp (apply_subst subst term) name_context
-
-let ppterm_in_context subst term context =
- let name_context =
- List.map (function None -> None | Some (n,_) -> Some n) context
- in
- ppterm_in_name_context subst term name_context
-
-let ppcontext' ?(sep = "\n") subst context =
- let separate s = if s = "" then "" else s ^ sep in
- List.fold_right
- (fun context_entry (i,name_context) ->
- match context_entry with
- Some (n,Cic.Decl t) ->
- sprintf "%s%s : %s" (separate i) (CicPp.ppname n)
- (ppterm_in_name_context subst t name_context), (Some n)::name_context
- | Some (n,Cic.Def (bo,ty)) ->
- sprintf "%s%s : %s := %s" (separate i) (CicPp.ppname n)
- (match ty with
- None -> "_"
- | Some ty -> ppterm_in_name_context subst ty name_context)
- (ppterm_in_name_context subst bo name_context), (Some n)::name_context
- | None ->
- sprintf "%s_ :? _" (separate i), None::name_context
- ) context ("",[])
-
-let ppsubst_unfolded subst =
- String.concat "\n"
- (List.map
- (fun (idx, (c, t,_)) ->
- let context,name_context = ppcontext' ~sep:"; " subst c in
- sprintf "%s |- ?%d:= %s" context idx
- (ppterm_in_name_context subst t name_context))
- subst)
-(*
- Printf.sprintf "?%d := %s" idx (CicPp.ppterm term))
- subst) *)
-;;
-
-let ppsubst subst =
- String.concat "\n"
- (List.map
- (fun (idx, (c, t, _)) ->
- let context,name_context = ppcontext' ~sep:"; " [] c in
- sprintf "%s |- ?%d:= %s" context idx
- (ppterm_in_name_context [] t name_context))
- subst)
-;;
-
-let ppcontext ?sep subst context = fst (ppcontext' ?sep subst context)
-
-let ppmetasenv ?(sep = "\n") subst metasenv =
- String.concat sep
- (List.map
- (fun (i, c, t) ->
- let context,name_context = ppcontext' ~sep:"; " subst c in
- sprintf "%s |- ?%d: %s" context i
- (ppterm_in_name_context subst t name_context))
- (List.filter
- (fun (i, _, _) -> not (List.mem_assoc i subst))
- metasenv))
-
-let tempi_type_of_aux_subst = ref 0.0;;
-let tempi_subst = ref 0.0;;
-let tempi_type_of_aux = ref 0.0;;
-
-(**** DELIFT ****)
-(* the delift function takes in input a metavariable index, an ordered list of
- * optional terms [t1,...,tn] and a term t, and substitutes every tk = Some
- * (rel(nk)) with rel(k). Typically, the list of optional terms is the explicit
- * substitution that is applied to a metavariable occurrence and the result of
- * the delift function is a term the implicit variable can be substituted with
- * to make the term [t] unifiable with the metavariable occurrence. In general,
- * the problem is undecidable if we consider equivalence in place of alpha
- * convertibility. Our implementation, though, is even weaker than alpha
- * convertibility, since it replace the term [tk] if and only if [tk] is a Rel
- * (missing all the other cases). Does this matter in practice?
- * The metavariable index is the index of the metavariable that must not occur
- * in the term (for occur check).
- *)
-
-exception NotInTheList;;
-
-let position n =
- let rec aux k =
- function
- [] -> raise NotInTheList
- | (Some (Cic.Rel m))::_ when m=n -> k
- | _::tl -> aux (k+1) tl in
- aux 1
-;;
-
-exception Occur;;
-
-let rec force_does_not_occur subst to_be_restricted t =
- let module C = Cic in
- let more_to_be_restricted = ref [] in
- let rec aux k = function
- C.Rel r when List.mem (r - k) to_be_restricted -> raise Occur
- | C.Rel _
- | C.Sort _ as t -> t
- | C.Implicit _ -> assert false
- | C.Meta (n, l) ->
- (* we do not retrieve the term associated to ?n in subst since *)
- (* in this way we can restrict if something goes wrong *)
- let l' =
- let i = ref 0 in
- List.map
- (function t ->
- incr i ;
- match t with
- None -> None
- | Some t ->
- try
- Some (aux k t)
- with Occur ->
- more_to_be_restricted := (n,!i) :: !more_to_be_restricted;
- None)
- l
- in
- C.Meta (n, l')
- | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty)
- | C.Prod (name,so,dest) -> C.Prod (name, aux k so, aux (k+1) dest)
- | C.Lambda (name,so,dest) -> C.Lambda (name, aux k so, aux (k+1) dest)
- | C.LetIn (name,so,dest) -> C.LetIn (name, aux k so, aux (k+1) dest)
- | C.Appl l -> C.Appl (List.map (aux k) l)
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri,t) -> (uri, aux k t)) exp_named_subst
- in
- C.Var (uri, exp_named_subst')
- | C.Const (uri, exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri,t) -> (uri, aux k t)) exp_named_subst
- in
- C.Const (uri, exp_named_subst')
- | C.MutInd (uri,tyno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri,t) -> (uri, aux k t)) exp_named_subst
- in
- C.MutInd (uri, tyno, exp_named_subst')
- | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (fun (uri,t) -> (uri, aux k t)) exp_named_subst
- in
- C.MutConstruct (uri, tyno, consno, exp_named_subst')
- | C.MutCase (uri,tyno,out,te,pl) ->
- C.MutCase (uri, tyno, aux k out, aux k te, List.map (aux k) pl)
- | C.Fix (i,fl) ->
- let len = List.length fl in
- let k_plus_len = k + len in
- let fl' =
- List.map
- (fun (name,j,ty,bo) -> (name, j, aux k ty, aux k_plus_len bo)) fl
- in
- C.Fix (i, fl')
- | C.CoFix (i,fl) ->
- let len = List.length fl in
- let k_plus_len = k + len in
- let fl' =
- List.map
- (fun (name,ty,bo) -> (name, aux k ty, aux k_plus_len bo)) fl
- in
- C.CoFix (i, fl')
- in
- let res = aux 0 t in
- (!more_to_be_restricted, res)
-
-let rec restrict subst to_be_restricted metasenv =
- let names_of_context_indexes context indexes =
- String.concat ", "
- (List.map
- (fun i ->
- try
- match List.nth context (i-1) with
- | None -> assert false
- | Some (n, _) -> CicPp.ppname n
- with
- Failure _ -> assert false
- ) indexes)
- in
- let force_does_not_occur_in_context to_be_restricted = function
- | None -> [], None
- | Some (name, Cic.Decl t) ->
- let (more_to_be_restricted, t') =
- force_does_not_occur subst to_be_restricted t
- in
- more_to_be_restricted, Some (name, Cic.Decl t')
- | Some (name, Cic.Def (bo, ty)) ->
- let (more_to_be_restricted, bo') =
- force_does_not_occur subst to_be_restricted bo
- in
- let more_to_be_restricted, ty' =
- match ty with
- | None -> more_to_be_restricted, None
- | Some ty ->
- let more_to_be_restricted', ty' =
- force_does_not_occur subst to_be_restricted ty
- in
- more_to_be_restricted @ more_to_be_restricted',
- Some ty'
- in
- more_to_be_restricted, Some (name, Cic.Def (bo', ty'))
- in
- let rec erase i to_be_restricted n = function
- | [] -> [], to_be_restricted, []
- | hd::tl ->
- let more_to_be_restricted,restricted,tl' =
- erase (i+1) to_be_restricted n tl
- in
- let restrict_me = List.mem i restricted in
- if restrict_me then
- more_to_be_restricted, restricted, None:: tl'
- else
- (try
- let more_to_be_restricted', hd' =
- let delifted_restricted =
- let rec aux =
- function
- [] -> []
- | j::tl when j > i -> (j - i)::aux tl
- | _::tl -> aux tl
- in
- aux restricted
- in
- force_does_not_occur_in_context delifted_restricted hd
- in
- more_to_be_restricted @ more_to_be_restricted',
- restricted, hd' :: tl'
- with Occur ->
- more_to_be_restricted, (i :: restricted), None :: tl')
- in
- let (more_to_be_restricted, metasenv) = (* restrict metasenv *)
- List.fold_right
- (fun (n, context, t) (more, metasenv) ->
- let to_be_restricted =
- List.map snd (List.filter (fun (m, _) -> m = n) to_be_restricted)
- in
- let (more_to_be_restricted, restricted, context') =
- (* just an optimization *)
- if to_be_restricted = [] then
- [],[],context
- else
- erase 1 to_be_restricted n context
- in
- try
- let more_to_be_restricted', t' =
- force_does_not_occur subst restricted t
- in
- let metasenv' = (n, context', t') :: metasenv in
- (more @ more_to_be_restricted @ more_to_be_restricted',
- metasenv')
- with Occur ->
- raise (MetaSubstFailure (lazy (sprintf
- "Cannot restrict the context of the metavariable ?%d over the hypotheses %s since metavariable's type depends on at least one of them"
- n (names_of_context_indexes context to_be_restricted)))))
- metasenv ([], [])
- in
- let (more_to_be_restricted', subst) = (* restrict subst *)
- List.fold_right
- (* TODO: cambiare dopo l'aggiunta del ty *)
- (fun (n, (context, term,ty)) (more, subst') ->
- let to_be_restricted =
- List.map snd (List.filter (fun (m, _) -> m = n) to_be_restricted)
- in
- (try
- let (more_to_be_restricted, restricted, context') =
- (* just an optimization *)
- if to_be_restricted = [] then
- [], [], context
- else
- erase 1 to_be_restricted n context
- in
- let more_to_be_restricted', term' =
- force_does_not_occur subst restricted term
- in
- let more_to_be_restricted'', ty' =
- force_does_not_occur subst restricted ty in
- let subst' = (n, (context', term',ty')) :: subst' in
- let more =
- more @ more_to_be_restricted
- @ more_to_be_restricted'@more_to_be_restricted'' in
- (more, subst')
- with Occur ->
- let error_msg = lazy (sprintf
- "Cannot restrict the context of the metavariable ?%d over the hypotheses %s since ?%d is already instantiated with %s and at least one of the hypotheses occurs in the substituted term"
- n (names_of_context_indexes context to_be_restricted) n
- (ppterm subst term))
- in
- (* DEBUG
- debug_print (lazy error_msg);
- debug_print (lazy ("metasenv = \n" ^ (ppmetasenv metasenv subst)));
- debug_print (lazy ("subst = \n" ^ (ppsubst subst)));
- debug_print (lazy ("context = \n" ^ (ppcontext subst context))); *)
- raise (MetaSubstFailure error_msg)))
- subst ([], [])
- in
- match more_to_be_restricted @ more_to_be_restricted' with
- | [] -> (metasenv, subst)
- | l -> restrict subst l metasenv
-;;
-
-(*CSC: maybe we should rename delift in abstract, as I did in my dissertation *)(*Andrea: maybe not*)
-
-let delift n subst context metasenv l t =
-(* INVARIANT: we suppose that t is not another occurrence of Meta(n,_),
- otherwise the occur check does not make sense *)
-
-(*
- debug_print (lazy ("sto deliftando il termine " ^ (CicPp.ppterm t) ^ " rispetto
- al contesto locale " ^ (CicPp.ppterm (Cic.Meta(0,l)))));
-*)
-
- let module S = CicSubstitution in
- let l =
- let (_, canonical_context, _) = CicUtil.lookup_meta n metasenv in
- List.map2 (fun ct lt ->
- match (ct, lt) with
- | None, _ -> None
- | Some _, _ -> lt)
- canonical_context l
- in
- let to_be_restricted = ref [] in
- let rec deliftaux k =
- let module C = Cic in
- function
- C.Rel m ->
- if m <=k then
- C.Rel m (*CSC: che succede se c'e' un Def? Dovrebbe averlo gia' *)
- (*CSC: deliftato la regola per il LetIn *)
- (*CSC: FALSO! La regola per il LetIn non lo fa *)
- else
- (try
- match List.nth context (m-k-1) with
- Some (_,C.Def (t,_)) ->
- (*CSC: Hmmm. This bit of reduction is not in the spirit of *)
- (*CSC: first order unification. Does it help or does it harm? *)
- deliftaux k (S.lift m t)
- | Some (_,C.Decl t) ->
- C.Rel ((position (m-k) l) + k)
- | None -> raise (MetaSubstFailure (lazy "RelToHiddenHypothesis"))
- with
- Failure _ ->
- raise (MetaSubstFailure (lazy "Unbound variable found in deliftaux"))
- )
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
- in
- C.Var (uri,exp_named_subst')
- | C.Meta (i, l1) as t ->
- (try
- let (_,t,_) = CicUtil.lookup_subst i subst in
- deliftaux k (CicSubstitution.subst_meta l1 t)
- with CicUtil.Subst_not_found _ ->
- (* see the top level invariant *)
- if (i = n) then
- raise (MetaSubstFailure (lazy (sprintf
- "Cannot unify the metavariable ?%d with a term that has as subterm %s in which the same metavariable occurs (occur check)"
- i (ppterm subst t))))
- else
- begin
- (* I do not consider the term associated to ?i in subst since *)
- (* in this way I can restrict if something goes wrong. *)
- let rec deliftl j =
- function
- [] -> []
- | None::tl -> None::(deliftl (j+1) tl)
- | (Some t)::tl ->
- let l1' = (deliftl (j+1) tl) in
- try
- Some (deliftaux k t)::l1'
- with
- NotInTheList
- | MetaSubstFailure _ ->
- to_be_restricted :=
- (i,j)::!to_be_restricted ; None::l1'
- in
- let l' = deliftl 1 l1 in
- C.Meta(i,l')
- end)
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (deliftaux k te, deliftaux k ty)
- | C.Prod (n,s,t) -> C.Prod (n, deliftaux k s, deliftaux (k+1) t)
- | C.Lambda (n,s,t) -> C.Lambda (n, deliftaux k s, deliftaux (k+1) t)
- | C.LetIn (n,s,t) -> C.LetIn (n, deliftaux k s, deliftaux (k+1) t)
- | C.Appl l -> C.Appl (List.map (deliftaux k) l)
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
- in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,typeno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
- in
- C.MutInd (uri,typeno,exp_named_subst')
- | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
- in
- C.MutConstruct (uri,typeno,consno,exp_named_subst')
- | C.MutCase (sp,i,outty,t,pl) ->
- C.MutCase (sp, i, deliftaux k outty, deliftaux k t,
- List.map (deliftaux k) pl)
- | C.Fix (i, fl) ->
- let len = List.length fl in
- let liftedfl =
- List.map
- (fun (name, i, ty, bo) ->
- (name, i, deliftaux k ty, deliftaux (k+len) bo))
- fl
- in
- C.Fix (i, liftedfl)
- | C.CoFix (i, fl) ->
- let len = List.length fl in
- let liftedfl =
- List.map
- (fun (name, ty, bo) -> (name, deliftaux k ty, deliftaux (k+len) bo))
- fl
- in
- C.CoFix (i, liftedfl)
- in
- let res =
- try
- deliftaux 0 t
- with
- NotInTheList ->
- (* This is the case where we fail even first order unification. *)
- (* The reason is that our delift function is weaker than first *)
- (* order (in the sense of alpha-conversion). See comment above *)
- (* related to the delift function. *)
-(* debug_print (lazy "First Order UnificationFailure during delift") ;
-debug_print(lazy (sprintf
- "Error trying to abstract %s over [%s]: the algorithm only tried to abstract over bound variables"
- (ppterm subst t)
- (String.concat "; "
- (List.map
- (function Some t -> ppterm subst t | None -> "_") l
- )))); *)
- raise (Uncertain (lazy (sprintf
- "Error trying to abstract %s over [%s]: the algorithm only tried to abstract over bound variables"
- (ppterm subst t)
- (String.concat "; "
- (List.map
- (function Some t -> ppterm subst t | None -> "_")
- l)))))
- in
- let (metasenv, subst) = restrict subst !to_be_restricted metasenv in
- res, metasenv, subst
-;;
-
-(* delifts a term t of n levels strating from k, that is changes (Rel m)
- * to (Rel (m - n)) when m > (k + n). if k <= m < k + n delift fails
- *)
-let delift_rels_from subst metasenv k n =
- let rec liftaux subst metasenv k =
- let module C = Cic in
- function
- C.Rel m ->
- if m < k then
- C.Rel m, subst, metasenv
- else if m < k + n then
- raise DeliftingARelWouldCaptureAFreeVariable
- else
- C.Rel (m - n), subst, metasenv
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst',subst,metasenv =
- List.fold_right
- (fun (uri,t) (l,subst,metasenv) ->
- let t',subst,metasenv = liftaux subst metasenv k t in
- (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv)
- in
- C.Var (uri,exp_named_subst'),subst,metasenv
- | C.Meta (i,l) ->
- (try
- let (_, t,_) = lookup_subst i subst in
- liftaux subst metasenv k (CicSubstitution.subst_meta l t)
- with CicUtil.Subst_not_found _ ->
- let l',to_be_restricted,subst,metasenv =
- let rec aux con l subst metasenv =
- match l with
- [] -> [],[],subst,metasenv
- | he::tl ->
- let tl',to_be_restricted,subst,metasenv =
- aux (con + 1) tl subst metasenv in
- let he',more_to_be_restricted,subst,metasenv =
- match he with
- None -> None,[],subst,metasenv
- | Some t ->
- try
- let t',subst,metasenv = liftaux subst metasenv k t in
- Some t',[],subst,metasenv
- with
- DeliftingARelWouldCaptureAFreeVariable ->
- None,[i,con],subst,metasenv
- in
- he'::tl',more_to_be_restricted@to_be_restricted,subst,metasenv
- in
- aux 1 l subst metasenv in
- let metasenv,subst = restrict subst to_be_restricted metasenv in
- C.Meta(i,l'),subst,metasenv)
- | C.Sort _ as t -> t,subst,metasenv
- | C.Implicit _ as t -> t,subst,metasenv
- | C.Cast (te,ty) ->
- let te',subst,metasenv = liftaux subst metasenv k te in
- let ty',subst,metasenv = liftaux subst metasenv k ty in
- C.Cast (te',ty'),subst,metasenv
- | C.Prod (n,s,t) ->
- let s',subst,metasenv = liftaux subst metasenv k s in
- let t',subst,metasenv = liftaux subst metasenv (k+1) t in
- C.Prod (n,s',t'),subst,metasenv
- | C.Lambda (n,s,t) ->
- let s',subst,metasenv = liftaux subst metasenv k s in
- let t',subst,metasenv = liftaux subst metasenv (k+1) t in
- C.Lambda (n,s',t'),subst,metasenv
- | C.LetIn (n,s,t) ->
- let s',subst,metasenv = liftaux subst metasenv k s in
- let t',subst,metasenv = liftaux subst metasenv (k+1) t in
- C.LetIn (n,s',t'),subst,metasenv
- | C.Appl l ->
- let l',subst,metasenv =
- List.fold_right
- (fun t (l,subst,metasenv) ->
- let t',subst,metasenv = liftaux subst metasenv k t in
- t'::l,subst,metasenv) l ([],subst,metasenv) in
- C.Appl l',subst,metasenv
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst',subst,metasenv =
- List.fold_right
- (fun (uri,t) (l,subst,metasenv) ->
- let t',subst,metasenv = liftaux subst metasenv k t in
- (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv)
- in
- C.Const (uri,exp_named_subst'),subst,metasenv
- | C.MutInd (uri,tyno,exp_named_subst) ->
- let exp_named_subst',subst,metasenv =
- List.fold_right
- (fun (uri,t) (l,subst,metasenv) ->
- let t',subst,metasenv = liftaux subst metasenv k t in
- (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv)
- in
- C.MutInd (uri,tyno,exp_named_subst'),subst,metasenv
- | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
- let exp_named_subst',subst,metasenv =
- List.fold_right
- (fun (uri,t) (l,subst,metasenv) ->
- let t',subst,metasenv = liftaux subst metasenv k t in
- (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv)
- in
- C.MutConstruct (uri,tyno,consno,exp_named_subst'),subst,metasenv
- | C.MutCase (sp,i,outty,t,pl) ->
- let outty',subst,metasenv = liftaux subst metasenv k outty in
- let t',subst,metasenv = liftaux subst metasenv k t in
- let pl',subst,metasenv =
- List.fold_right
- (fun t (l,subst,metasenv) ->
- let t',subst,metasenv = liftaux subst metasenv k t in
- t'::l,subst,metasenv) pl ([],subst,metasenv)
- in
- C.MutCase (sp,i,outty',t',pl'),subst,metasenv
- | C.Fix (i, fl) ->
- let len = List.length fl in
- let liftedfl,subst,metasenv =
- List.fold_right
- (fun (name, i, ty, bo) (l,subst,metasenv) ->
- let ty',subst,metasenv = liftaux subst metasenv k ty in
- let bo',subst,metasenv = liftaux subst metasenv (k+len) bo in
- (name,i,ty',bo')::l,subst,metasenv
- ) fl ([],subst,metasenv)
- in
- C.Fix (i, liftedfl),subst,metasenv
- | C.CoFix (i, fl) ->
- let len = List.length fl in
- let liftedfl,subst,metasenv =
- List.fold_right
- (fun (name, ty, bo) (l,subst,metasenv) ->
- let ty',subst,metasenv = liftaux subst metasenv k ty in
- let bo',subst,metasenv = liftaux subst metasenv (k+len) bo in
- (name,ty',bo')::l,subst,metasenv
- ) fl ([],subst,metasenv)
- in
- C.CoFix (i, liftedfl),subst,metasenv
- in
- liftaux subst metasenv k
-
-let delift_rels subst metasenv n t =
- delift_rels_from subst metasenv 1 n t
-
-
-(**** END OF DELIFT ****)
-
-
-(** {2 Format-like pretty printers} *)
-
-let fpp_gen ppf s =
- Format.pp_print_string ppf s;
- Format.pp_print_newline ppf ();
- Format.pp_print_flush ppf ()
-
-let fppsubst ppf subst = fpp_gen ppf (ppsubst subst)
-let fppterm ppf term = fpp_gen ppf (CicPp.ppterm term)
-let fppmetasenv ppf metasenv = fpp_gen ppf (ppmetasenv [] metasenv)
-
+++ /dev/null
-(* 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
-*)
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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)
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-open Printf
-
-exception RefineFailure of string Lazy.t;;
-exception Uncertain of string Lazy.t;;
-exception AssertFailure of string Lazy.t;;
-
-let insert_coercions = ref true
-
-let debug_print = fun _ -> ()
-
-let profiler = HExtlib.profile "CicRefine.fo_unif"
-
-let fo_unif_subst subst context metasenv t1 t2 ugraph =
- try
-let foo () =
- CicUnification.fo_unif_subst subst context metasenv t1 t2 ugraph
-in profiler.HExtlib.profile foo ()
- with
- (CicUnification.UnificationFailure msg) -> raise (RefineFailure msg)
- | (CicUnification.Uncertain msg) -> raise (Uncertain msg)
-;;
-
-let enrich localization_tbl t ?(f = fun msg -> msg) exn =
- let exn' =
- match exn with
- RefineFailure msg -> RefineFailure (f msg)
- | Uncertain msg -> Uncertain (f msg)
- | _ -> assert false in
- let loc =
- try
- Cic.CicHash.find localization_tbl t
- with Not_found ->
- prerr_endline ("!!! NOT LOCALIZED: " ^ CicPp.ppterm t);
- assert false
- in
- raise (HExtlib.Localized (loc,exn'))
-
-let relocalize localization_tbl oldt newt =
- try
- let infos = Cic.CicHash.find localization_tbl oldt in
- Cic.CicHash.remove localization_tbl oldt;
- Cic.CicHash.add localization_tbl newt infos;
- with
- Not_found -> ()
-;;
-
-let rec split l n =
- match (l,n) with
- (l,0) -> ([], l)
- | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2)
- | (_,_) -> raise (AssertFailure (lazy "split: list too short"))
-;;
-
-let exp_impl metasenv subst context =
- function
- | Some `Type ->
- let (metasenv', idx) = CicMkImplicit.mk_implicit_type metasenv subst context in
- let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in
- metasenv', Cic.Meta (idx, irl)
- | Some `Closed ->
- let (metasenv', idx) = CicMkImplicit.mk_implicit metasenv subst [] in
- metasenv', Cic.Meta (idx, [])
- | None ->
- let (metasenv', idx) = CicMkImplicit.mk_implicit metasenv subst context in
- let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in
- metasenv', Cic.Meta (idx, irl)
- | _ -> assert false
-;;
-
-
-let rec type_of_constant uri ugraph =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let _ = CicTypeChecker.typecheck uri in
- let obj,u =
- try
- CicEnvironment.get_cooked_obj ugraph uri
- with Not_found -> assert false
- in
- match obj with
- C.Constant (_,_,ty,_,_) -> ty,u
- | C.CurrentProof (_,_,_,ty,_,_) -> ty,u
- | _ ->
- raise
- (RefineFailure (lazy ("Unknown constant definition " ^ U.string_of_uri uri)))
-
-and type_of_variable uri ugraph =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let _ = CicTypeChecker.typecheck uri in
- let obj,u =
- try
- CicEnvironment.get_cooked_obj ugraph uri
- with Not_found -> assert false
- in
- match obj with
- C.Variable (_,_,ty,_,_) -> ty,u
- | _ ->
- raise
- (RefineFailure
- (lazy ("Unknown variable definition " ^ UriManager.string_of_uri uri)))
-
-and type_of_mutual_inductive_defs uri i ugraph =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let _ = CicTypeChecker.typecheck uri in
- let obj,u =
- try
- CicEnvironment.get_cooked_obj ugraph uri
- with Not_found -> assert false
- in
- match obj with
- C.InductiveDefinition (dl,_,_,_) ->
- let (_,_,arity,_) = List.nth dl i in
- arity,u
- | _ ->
- raise
- (RefineFailure
- (lazy ("Unknown mutual inductive definition " ^ U.string_of_uri uri)))
-
-and type_of_mutual_inductive_constr uri i j ugraph =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let _ = CicTypeChecker.typecheck uri in
- let obj,u =
- try
- CicEnvironment.get_cooked_obj ugraph uri
- with Not_found -> assert false
- in
- match obj with
- C.InductiveDefinition (dl,_,_,_) ->
- let (_,_,_,cl) = List.nth dl i in
- let (_,ty) = List.nth cl (j-1) in
- ty,u
- | _ ->
- raise
- (RefineFailure
- (lazy
- ("Unkown mutual inductive definition " ^ U.string_of_uri uri)))
-
-
-(* type_of_aux' is just another name (with a different scope) for type_of_aux *)
-
-(* the check_branch function checks if a branch of a case is refinable.
- It returns a pair (outype_instance,args), a subst and a metasenv.
- outype_instance is the expected result of applying the case outtype
- to args.
- The problem is that outype is in general unknown, and we should
- try to synthesize it from the above information, that is in general
- a second order unification problem. *)
-
-and check_branch n context metasenv subst left_args_no actualtype term expectedtype ugraph =
- let module C = Cic in
- (* let module R = CicMetaSubst in *)
- let module R = CicReduction in
- match R.whd ~subst context expectedtype with
- C.MutInd (_,_,_) ->
- (n,context,actualtype, [term]), subst, metasenv, ugraph
- | C.Appl (C.MutInd (_,_,_)::tl) ->
- let (_,arguments) = split tl left_args_no in
- (n,context,actualtype, arguments@[term]), subst, metasenv, ugraph
- | C.Prod (name,so,de) ->
- (* we expect that the actual type of the branch has the due
- number of Prod *)
- (match R.whd ~subst context actualtype with
- C.Prod (name',so',de') ->
- let subst, metasenv, ugraph1 =
- fo_unif_subst subst context metasenv so so' ugraph in
- let term' =
- (match CicSubstitution.lift 1 term with
- C.Appl l -> C.Appl (l@[C.Rel 1])
- | t -> C.Appl [t ; C.Rel 1]) in
- (* we should also check that the name variable is anonymous in
- the actual type de' ?? *)
- check_branch (n+1)
- ((Some (name,(C.Decl so)))::context)
- metasenv subst left_args_no de' term' de ugraph1
- | _ -> raise (AssertFailure (lazy "Wrong number of arguments")))
- | _ -> raise (AssertFailure (lazy "Prod or MutInd expected"))
-
-and type_of_aux' ?(localization_tbl = Cic.CicHash.create 1) metasenv context t
- ugraph
-=
- let rec type_of_aux subst metasenv context t ugraph =
- let module C = Cic in
- let module S = CicSubstitution in
- let module U = UriManager in
- let (t',_,_,_,_) as res =
- match t with
- (* function *)
- C.Rel n ->
- (try
- match List.nth context (n - 1) with
- Some (_,C.Decl ty) ->
- t,S.lift n ty,subst,metasenv, ugraph
- | Some (_,C.Def (_,Some ty)) ->
- t,S.lift n ty,subst,metasenv, ugraph
- | Some (_,C.Def (bo,None)) ->
- let ty,ugraph =
- (* if it is in the context it must be already well-typed*)
- CicTypeChecker.type_of_aux' ~subst metasenv context
- (S.lift n bo) ugraph
- in
- t,ty,subst,metasenv,ugraph
- | None ->
- enrich localization_tbl t
- (RefineFailure (lazy "Rel to hidden hypothesis"))
- with
- _ ->
- enrich localization_tbl t
- (RefineFailure (lazy "Not a close term")))
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst',subst',metasenv',ugraph1 =
- check_exp_named_subst
- subst metasenv context exp_named_subst ugraph
- in
- let ty_uri,ugraph1 = type_of_variable uri ugraph in
- let ty =
- CicSubstitution.subst_vars exp_named_subst' ty_uri
- in
- C.Var (uri,exp_named_subst'),ty,subst',metasenv',ugraph1
- | C.Meta (n,l) ->
- (try
- let (canonical_context, term,ty) =
- CicUtil.lookup_subst n subst
- in
- let l',subst',metasenv',ugraph1 =
- check_metasenv_consistency n subst metasenv context
- canonical_context l ugraph
- in
- (* trust or check ??? *)
- C.Meta (n,l'),CicSubstitution.subst_meta l' ty,
- subst', metasenv', ugraph1
- (* type_of_aux subst metasenv
- context (CicSubstitution.subst_meta l term) *)
- with CicUtil.Subst_not_found _ ->
- let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in
- let l',subst',metasenv', ugraph1 =
- check_metasenv_consistency n subst metasenv context
- canonical_context l ugraph
- in
- C.Meta (n,l'),CicSubstitution.subst_meta l' ty,
- subst', metasenv',ugraph1)
- | C.Sort (C.Type tno) ->
- let tno' = CicUniv.fresh() in
- let ugraph1 = CicUniv.add_gt tno' tno ugraph in
- t,(C.Sort (C.Type tno')),subst,metasenv,ugraph1
- | C.Sort _ ->
- t,C.Sort (C.Type (CicUniv.fresh())),subst,metasenv,ugraph
- | C.Implicit infos ->
- let metasenv',t' = exp_impl metasenv subst context infos in
- type_of_aux subst metasenv' context t' ugraph
- | C.Cast (te,ty) ->
- let ty',_,subst',metasenv',ugraph1 =
- type_of_aux subst metasenv context ty ugraph
- in
- let te',inferredty,subst'',metasenv'',ugraph2 =
- type_of_aux subst' metasenv' context te ugraph1
- in
- (try
- let subst''',metasenv''',ugraph3 =
- fo_unif_subst subst'' context metasenv''
- inferredty ty' ugraph2
- in
- C.Cast (te',ty'),ty',subst''',metasenv''',ugraph3
- with
- exn ->
- enrich localization_tbl te'
- ~f:(fun _ ->
- lazy ("The term " ^
- CicMetaSubst.ppterm_in_context subst'' te'
- context ^ " has type " ^
- CicMetaSubst.ppterm_in_context subst'' inferredty
- context ^ " but is here used with type " ^
- CicMetaSubst.ppterm_in_context subst'' ty' context)) exn
- )
- | C.Prod (name,s,t) ->
- let carr t subst context = CicMetaSubst.apply_subst subst t in
- let coerce_to_sort in_source tgt_sort t type_to_coerce
- subst context metasenv uragph
- =
- if not !insert_coercions then
- t,type_to_coerce,subst,metasenv,ugraph
- else
- let coercion_src = carr type_to_coerce subst context in
- match coercion_src with
- | Cic.Sort _ ->
- t,type_to_coerce,subst,metasenv,ugraph
- | Cic.Meta _ as meta ->
- t, meta, subst, metasenv, ugraph
- | Cic.Cast _ as cast ->
- t, cast, subst, metasenv, ugraph
- | term ->
- let coercion_tgt = carr (Cic.Sort tgt_sort) subst context in
- let search = CoercGraph.look_for_coercion in
- let boh = search coercion_src coercion_tgt in
- (match boh with
- | CoercGraph.NoCoercion
- | CoercGraph.NotHandled _ ->
- enrich localization_tbl t
- (RefineFailure
- (lazy ("The term " ^
- CicMetaSubst.ppterm_in_context subst t context ^
- " is not a type since it has type " ^
- CicMetaSubst.ppterm_in_context
- subst coercion_src context ^ " that is not a sort")))
- | CoercGraph.NotMetaClosed ->
- enrich localization_tbl t
- (Uncertain
- (lazy ("The term " ^
- CicMetaSubst.ppterm_in_context subst t context ^
- " is not a type since it has type " ^
- CicMetaSubst.ppterm_in_context
- subst coercion_src context ^ " that is not a sort")))
- | CoercGraph.SomeCoercion c ->
- let newt, tty, subst, metasenv, ugraph =
- avoid_double_coercion
- subst metasenv ugraph
- (Cic.Appl[c;t]) coercion_tgt
- in
- newt, tty, subst, metasenv, ugraph)
- in
- let s',sort1,subst',metasenv',ugraph1 =
- type_of_aux subst metasenv context s ugraph
- in
- let s',sort1,subst', metasenv',ugraph1 =
- coerce_to_sort true (Cic.Type(CicUniv.fresh()))
- s' sort1 subst' context metasenv' ugraph1
- in
- let context_for_t = ((Some (name,(C.Decl s')))::context) in
- let t',sort2,subst'',metasenv'',ugraph2 =
- type_of_aux subst' metasenv'
- context_for_t t ugraph1
- in
- let t',sort2,subst'',metasenv'',ugraph2 =
- coerce_to_sort false (Cic.Type(CicUniv.fresh()))
- t' sort2 subst'' context_for_t metasenv'' ugraph2
- in
- let sop,subst''',metasenv''',ugraph3 =
- sort_of_prod subst'' metasenv''
- context (name,s') (sort1,sort2) ugraph2
- in
- C.Prod (name,s',t'),sop,subst''',metasenv''',ugraph3
- | C.Lambda (n,s,t) ->
-
- let s',sort1,subst',metasenv',ugraph1 =
- type_of_aux subst metasenv context s ugraph in
- let s',sort1,subst',metasenv',ugraph1 =
- if not !insert_coercions then
- s',sort1, subst', metasenv', ugraph1
- else
- match CicReduction.whd ~subst:subst' context sort1 with
- | C.Meta _ | C.Sort _ -> s',sort1, subst', metasenv', ugraph1
- | coercion_src ->
- let coercion_tgt = Cic.Sort (Cic.Type (CicUniv.fresh())) in
- let search = CoercGraph.look_for_coercion in
- let boh = search coercion_src coercion_tgt in
- match boh with
- | CoercGraph.SomeCoercion c ->
- let newt, tty, subst', metasenv', ugraph1 =
- avoid_double_coercion
- subst' metasenv' ugraph1
- (Cic.Appl[c;s']) coercion_tgt
- in
- newt, tty, subst', metasenv', ugraph1
- | CoercGraph.NoCoercion
- | CoercGraph.NotHandled _ ->
- enrich localization_tbl s'
- (RefineFailure
- (lazy ("The term " ^
- CicMetaSubst.ppterm_in_context subst s' context ^
- " is not a type since it has type " ^
- CicMetaSubst.ppterm_in_context
- subst coercion_src context ^ " that is not a sort")))
- | CoercGraph.NotMetaClosed ->
- enrich localization_tbl s'
- (Uncertain
- (lazy ("The term " ^
- CicMetaSubst.ppterm_in_context subst s' context ^
- " is not a type since it has type " ^
- CicMetaSubst.ppterm_in_context
- subst coercion_src context ^ " that is not a sort")))
- in
- let context_for_t = ((Some (n,(C.Decl s')))::context) in
- let t',type2,subst'',metasenv'',ugraph2 =
- type_of_aux subst' metasenv' context_for_t t ugraph1
- in
- C.Lambda (n,s',t'),C.Prod (n,s',type2),
- subst'',metasenv'',ugraph2
- | C.LetIn (n,s,t) ->
- (* only to check if s is well-typed *)
- let s',ty,subst',metasenv',ugraph1 =
- type_of_aux subst metasenv context s ugraph
- in
- let context_for_t = ((Some (n,(C.Def (s',Some ty))))::context) in
-
- let t',inferredty,subst'',metasenv'',ugraph2 =
- type_of_aux subst' metasenv'
- context_for_t t ugraph1
- in
- (* One-step LetIn reduction.
- * Even faster than the previous solution.
- * Moreover the inferred type is closer to the expected one.
- *)
- C.LetIn (n,s',t'),CicSubstitution.subst s' inferredty,
- subst'',metasenv'',ugraph2
- | C.Appl (he::((_::_) as tl)) ->
- let he',hetype,subst',metasenv',ugraph1 =
- type_of_aux subst metasenv context he ugraph
- in
- let tlbody_and_type,subst'',metasenv'',ugraph2 =
- List.fold_right
- (fun x (res,subst,metasenv,ugraph) ->
- let x',ty,subst',metasenv',ugraph1 =
- type_of_aux subst metasenv context x ugraph
- in
- (x', ty)::res,subst',metasenv',ugraph1
- ) tl ([],subst',metasenv',ugraph1)
- in
- let tl',applty,subst''',metasenv''',ugraph3 =
- eat_prods true subst'' metasenv'' context
- hetype tlbody_and_type ugraph2
- in
- avoid_double_coercion
- subst''' metasenv''' ugraph3 (C.Appl (he'::tl')) applty
- | C.Appl _ -> assert false
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst',subst',metasenv',ugraph1 =
- check_exp_named_subst subst metasenv context
- exp_named_subst ugraph in
- let ty_uri,ugraph2 = type_of_constant uri ugraph1 in
- let cty =
- CicSubstitution.subst_vars exp_named_subst' ty_uri
- in
- C.Const (uri,exp_named_subst'),cty,subst',metasenv',ugraph2
- | C.MutInd (uri,i,exp_named_subst) ->
- let exp_named_subst',subst',metasenv',ugraph1 =
- check_exp_named_subst subst metasenv context
- exp_named_subst ugraph
- in
- let ty_uri,ugraph2 = type_of_mutual_inductive_defs uri i ugraph1 in
- let cty =
- CicSubstitution.subst_vars exp_named_subst' ty_uri in
- C.MutInd (uri,i,exp_named_subst'),cty,subst',metasenv',ugraph2
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let exp_named_subst',subst',metasenv',ugraph1 =
- check_exp_named_subst subst metasenv context
- exp_named_subst ugraph
- in
- let ty_uri,ugraph2 =
- type_of_mutual_inductive_constr uri i j ugraph1
- in
- let cty =
- CicSubstitution.subst_vars exp_named_subst' ty_uri
- in
- C.MutConstruct (uri,i,j,exp_named_subst'),cty,subst',
- metasenv',ugraph2
- | C.MutCase (uri, i, outtype, term, pl) ->
- (* first, get the inductive type (and noparams)
- * in the environment *)
- let (_,b,arity,constructors), expl_params, no_left_params,ugraph =
- let _ = CicTypeChecker.typecheck uri in
- let obj,u = CicEnvironment.get_cooked_obj ugraph uri in
- match obj with
- C.InductiveDefinition (l,expl_params,parsno,_) ->
- List.nth l i , expl_params, parsno, u
- | _ ->
- enrich localization_tbl t
- (RefineFailure
- (lazy ("Unkown mutual inductive definition " ^
- U.string_of_uri uri)))
- in
- let rec count_prod t =
- match CicReduction.whd ~subst context t with
- C.Prod (_, _, t) -> 1 + (count_prod t)
- | _ -> 0
- in
- let no_args = count_prod arity in
- (* now, create a "generic" MutInd *)
- let metasenv,left_args =
- CicMkImplicit.n_fresh_metas metasenv subst context no_left_params
- in
- let metasenv,right_args =
- let no_right_params = no_args - no_left_params in
- if no_right_params < 0 then assert false
- else CicMkImplicit.n_fresh_metas
- metasenv subst context no_right_params
- in
- let metasenv,exp_named_subst =
- CicMkImplicit.fresh_subst metasenv subst context expl_params in
- let expected_type =
- if no_args = 0 then
- C.MutInd (uri,i,exp_named_subst)
- else
- C.Appl
- (C.MutInd (uri,i,exp_named_subst)::(left_args @ right_args))
- in
- (* check consistency with the actual type of term *)
- let term',actual_type,subst,metasenv,ugraph1 =
- type_of_aux subst metasenv context term ugraph in
- let expected_type',_, subst, metasenv,ugraph2 =
- type_of_aux subst metasenv context expected_type ugraph1
- in
- let actual_type = CicReduction.whd ~subst context actual_type in
- let subst,metasenv,ugraph3 =
- try
- fo_unif_subst subst context metasenv
- expected_type' actual_type ugraph2
- with
- exn ->
- enrich localization_tbl term' exn
- ~f:(function _ ->
- lazy ("The term " ^
- CicMetaSubst.ppterm_in_context subst term'
- context ^ " has type " ^
- CicMetaSubst.ppterm_in_context subst actual_type
- context ^ " but is here used with type " ^
- CicMetaSubst.ppterm_in_context subst expected_type' context))
- in
- let rec instantiate_prod t =
- function
- [] -> t
- | he::tl ->
- match CicReduction.whd ~subst context t with
- C.Prod (_,_,t') ->
- instantiate_prod (CicSubstitution.subst he t') tl
- | _ -> assert false
- in
- let arity_instantiated_with_left_args =
- instantiate_prod arity left_args in
- (* TODO: check if the sort elimination
- * is allowed: [(I q1 ... qr)|B] *)
- let (pl',_,outtypeinstances,subst,metasenv,ugraph4) =
- List.fold_left
- (fun (pl,j,outtypeinstances,subst,metasenv,ugraph) p ->
- let constructor =
- if left_args = [] then
- (C.MutConstruct (uri,i,j,exp_named_subst))
- else
- (C.Appl
- (C.MutConstruct (uri,i,j,exp_named_subst)::left_args))
- in
- let p',actual_type,subst,metasenv,ugraph1 =
- type_of_aux subst metasenv context p ugraph
- in
- let constructor',expected_type, subst, metasenv,ugraph2 =
- type_of_aux subst metasenv context constructor ugraph1
- in
- let outtypeinstance,subst,metasenv,ugraph3 =
- check_branch 0 context metasenv subst no_left_params
- actual_type constructor' expected_type ugraph2
- in
- (pl @ [p'],j+1,
- outtypeinstance::outtypeinstances,subst,metasenv,ugraph3))
- ([],1,[],subst,metasenv,ugraph3) pl
- in
-
- (* we are left to check that the outype matches his instances.
- The easy case is when the outype is specified, that amount
- to a trivial check. Otherwise, we should guess a type from
- its instances
- *)
-
- let outtype,outtypety, subst, metasenv,ugraph4 =
- type_of_aux subst metasenv context outtype ugraph4 in
- (match outtype with
- | C.Meta (n,l) ->
- (let candidate,ugraph5,metasenv,subst =
- let exp_name_subst, metasenv =
- let o,_ =
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
- in
- let uris = CicUtil.params_of_obj o in
- List.fold_right (
- fun uri (acc,metasenv) ->
- let metasenv',new_meta =
- CicMkImplicit.mk_implicit metasenv subst context
- in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable
- context
- in
- (uri, Cic.Meta(new_meta,irl))::acc, metasenv'
- ) uris ([],metasenv)
- in
- let ty =
- match left_args,right_args with
- [],[] -> Cic.MutInd(uri, i, exp_name_subst)
- | _,_ ->
- let rec mk_right_args =
- function
- 0 -> []
- | n -> (Cic.Rel n)::(mk_right_args (n - 1))
- in
- let right_args_no = List.length right_args in
- let lifted_left_args =
- List.map (CicSubstitution.lift right_args_no) left_args
- in
- Cic.Appl (Cic.MutInd(uri,i,exp_name_subst)::
- (lifted_left_args @ mk_right_args right_args_no))
- in
- let fresh_name =
- FreshNamesGenerator.mk_fresh_name ~subst metasenv
- context Cic.Anonymous ~typ:ty
- in
- match outtypeinstances with
- | [] ->
- let extended_context =
- let rec add_right_args =
- function
- Cic.Prod (name,ty,t) ->
- Some (name,Cic.Decl ty)::(add_right_args t)
- | _ -> []
- in
- (Some (fresh_name,Cic.Decl ty))::
- (List.rev
- (add_right_args arity_instantiated_with_left_args))@
- context
- in
- let metasenv,new_meta =
- CicMkImplicit.mk_implicit metasenv subst extended_context
- in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable
- extended_context
- in
- let rec add_lambdas b =
- function
- Cic.Prod (name,ty,t) ->
- Cic.Lambda (name,ty,(add_lambdas b t))
- | _ -> Cic.Lambda (fresh_name, ty, b)
- in
- let candidate =
- add_lambdas (Cic.Meta (new_meta,irl))
- arity_instantiated_with_left_args
- in
- (Some candidate),ugraph4,metasenv,subst
- | (constructor_args_no,_,instance,_)::tl ->
- try
- let instance',subst,metasenv =
- CicMetaSubst.delift_rels subst metasenv
- constructor_args_no instance
- in
- let candidate,ugraph,metasenv,subst =
- List.fold_left (
- fun (candidate_oty,ugraph,metasenv,subst)
- (constructor_args_no,_,instance,_) ->
- match candidate_oty with
- | None -> None,ugraph,metasenv,subst
- | Some ty ->
- try
- let instance',subst,metasenv =
- CicMetaSubst.delift_rels subst metasenv
- constructor_args_no instance
- in
- let subst,metasenv,ugraph =
- fo_unif_subst subst context metasenv
- instance' ty ugraph
- in
- candidate_oty,ugraph,metasenv,subst
- with
- CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable
- | CicUnification.UnificationFailure _
- | CicUnification.Uncertain _ ->
- None,ugraph,metasenv,subst
- ) (Some instance',ugraph4,metasenv,subst) tl
- in
- match candidate with
- | None -> None, ugraph,metasenv,subst
- | Some t ->
- let rec add_lambdas n b =
- function
- Cic.Prod (name,ty,t) ->
- Cic.Lambda (name,ty,(add_lambdas (n + 1) b t))
- | _ ->
- Cic.Lambda (fresh_name, ty,
- CicSubstitution.lift (n + 1) t)
- in
- Some
- (add_lambdas 0 t arity_instantiated_with_left_args),
- ugraph,metasenv,subst
- with CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
- None,ugraph4,metasenv,subst
- in
- match candidate with
- | None -> raise (Uncertain (lazy "can't solve an higher order unification problem"))
- | Some candidate ->
- let subst,metasenv,ugraph =
- fo_unif_subst subst context metasenv
- candidate outtype ugraph5
- in
- C.MutCase (uri, i, outtype, term', pl'),
- CicReduction.head_beta_reduce
- (CicMetaSubst.apply_subst subst
- (Cic.Appl (outtype::right_args@[term']))),
- subst,metasenv,ugraph)
- | _ -> (* easy case *)
- let tlbody_and_type,subst,metasenv,ugraph4 =
- List.fold_right
- (fun x (res,subst,metasenv,ugraph) ->
- let x',ty,subst',metasenv',ugraph1 =
- type_of_aux subst metasenv context x ugraph
- in
- (x', ty)::res,subst',metasenv',ugraph1
- ) (right_args @ [term']) ([],subst,metasenv,ugraph4)
- in
- let _,_,subst,metasenv,ugraph4 =
- eat_prods false subst metasenv context
- outtypety tlbody_and_type ugraph4
- in
- let _,_, subst, metasenv,ugraph5 =
- type_of_aux subst metasenv context
- (C.Appl ((outtype :: right_args) @ [term'])) ugraph4
- in
- let (subst,metasenv,ugraph6) =
- List.fold_left
- (fun (subst,metasenv,ugraph)
- (constructor_args_no,context,instance,args) ->
- let instance' =
- let appl =
- let outtype' =
- CicSubstitution.lift constructor_args_no outtype
- in
- C.Appl (outtype'::args)
- in
- CicReduction.whd ~subst context appl
- in
- fo_unif_subst subst context metasenv
- instance instance' ugraph)
- (subst,metasenv,ugraph5) outtypeinstances
- in
- C.MutCase (uri, i, outtype, term', pl'),
- CicReduction.head_beta_reduce
- (CicMetaSubst.apply_subst subst
- (C.Appl(outtype::right_args@[term]))),
- subst,metasenv,ugraph6)
- | C.Fix (i,fl) ->
- let fl_ty',subst,metasenv,types,ugraph1 =
- List.fold_left
- (fun (fl,subst,metasenv,types,ugraph) (n,_,ty,_) ->
- let ty',_,subst',metasenv',ugraph1 =
- type_of_aux subst metasenv context ty ugraph
- in
- fl @ [ty'],subst',metasenv',
- Some (C.Name n,(C.Decl ty')) :: types, ugraph
- ) ([],subst,metasenv,[],ugraph) fl
- in
- let len = List.length types in
- let context' = types@context in
- let fl_bo',subst,metasenv,ugraph2 =
- List.fold_left
- (fun (fl,subst,metasenv,ugraph) ((name,x,_,bo),ty) ->
- let bo',ty_of_bo,subst,metasenv,ugraph1 =
- type_of_aux subst metasenv context' bo ugraph
- in
- let subst',metasenv',ugraph' =
- fo_unif_subst subst context' metasenv
- ty_of_bo (CicSubstitution.lift len ty) ugraph1
- in
- fl @ [bo'] , subst',metasenv',ugraph'
- ) ([],subst,metasenv,ugraph1) (List.combine fl fl_ty')
- in
- let ty = List.nth fl_ty' i in
- (* now we have the new ty in fl_ty', the new bo in fl_bo',
- * and we want the new fl with bo' and ty' injected in the right
- * place.
- *)
- let rec map3 f l1 l2 l3 =
- match l1,l2,l3 with
- | [],[],[] -> []
- | h1::tl1,h2::tl2,h3::tl3 -> (f h1 h2 h3) :: (map3 f tl1 tl2 tl3)
- | _ -> assert false
- in
- let fl'' = map3 (fun ty' bo' (name,x,ty,bo) -> (name,x,ty',bo') )
- fl_ty' fl_bo' fl
- in
- C.Fix (i,fl''),ty,subst,metasenv,ugraph2
- | C.CoFix (i,fl) ->
- let fl_ty',subst,metasenv,types,ugraph1 =
- List.fold_left
- (fun (fl,subst,metasenv,types,ugraph) (n,ty,_) ->
- let ty',_,subst',metasenv',ugraph1 =
- type_of_aux subst metasenv context ty ugraph
- in
- fl @ [ty'],subst',metasenv',
- Some (C.Name n,(C.Decl ty')) :: types, ugraph1
- ) ([],subst,metasenv,[],ugraph) fl
- in
- let len = List.length types in
- let context' = types@context in
- let fl_bo',subst,metasenv,ugraph2 =
- List.fold_left
- (fun (fl,subst,metasenv,ugraph) ((name,_,bo),ty) ->
- let bo',ty_of_bo,subst,metasenv,ugraph1 =
- type_of_aux subst metasenv context' bo ugraph
- in
- let subst',metasenv',ugraph' =
- fo_unif_subst subst context' metasenv
- ty_of_bo (CicSubstitution.lift len ty) ugraph1
- in
- fl @ [bo'],subst',metasenv',ugraph'
- ) ([],subst,metasenv,ugraph1) (List.combine fl fl_ty')
- in
- let ty = List.nth fl_ty' i in
- (* now we have the new ty in fl_ty', the new bo in fl_bo',
- * and we want the new fl with bo' and ty' injected in the right
- * place.
- *)
- let rec map3 f l1 l2 l3 =
- match l1,l2,l3 with
- | [],[],[] -> []
- | h1::tl1,h2::tl2,h3::tl3 -> (f h1 h2 h3) :: (map3 f tl1 tl2 tl3)
- | _ -> assert false
- in
- let fl'' = map3 (fun ty' bo' (name,ty,bo) -> (name,ty',bo') )
- fl_ty' fl_bo' fl
- in
- C.CoFix (i,fl''),ty,subst,metasenv,ugraph2
- in
- relocalize localization_tbl t t';
- res
-
- and avoid_double_coercion subst metasenv ugraph t ty =
- match t with
- | (Cic.Appl [ c1 ; (Cic.Appl [c2; head]) ]) when
- CoercGraph.is_a_coercion c1 && CoercGraph.is_a_coercion c2 ->
- let source_carr = CoercGraph.source_of c2 in
- let tgt_carr = CicMetaSubst.apply_subst subst ty in
- (match CoercGraph.look_for_coercion source_carr tgt_carr
- with
- | CoercGraph.SomeCoercion c ->
- Cic.Appl [ c ; head ], ty, subst,metasenv,ugraph
- | _ -> assert false) (* the composite coercion must exist *)
- | _ -> t, ty, subst, metasenv, ugraph
-
- (* check_metasenv_consistency checks that the "canonical" context of a
- metavariable is consitent - up to relocation via the relocation list l -
- with the actual context *)
- and check_metasenv_consistency
- metano subst metasenv context canonical_context l ugraph
- =
- let module C = Cic in
- let module R = CicReduction in
- let module S = CicSubstitution in
- let lifted_canonical_context =
- let rec aux i =
- function
- [] -> []
- | (Some (n,C.Decl t))::tl ->
- (Some (n,C.Decl (S.subst_meta l (S.lift i t))))::(aux (i+1) tl)
- | (Some (n,C.Def (t,None)))::tl ->
- (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None)))::(aux (i+1) tl)
- | None::tl -> None::(aux (i+1) tl)
- | (Some (n,C.Def (t,Some ty)))::tl ->
- (Some (n,
- C.Def ((S.subst_meta l (S.lift i t)),
- Some (S.subst_meta l (S.lift i ty))))) :: (aux (i+1) tl)
- in
- aux 1 canonical_context
- in
- try
- List.fold_left2
- (fun (l,subst,metasenv,ugraph) t ct ->
- match (t,ct) with
- _,None ->
- l @ [None],subst,metasenv,ugraph
- | Some t,Some (_,C.Def (ct,_)) ->
- let subst',metasenv',ugraph' =
- (try
- fo_unif_subst subst context metasenv t ct ugraph
- with e -> raise (RefineFailure (lazy (sprintf "The local context is not consistent with the canonical context, since %s cannot be unified with %s. Reason: %s" (CicMetaSubst.ppterm subst t) (CicMetaSubst.ppterm subst ct) (match e with AssertFailure msg -> Lazy.force msg | _ -> (Printexc.to_string e))))))
- in
- l @ [Some t],subst',metasenv',ugraph'
- | Some t,Some (_,C.Decl ct) ->
- let t',inferredty,subst',metasenv',ugraph1 =
- type_of_aux subst metasenv context t ugraph
- in
- let subst'',metasenv'',ugraph2 =
- (try
- fo_unif_subst
- subst' context metasenv' inferredty ct ugraph1
- with e -> raise (RefineFailure (lazy (sprintf "The local context is not consistent with the canonical context, since the type %s of %s cannot be unified with the expected type %s. Reason: %s" (CicMetaSubst.ppterm subst' inferredty) (CicMetaSubst.ppterm subst' t) (CicMetaSubst.ppterm subst' ct) (match e with AssertFailure msg -> Lazy.force msg | RefineFailure msg -> Lazy.force msg | _ -> (Printexc.to_string e))))))
- in
- l @ [Some t'], subst'',metasenv'',ugraph2
- | None, Some _ ->
- raise (RefineFailure (lazy (sprintf "Not well typed metavariable instance %s: the local context does not instantiate an hypothesis even if the hypothesis is not restricted in the canonical context %s" (CicMetaSubst.ppterm subst (Cic.Meta (metano, l))) (CicMetaSubst.ppcontext subst canonical_context))))) ([],subst,metasenv,ugraph) l lifted_canonical_context
- with
- Invalid_argument _ ->
- raise
- (RefineFailure
- (lazy (sprintf
- "Not well typed metavariable instance %s: the length of the local context does not match the length of the canonical context %s"
- (CicMetaSubst.ppterm subst (Cic.Meta (metano, l)))
- (CicMetaSubst.ppcontext subst canonical_context))))
-
- and check_exp_named_subst metasubst metasenv context tl ugraph =
- let rec check_exp_named_subst_aux metasubst metasenv substs tl ugraph =
- match tl with
- [] -> [],metasubst,metasenv,ugraph
- | (uri,t)::tl ->
- let ty_uri,ugraph1 = type_of_variable uri ugraph in
- let typeofvar =
- CicSubstitution.subst_vars substs ty_uri in
- (* CSC: why was this code here? it is wrong
- (match CicEnvironment.get_cooked_obj ~trust:false uri with
- Cic.Variable (_,Some bo,_,_) ->
- raise
- (RefineFailure (lazy
- "A variable with a body can not be explicit substituted"))
- | Cic.Variable (_,None,_,_) -> ()
- | _ ->
- raise
- (RefineFailure (lazy
- ("Unkown variable definition " ^ UriManager.string_of_uri uri)))
- ) ;
- *)
- let t',typeoft,metasubst',metasenv',ugraph2 =
- type_of_aux metasubst metasenv context t ugraph1 in
- let subst = uri,t' in
- let metasubst'',metasenv'',ugraph3 =
- try
- fo_unif_subst
- metasubst' context metasenv' typeoft typeofvar ugraph2
- with _ ->
- raise (RefineFailure (lazy
- ("Wrong Explicit Named Substitution: " ^
- CicMetaSubst.ppterm metasubst' typeoft ^
- " not unifiable with " ^
- CicMetaSubst.ppterm metasubst' typeofvar)))
- in
- (* FIXME: no mere tail recursive! *)
- let exp_name_subst, metasubst''', metasenv''', ugraph4 =
- check_exp_named_subst_aux
- metasubst'' metasenv'' (substs@[subst]) tl ugraph3
- in
- ((uri,t')::exp_name_subst), metasubst''', metasenv''', ugraph4
- in
- check_exp_named_subst_aux metasubst metasenv [] tl ugraph
-
-
- and sort_of_prod subst metasenv context (name,s) (t1, t2) ugraph =
- let module C = Cic in
- let context_for_t2 = (Some (name,C.Decl s))::context in
- let t1'' = CicReduction.whd ~subst context t1 in
- let t2'' = CicReduction.whd ~subst context_for_t2 t2 in
- match (t1'', t2'') with
- (C.Sort s1, C.Sort s2)
- when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) ->
- (* different than Coq manual!!! *)
- C.Sort s2,subst,metasenv,ugraph
- | (C.Sort (C.Type t1), C.Sort (C.Type t2)) ->
- let t' = CicUniv.fresh() in
- let ugraph1 = CicUniv.add_ge t' t1 ugraph in
- let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in
- C.Sort (C.Type t'),subst,metasenv,ugraph2
- | (C.Sort _,C.Sort (C.Type t1)) ->
- C.Sort (C.Type t1),subst,metasenv,ugraph
- | (C.Meta _, C.Sort _) -> t2'',subst,metasenv,ugraph
- | (C.Sort _,C.Meta _) | (C.Meta _,C.Meta _) ->
- (* TODO how can we force the meta to become a sort? If we don't we
- * brake the invariant that refine produce only well typed terms *)
- (* TODO if we check the non meta term and if it is a sort then we
- * are likely to know the exact value of the result e.g. if the rhs
- * is a Sort (Prop | Set | CProp) then the result is the rhs *)
- let (metasenv,idx) =
- CicMkImplicit.mk_implicit_sort metasenv subst in
- let (subst, metasenv,ugraph1) =
- fo_unif_subst subst context_for_t2 metasenv
- (C.Meta (idx,[])) t2'' ugraph
- in
- t2'',subst,metasenv,ugraph1
- | _,_ ->
- raise
- (RefineFailure
- (lazy
- (sprintf
- ("Two sorts were expected, found %s " ^^
- "(that reduces to %s) and %s (that reduces to %s)")
- (CicPp.ppterm t1) (CicPp.ppterm t1'') (CicPp.ppterm t2)
- (CicPp.ppterm t2''))))
-
- and eat_prods
- allow_coercions subst metasenv context hetype tlbody_and_type ugraph
- =
- let rec mk_prod metasenv context' =
- function
- [] ->
- let (metasenv, idx) =
- CicMkImplicit.mk_implicit_type metasenv subst context'
- in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context'
- in
- metasenv,Cic.Meta (idx, irl)
- | (_,argty)::tl ->
- let (metasenv, idx) =
- CicMkImplicit.mk_implicit_type metasenv subst context'
- in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context'
- in
- let meta = Cic.Meta (idx,irl) in
- let name =
- (* The name must be fresh for context. *)
- (* Nevertheless, argty is well-typed only in context. *)
- (* Thus I generate a name (name_hint) in context and *)
- (* then I generate a name --- using the hint name_hint *)
- (* --- that is fresh in context'. *)
- let name_hint =
- (* Cic.Name "pippo" *)
- FreshNamesGenerator.mk_fresh_name ~subst metasenv
- (* (CicMetaSubst.apply_subst_metasenv subst metasenv) *)
- (CicMetaSubst.apply_subst_context subst context)
- Cic.Anonymous
- ~typ:(CicMetaSubst.apply_subst subst argty)
- in
- (* [] and (Cic.Sort Cic.prop) are dummy: they will not be used *)
- FreshNamesGenerator.mk_fresh_name ~subst
- [] context' name_hint ~typ:(Cic.Sort Cic.Prop)
- in
- let metasenv,target =
- mk_prod metasenv ((Some (name, Cic.Decl meta))::context') tl
- in
- metasenv,Cic.Prod (name,meta,target)
- in
- let metasenv,hetype' = mk_prod metasenv context tlbody_and_type in
- let (subst, metasenv,ugraph1) =
- try
- fo_unif_subst subst context metasenv hetype hetype' ugraph
- with exn ->
- debug_print (lazy (Printf.sprintf "hetype=%s\nhetype'=%s\nmetasenv=%s\nsubst=%s"
- (CicPp.ppterm hetype)
- (CicPp.ppterm hetype')
- (CicMetaSubst.ppmetasenv [] metasenv)
- (CicMetaSubst.ppsubst subst)));
- raise exn
-
- in
- let rec eat_prods metasenv subst context hetype ugraph =
- function
- | [] -> [],metasenv,subst,hetype,ugraph
- | (hete, hety)::tl ->
- (match hetype with
- Cic.Prod (n,s,t) ->
- let arg,subst,metasenv,ugraph1 =
- try
- let subst,metasenv,ugraph1 =
- fo_unif_subst subst context metasenv hety s ugraph
- in
- hete,subst,metasenv,ugraph1
- with exn when allow_coercions && !insert_coercions ->
- (* we search a coercion from hety to s *)
- let coer, tgt_carr =
- let carr t subst context =
- CicMetaSubst.apply_subst subst t
- in
- let c_hety = carr hety subst context in
- let c_s = carr s subst context in
- CoercGraph.look_for_coercion c_hety c_s, c_s
- in
- (match coer with
- | CoercGraph.NoCoercion
- | CoercGraph.NotHandled _ ->
- enrich localization_tbl hete
- (RefineFailure
- (lazy ("The term " ^
- CicMetaSubst.ppterm_in_context subst hete
- context ^ " has type " ^
- CicMetaSubst.ppterm_in_context subst hety
- context ^ " but is here used with type " ^
- CicMetaSubst.ppterm_in_context subst s context
- (* "\nReason: " ^ Lazy.force e*))))
- | CoercGraph.NotMetaClosed ->
- enrich localization_tbl hete
- (Uncertain
- (lazy ("The term " ^
- CicMetaSubst.ppterm_in_context subst hete
- context ^ " has type " ^
- CicMetaSubst.ppterm_in_context subst hety
- context ^ " but is here used with type " ^
- CicMetaSubst.ppterm_in_context subst s context
- (* "\nReason: " ^ Lazy.force e*))))
- | CoercGraph.SomeCoercion c ->
- let newt, _, subst, metasenv, ugraph =
- avoid_double_coercion
- subst metasenv ugraph
- (Cic.Appl[c;hete]) tgt_carr in
- try
- let newty,newhety,subst,metasenv,ugraph =
- type_of_aux subst metasenv context newt ugraph in
- let subst,metasenv,ugraph1 =
- fo_unif_subst subst context metasenv
- newhety s ugraph
- in
- newt, subst, metasenv, ugraph
- with exn ->
- enrich localization_tbl hete
- ~f:(fun _ ->
- (lazy ("The term " ^
- CicMetaSubst.ppterm_in_context subst hete
- context ^ " has type " ^
- CicMetaSubst.ppterm_in_context subst hety
- context ^ " but is here used with type " ^
- CicMetaSubst.ppterm_in_context subst s context
- (* "\nReason: " ^ Lazy.force e*)))) exn)
- | exn ->
- enrich localization_tbl hete
- ~f:(fun _ ->
- (lazy ("The term " ^
- CicMetaSubst.ppterm_in_context subst hete
- context ^ " has type " ^
- CicMetaSubst.ppterm_in_context subst hety
- context ^ " but is here used with type " ^
- CicMetaSubst.ppterm_in_context subst s context
- (* "\nReason: " ^ Lazy.force e*)))) exn
- in
- let coerced_args,metasenv',subst',t',ugraph2 =
- eat_prods metasenv subst context
- (CicSubstitution.subst arg t) ugraph1 tl
- in
- arg::coerced_args,metasenv',subst',t',ugraph2
- | _ -> assert false
- )
- in
- let coerced_args,metasenv,subst,t,ugraph2 =
- eat_prods metasenv subst context hetype' ugraph1 tlbody_and_type
- in
- coerced_args,t,subst,metasenv,ugraph2
- in
-
- (* eat prods ends here! *)
-
- let t',ty,subst',metasenv',ugraph1 =
- type_of_aux [] metasenv context t ugraph
- in
- let substituted_t = CicMetaSubst.apply_subst subst' t' in
- let substituted_ty = CicMetaSubst.apply_subst subst' ty in
- (* Andrea: ho rimesso qui l'applicazione della subst al
- metasenv dopo che ho droppato l'invariante che il metsaenv
- e' sempre istanziato *)
- let substituted_metasenv =
- CicMetaSubst.apply_subst_metasenv subst' metasenv' in
- (* metasenv' *)
- (* substituted_t,substituted_ty,substituted_metasenv *)
- (* ANDREA: spostare tutta questa robaccia da un altra parte *)
- let cleaned_t =
- FreshNamesGenerator.clean_dummy_dependent_types substituted_t in
- let cleaned_ty =
- FreshNamesGenerator.clean_dummy_dependent_types substituted_ty in
- let cleaned_metasenv =
- List.map
- (function (n,context,ty) ->
- let ty' = FreshNamesGenerator.clean_dummy_dependent_types ty in
- let context' =
- List.map
- (function
- None -> None
- | Some (n, Cic.Decl t) ->
- Some (n,
- Cic.Decl (FreshNamesGenerator.clean_dummy_dependent_types t))
- | Some (n, Cic.Def (bo,ty)) ->
- let bo' = FreshNamesGenerator.clean_dummy_dependent_types bo in
- let ty' =
- match ty with
- None -> None
- | Some ty ->
- Some (FreshNamesGenerator.clean_dummy_dependent_types ty)
- in
- Some (n, Cic.Def (bo',ty'))
- ) context
- in
- (n,context',ty')
- ) substituted_metasenv
- in
- (cleaned_t,cleaned_ty,cleaned_metasenv,ugraph1)
-;;
-
-let type_of_aux' ?localization_tbl metasenv context term ugraph =
- try
- type_of_aux' ?localization_tbl metasenv context term ugraph
- with
- CicUniv.UniverseInconsistency msg -> raise (RefineFailure (lazy msg))
-
-let undebrujin uri typesno tys t =
- snd
- (List.fold_right
- (fun (name,_,_,_) (i,t) ->
- (* here the explicit_named_substituion is assumed to be *)
- (* of length 0 *)
- let t' = Cic.MutInd (uri,i,[]) in
- let t = CicSubstitution.subst t' t in
- i - 1,t
- ) tys (typesno - 1,t))
-
-let map_first_n n start f g l =
- let rec aux acc k l =
- if k < n then
- match l with
- | [] -> raise (Invalid_argument "map_first_n")
- | hd :: tl -> f hd k (aux acc (k+1) tl)
- else
- g acc l
- in
- aux start 0 l
-
-(*CSC: this is a very rough approximation; to be finished *)
-let are_all_occurrences_positive metasenv ugraph uri tys leftno =
- let subst,metasenv,ugraph,tys =
- List.fold_right
- (fun (name,ind,arity,cl) (subst,metasenv,ugraph,acc) ->
- let subst,metasenv,ugraph,cl =
- List.fold_right
- (fun (name,ty) (subst,metasenv,ugraph,acc) ->
- let rec aux ctx k subst = function
- | Cic.Appl((Cic.MutInd (uri',_,_)as hd)::tl) when uri = uri'->
- let subst,metasenv,ugraph,tl =
- map_first_n leftno
- (subst,metasenv,ugraph,[])
- (fun t n (subst,metasenv,ugraph,acc) ->
- let subst,metasenv,ugraph =
- fo_unif_subst
- subst ctx metasenv t (Cic.Rel (k-n)) ugraph
- in
- subst,metasenv,ugraph,(t::acc))
- (fun (s,m,g,acc) tl -> assert(acc=[]);(s,m,g,tl))
- tl
- in
- subst,metasenv,ugraph,(Cic.Appl (hd::tl))
- | Cic.MutInd(uri',_,_) as t when uri = uri'->
- subst,metasenv,ugraph,t
- | Cic.Prod (name,s,t) ->
- let ctx = (Some (name,Cic.Decl s))::ctx in
- let subst,metasenv,ugraph,t = aux ctx (k+1) subst t in
- subst,metasenv,ugraph,Cic.Prod (name,s,t)
- | _ ->
- raise
- (RefineFailure
- (lazy "not well formed constructor type"))
- in
- let subst,metasenv,ugraph,ty = aux [] 0 subst ty in
- subst,metasenv,ugraph,(name,ty) :: acc)
- cl (subst,metasenv,ugraph,[])
- in
- subst,metasenv,ugraph,(name,ind,arity,cl)::acc)
- tys ([],metasenv,ugraph,[])
- in
- let substituted_tys =
- List.map
- (fun (name,ind,arity,cl) ->
- let cl =
- List.map (fun (name, ty) -> name,CicMetaSubst.apply_subst subst ty) cl
- in
- name,ind,CicMetaSubst.apply_subst subst arity,cl)
- tys
- in
- metasenv,ugraph,substituted_tys
-
-let typecheck metasenv uri obj ~localization_tbl =
- let ugraph = CicUniv.empty_ugraph in
- match obj with
- Cic.Constant (name,Some bo,ty,args,attrs) ->
- let bo',boty,metasenv,ugraph =
- type_of_aux' ~localization_tbl metasenv [] bo ugraph in
- let ty',_,metasenv,ugraph =
- type_of_aux' ~localization_tbl metasenv [] ty ugraph in
- let subst,metasenv,ugraph = fo_unif_subst [] [] metasenv boty ty' ugraph in
- let bo' = CicMetaSubst.apply_subst subst bo' in
- let ty' = CicMetaSubst.apply_subst subst ty' in
- let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
- Cic.Constant (name,Some bo',ty',args,attrs),metasenv,ugraph
- | Cic.Constant (name,None,ty,args,attrs) ->
- let ty',_,metasenv,ugraph =
- type_of_aux' ~localization_tbl metasenv [] ty ugraph
- in
- Cic.Constant (name,None,ty',args,attrs),metasenv,ugraph
- | Cic.CurrentProof (name,metasenv',bo,ty,args,attrs) ->
- assert (metasenv' = metasenv);
- (* Here we do not check the metasenv for correctness *)
- let bo',boty,metasenv,ugraph =
- type_of_aux' ~localization_tbl metasenv [] bo ugraph in
- let ty',sort,metasenv,ugraph =
- type_of_aux' ~localization_tbl metasenv [] ty ugraph in
- begin
- match sort with
- Cic.Sort _
- (* instead of raising Uncertain, let's hope that the meta will become
- a sort *)
- | Cic.Meta _ -> ()
- | _ -> raise (RefineFailure (lazy "The term provided is not a type"))
- end;
- let subst,metasenv,ugraph = fo_unif_subst [] [] metasenv boty ty' ugraph in
- let bo' = CicMetaSubst.apply_subst subst bo' in
- let ty' = CicMetaSubst.apply_subst subst ty' in
- let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
- Cic.CurrentProof (name,metasenv,bo',ty',args,attrs),metasenv,ugraph
- | Cic.Variable _ -> assert false (* not implemented *)
- | Cic.InductiveDefinition (tys,args,paramsno,attrs) ->
- (*CSC: this code is greately simplified and many many checks are missing *)
- (*CSC: e.g. the constructors are not required to build their own types, *)
- (*CSC: the arities are not required to have as type a sort, etc. *)
- let uri = match uri with Some uri -> uri | None -> assert false in
- let typesno = List.length tys in
- (* first phase: we fix only the types *)
- let metasenv,ugraph,tys =
- List.fold_right
- (fun (name,b,ty,cl) (metasenv,ugraph,res) ->
- let ty',_,metasenv,ugraph =
- type_of_aux' ~localization_tbl metasenv [] ty ugraph
- in
- metasenv,ugraph,(name,b,ty',cl)::res
- ) tys (metasenv,ugraph,[]) in
- let con_context =
- List.rev_map (fun (name,_,ty,_)-> Some (Cic.Name name,Cic.Decl ty)) tys in
- (* second phase: we fix only the constructors *)
- let metasenv,ugraph,tys =
- List.fold_right
- (fun (name,b,ty,cl) (metasenv,ugraph,res) ->
- let metasenv,ugraph,cl' =
- List.fold_right
- (fun (name,ty) (metasenv,ugraph,res) ->
- let ty =
- CicTypeChecker.debrujin_constructor
- ~cb:(relocalize localization_tbl) uri typesno ty in
- let ty',_,metasenv,ugraph =
- type_of_aux' ~localization_tbl metasenv con_context ty ugraph in
- let ty' = undebrujin uri typesno tys ty' in
- metasenv,ugraph,(name,ty')::res
- ) cl (metasenv,ugraph,[])
- in
- metasenv,ugraph,(name,b,ty,cl')::res
- ) tys (metasenv,ugraph,[]) in
- (* third phase: we check the positivity condition *)
- let metasenv,ugraph,tys =
- are_all_occurrences_positive metasenv ugraph uri tys paramsno
- in
- Cic.InductiveDefinition (tys,args,paramsno,attrs),metasenv,ugraph
-
-(* DEBUGGING ONLY
-let type_of_aux' metasenv context term =
- try
- let (t,ty,m) =
- type_of_aux' metasenv context term in
- debug_print (lazy
- ("@@@ REFINE SUCCESSFUL: " ^ CicPp.ppterm t ^ " : " ^ CicPp.ppterm ty));
- debug_print (lazy
- ("@@@ REFINE SUCCESSFUL (metasenv):\n" ^ CicMetaSubst.ppmetasenv ~sep:";" m []));
- (t,ty,m)
- with
- | RefineFailure msg as e ->
- debug_print (lazy ("@@@ REFINE FAILED: " ^ msg));
- raise e
- | Uncertain msg as e ->
- debug_print (lazy ("@@@ REFINE UNCERTAIN: " ^ msg));
- raise e
-;; *)
-
-let profiler2 = HExtlib.profile "CicRefine"
-
-let type_of_aux' ?localization_tbl metasenv context term ugraph =
- profiler2.HExtlib.profile
- (type_of_aux' ?localization_tbl metasenv context term) ugraph
-
-let typecheck ~localization_tbl metasenv uri obj =
- profiler2.HExtlib.profile (typecheck ~localization_tbl metasenv uri) obj
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception 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 *)
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-open Printf
-
-exception UnificationFailure of string Lazy.t;;
-exception Uncertain of string Lazy.t;;
-exception AssertFailure of string Lazy.t;;
-
-let verbose = false;;
-let debug_print = fun _ -> ()
-
-let profiler_toa = HExtlib.profile "fo_unif_subst.type_of_aux'"
-let profiler_beta_expand = HExtlib.profile "fo_unif_subst.beta_expand"
-let profiler_deref = HExtlib.profile "fo_unif_subst.deref'"
-let profiler_are_convertible = HExtlib.profile "fo_unif_subst.are_convertible"
-
-let type_of_aux' metasenv subst context term ugraph =
-let foo () =
- try
- CicTypeChecker.type_of_aux' ~subst metasenv context term ugraph
- with
- CicTypeChecker.TypeCheckerFailure msg ->
- let msg =
- lazy
- (sprintf
- "Kernel Type checking error:
-%s\n%s\ncontext=\n%s\nmetasenv=\n%s\nsubstitution=\n%s\nException:\n%s.\nToo bad."
- (CicMetaSubst.ppterm subst term)
- (CicMetaSubst.ppterm [] term)
- (CicMetaSubst.ppcontext subst context)
- (CicMetaSubst.ppmetasenv subst metasenv)
- (CicMetaSubst.ppsubst subst) (Lazy.force msg)) in
- raise (AssertFailure msg)
- | CicTypeChecker.AssertFailure msg ->
- let msg = lazy
- (sprintf
- "Kernel Type checking assertion failure:
-%s\n%s\ncontext=\n%s\nmetasenv=\n%s\nsubstitution=\n%s\nException:\n%s.\nToo bad."
- (CicMetaSubst.ppterm subst term)
- (CicMetaSubst.ppterm [] term)
- (CicMetaSubst.ppcontext subst context)
- (CicMetaSubst.ppmetasenv subst metasenv)
- (CicMetaSubst.ppsubst subst) (Lazy.force msg)) in
- raise (AssertFailure msg)
-in profiler_toa.HExtlib.profile foo ()
-;;
-
-let exists_a_meta l =
- List.exists (function Cic.Meta _ -> true | _ -> false) l
-
-let rec deref subst t =
- let snd (_,a,_) = a in
- match t with
- Cic.Meta(n,l) ->
- (try
- deref subst
- (CicSubstitution.subst_meta
- l (snd (CicUtil.lookup_subst n subst)))
- with
- CicUtil.Subst_not_found _ -> t)
- | Cic.Appl(Cic.Meta(n,l)::args) ->
- (match deref subst (Cic.Meta(n,l)) with
- | Cic.Lambda _ as t ->
- deref subst (CicReduction.head_beta_reduce (Cic.Appl(t::args)))
- | r -> Cic.Appl(r::args))
- | Cic.Appl(((Cic.Lambda _) as t)::args) ->
- deref subst (CicReduction.head_beta_reduce (Cic.Appl(t::args)))
- | t -> t
-;;
-
-let deref subst t =
- let foo () = deref subst t
- in profiler_deref.HExtlib.profile foo ()
-
-exception WrongShape;;
-let eta_reduce after_beta_expansion after_beta_expansion_body
- before_beta_expansion
- =
- try
- match before_beta_expansion,after_beta_expansion_body with
- Cic.Appl l, Cic.Appl l' ->
- let rec all_but_last check_last =
- function
- [] -> assert false
- | [Cic.Rel 1] -> []
- | [_] -> if check_last then raise WrongShape else []
- | he::tl -> he::(all_but_last check_last tl)
- in
- let all_but_last check_last l =
- match all_but_last check_last l with
- [] -> assert false
- | [he] -> he
- | l -> Cic.Appl l
- in
- let t = CicSubstitution.subst (Cic.Rel (-1)) (all_but_last true l') in
- let all_but_last = all_but_last false l in
- (* here we should test alpha-equivalence; however we know by
- construction that here alpha_equivalence is equivalent to = *)
- if t = all_but_last then
- all_but_last
- else
- after_beta_expansion
- | _,_ -> after_beta_expansion
- with
- WrongShape -> after_beta_expansion
-
-let rec beta_expand test_equality_only metasenv subst context t arg ugraph =
- let module S = CicSubstitution in
- let module C = Cic in
-let foo () =
- let rec aux metasenv subst n context t' ugraph =
- try
-
- let subst,metasenv,ugraph1 =
- fo_unif_subst test_equality_only subst context metasenv
- (CicSubstitution.lift n arg) t' ugraph
-
- in
- subst,metasenv,C.Rel (1 + n),ugraph1
- with
- Uncertain _
- | UnificationFailure _ ->
- match t' with
- | C.Rel m -> subst,metasenv,
- (if m <= n then C.Rel m else C.Rel (m+1)),ugraph
- | C.Var (uri,exp_named_subst) ->
- let subst,metasenv,exp_named_subst',ugraph1 =
- aux_exp_named_subst metasenv subst n context exp_named_subst ugraph
- in
- subst,metasenv,C.Var (uri,exp_named_subst'),ugraph1
- | C.Meta (i,l) ->
- (* andrea: in general, beta_expand can create badly typed
- terms. This happens quite seldom in practice, UNLESS we
- iterate on the local context. For this reason, we renounce
- to iterate and just lift *)
- let l =
- List.map
- (function
- Some t -> Some (CicSubstitution.lift 1 t)
- | None -> None) l in
- subst, metasenv, C.Meta (i,l), ugraph
- | C.Sort _
- | C.Implicit _ as t -> subst,metasenv,t,ugraph
- | C.Cast (te,ty) ->
- let subst,metasenv,te',ugraph1 =
- aux metasenv subst n context te ugraph in
- let subst,metasenv,ty',ugraph2 =
- aux metasenv subst n context ty ugraph1 in
- (* TASSI: sure this is in serial? *)
- subst,metasenv,(C.Cast (te', ty')),ugraph2
- | C.Prod (nn,s,t) ->
- let subst,metasenv,s',ugraph1 =
- aux metasenv subst n context s ugraph in
- let subst,metasenv,t',ugraph2 =
- aux metasenv subst (n+1) ((Some (nn, C.Decl s))::context) t
- ugraph1
- in
- (* TASSI: sure this is in serial? *)
- subst,metasenv,(C.Prod (nn, s', t')),ugraph2
- | C.Lambda (nn,s,t) ->
- let subst,metasenv,s',ugraph1 =
- aux metasenv subst n context s ugraph in
- let subst,metasenv,t',ugraph2 =
- aux metasenv subst (n+1) ((Some (nn, C.Decl s))::context) t ugraph1
- in
- (* TASSI: sure this is in serial? *)
- subst,metasenv,(C.Lambda (nn, s', t')),ugraph2
- | C.LetIn (nn,s,t) ->
- let subst,metasenv,s',ugraph1 =
- aux metasenv subst n context s ugraph in
- let subst,metasenv,t',ugraph2 =
- aux metasenv subst (n+1) ((Some (nn, C.Def (s,None)))::context) t
- ugraph1
- in
- (* TASSI: sure this is in serial? *)
- subst,metasenv,(C.LetIn (nn, s', t')),ugraph2
- | C.Appl l ->
- let subst,metasenv,revl',ugraph1 =
- List.fold_left
- (fun (subst,metasenv,appl,ugraph) t ->
- let subst,metasenv,t',ugraph1 =
- aux metasenv subst n context t ugraph in
- subst,metasenv,(t'::appl),ugraph1
- ) (subst,metasenv,[],ugraph) l
- in
- subst,metasenv,(C.Appl (List.rev revl')),ugraph1
- | C.Const (uri,exp_named_subst) ->
- let subst,metasenv,exp_named_subst',ugraph1 =
- aux_exp_named_subst metasenv subst n context exp_named_subst ugraph
- in
- subst,metasenv,(C.Const (uri,exp_named_subst')),ugraph1
- | C.MutInd (uri,i,exp_named_subst) ->
- let subst,metasenv,exp_named_subst',ugraph1 =
- aux_exp_named_subst metasenv subst n context exp_named_subst ugraph
- in
- subst,metasenv,(C.MutInd (uri,i,exp_named_subst')),ugraph1
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let subst,metasenv,exp_named_subst',ugraph1 =
- aux_exp_named_subst metasenv subst n context exp_named_subst ugraph
- in
- subst,metasenv,(C.MutConstruct (uri,i,j,exp_named_subst')),ugraph1
- | C.MutCase (sp,i,outt,t,pl) ->
- let subst,metasenv,outt',ugraph1 =
- aux metasenv subst n context outt ugraph in
- let subst,metasenv,t',ugraph2 =
- aux metasenv subst n context t ugraph1 in
- let subst,metasenv,revpl',ugraph3 =
- List.fold_left
- (fun (subst,metasenv,pl,ugraph) t ->
- let subst,metasenv,t',ugraph1 =
- aux metasenv subst n context t ugraph in
- subst,metasenv,(t'::pl),ugraph1
- ) (subst,metasenv,[],ugraph2) pl
- in
- subst,metasenv,(C.MutCase (sp,i,outt', t', List.rev revpl')),ugraph3
- (* TASSI: not sure this is serial *)
- | C.Fix (i,fl) ->
-(*CSC: not implemented
- let tylen = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) -> (name, i, aux n ty, aux (n+tylen) bo))
- fl
- in
- C.Fix (i, substitutedfl)
-*)
- subst,metasenv,(CicSubstitution.lift 1 t' ),ugraph
- | C.CoFix (i,fl) ->
-(*CSC: not implemented
- let tylen = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (name, aux n ty, aux (n+tylen) bo))
- fl
- in
- C.CoFix (i, substitutedfl)
-
-*)
- subst,metasenv,(CicSubstitution.lift 1 t'), ugraph
-
- and aux_exp_named_subst metasenv subst n context ens ugraph =
- List.fold_right
- (fun (uri,t) (subst,metasenv,l,ugraph) ->
- let subst,metasenv,t',ugraph1 = aux metasenv subst n context t ugraph in
- subst,metasenv,((uri,t')::l),ugraph1) ens (subst,metasenv,[],ugraph)
- in
- let argty,ugraph1 = type_of_aux' metasenv subst context arg ugraph in
- let fresh_name =
- FreshNamesGenerator.mk_fresh_name ~subst
- metasenv context (Cic.Name "Hbeta") ~typ:argty
- in
- let subst,metasenv,t',ugraph2 = aux metasenv subst 0 context t ugraph1 in
- let t'' = eta_reduce (C.Lambda (fresh_name,argty,t')) t' t in
- subst, metasenv, t'', ugraph2
-in profiler_beta_expand.HExtlib.profile foo ()
-
-
-and beta_expand_many test_equality_only metasenv subst context t args ugraph =
- let subst,metasenv,hd,ugraph =
- List.fold_right
- (fun arg (subst,metasenv,t,ugraph) ->
- let subst,metasenv,t,ugraph1 =
- beta_expand test_equality_only
- metasenv subst context t arg ugraph
- in
- subst,metasenv,t,ugraph1
- ) args (subst,metasenv,t,ugraph)
- in
- subst,metasenv,hd,ugraph
-
-
-(* NUOVA UNIFICAZIONE *)
-(* A substitution is a (int * Cic.term) list that associates a
- metavariable i with its body.
- A metaenv is a (int * Cic.term) list that associate a metavariable
- i with is type.
- fo_unif_new takes a metasenv, a context, two terms t1 and t2 and gives back
- a new substitution which is _NOT_ unwinded. It must be unwinded before
- applying it. *)
-
-and fo_unif_subst test_equality_only subst context metasenv t1 t2 ugraph =
- let module C = Cic in
- let module R = CicReduction in
- let module S = CicSubstitution in
- let t1 = deref subst t1 in
- let t2 = deref subst t2 in
- let b,ugraph =
-let foo () =
- R.are_convertible ~subst ~metasenv context t1 t2 ugraph
-in profiler_are_convertible.HExtlib.profile foo ()
- in
- if b then
- subst, metasenv, ugraph
- else
- match (t1, t2) with
- | (C.Meta (n,ln), C.Meta (m,lm)) when n=m ->
- let _,subst,metasenv,ugraph1 =
- (try
- List.fold_left2
- (fun (j,subst,metasenv,ugraph) t1 t2 ->
- match t1,t2 with
- None,_
- | _,None -> j+1,subst,metasenv,ugraph
- | Some t1', Some t2' ->
- (* First possibility: restriction *)
- (* Second possibility: unification *)
- (* Third possibility: convertibility *)
- let b, ugraph1 =
- R.are_convertible
- ~subst ~metasenv context t1' t2' ugraph
- in
- if b then
- j+1,subst,metasenv, ugraph1
- else
- (try
- let subst,metasenv,ugraph2 =
- fo_unif_subst
- test_equality_only
- subst context metasenv t1' t2' ugraph
- in
- j+1,subst,metasenv,ugraph2
- with
- Uncertain _
- | UnificationFailure _ ->
-debug_print (lazy ("restringo Meta n." ^ (string_of_int n) ^ "on variable n." ^ (string_of_int j)));
- let metasenv, subst =
- CicMetaSubst.restrict
- subst [(n,j)] metasenv in
- j+1,subst,metasenv,ugraph1)
- ) (1,subst,metasenv,ugraph) ln lm
- with
- Exit ->
- raise
- (UnificationFailure (lazy "1"))
- (*
- (sprintf
- "Error trying to unify %s with %s: the algorithm tried to check whether the two substitutions are convertible; if they are not, it tried to unify the two substitutions. No restriction was attempted."
- (CicMetaSubst.ppterm subst t1)
- (CicMetaSubst.ppterm subst t2))) *)
- | Invalid_argument _ ->
- raise
- (UnificationFailure (lazy "2")))
- (*
- (sprintf
- "Error trying to unify %s with %s: the lengths of the two local contexts do not match."
- (CicMetaSubst.ppterm subst t1)
- (CicMetaSubst.ppterm subst t2)))) *)
- in subst,metasenv,ugraph1
- | (C.Meta (n,_), C.Meta (m,_)) when n>m ->
- fo_unif_subst test_equality_only subst context metasenv t2 t1 ugraph
- | (C.Meta (n,l), t)
- | (t, C.Meta (n,l)) ->
- let swap =
- match t1,t2 with
- C.Meta (n,_), C.Meta (m,_) when n < m -> false
- | _, C.Meta _ -> false
- | _,_ -> true
- in
- let lower = fun x y -> if swap then y else x in
- let upper = fun x y -> if swap then x else y in
- let fo_unif_subst_ordered
- test_equality_only subst context metasenv m1 m2 ugraph =
- fo_unif_subst test_equality_only subst context metasenv
- (lower m1 m2) (upper m1 m2) ugraph
- in
- begin
- let subst,metasenv,ugraph1 =
- let (_,_,meta_type) = CicUtil.lookup_meta n metasenv in
- (try
- let tyt,ugraph1 =
- type_of_aux' metasenv subst context t ugraph
- in
- fo_unif_subst
- test_equality_only
- subst context metasenv tyt (S.subst_meta l meta_type) ugraph1
- with
- UnificationFailure _ as e -> raise e
- | Uncertain msg -> raise (UnificationFailure msg)
- | AssertFailure _ ->
- debug_print (lazy "siamo allo huge hack");
- (* TODO huge hack!!!!
- * we keep on unifying/refining in the hope that
- * the problem will be eventually solved.
- * In the meantime we're breaking a big invariant:
- * the terms that we are unifying are no longer well
- * typed in the current context (in the worst case
- * we could even diverge) *)
- (subst, metasenv,ugraph)) in
- let t',metasenv,subst =
- try
- CicMetaSubst.delift n subst context metasenv l t
- with
- (CicMetaSubst.MetaSubstFailure msg)->
- raise (UnificationFailure msg)
- | (CicMetaSubst.Uncertain msg) -> raise (Uncertain msg)
- in
- let t'',ugraph2 =
- match t' with
- C.Sort (C.Type u) when not test_equality_only ->
- let u' = CicUniv.fresh () in
- let s = C.Sort (C.Type u') in
- let ugraph2 =
- CicUniv.add_ge (upper u u') (lower u u') ugraph1
- in
- s,ugraph2
- | _ -> t',ugraph1
- in
- (* Unifying the types may have already instantiated n. Let's check *)
- try
- let (_, oldt,_) = CicUtil.lookup_subst n subst in
- let lifted_oldt = S.subst_meta l oldt in
- fo_unif_subst_ordered
- test_equality_only subst context metasenv t lifted_oldt ugraph2
- with
- CicUtil.Subst_not_found _ ->
- let (_, context, ty) = CicUtil.lookup_meta n metasenv in
- let subst = (n, (context, t'',ty)) :: subst in
- let metasenv =
- List.filter (fun (m,_,_) -> not (n = m)) metasenv in
- subst, metasenv, ugraph2
- end
- | (C.Var (uri1,exp_named_subst1),C.Var (uri2,exp_named_subst2))
- | (C.Const (uri1,exp_named_subst1),C.Const (uri2,exp_named_subst2)) ->
- if UriManager.eq uri1 uri2 then
- fo_unif_subst_exp_named_subst test_equality_only subst context metasenv
- exp_named_subst1 exp_named_subst2 ugraph
- else
- raise (UnificationFailure (lazy
- (sprintf
- "Can't unify %s with %s due to different constants"
- (CicMetaSubst.ppterm subst t1)
- (CicMetaSubst.ppterm subst t2))))
- | C.MutInd (uri1,i1,exp_named_subst1),C.MutInd (uri2,i2,exp_named_subst2) ->
- if UriManager.eq uri1 uri2 && i1 = i2 then
- fo_unif_subst_exp_named_subst
- test_equality_only
- subst context metasenv exp_named_subst1 exp_named_subst2 ugraph
- else
- raise (UnificationFailure (lazy "4"))
- (* (sprintf
- "Can't unify %s with %s due to different inductive principles"
- (CicMetaSubst.ppterm subst t1)
- (CicMetaSubst.ppterm subst t2))) *)
- | C.MutConstruct (uri1,i1,j1,exp_named_subst1),
- C.MutConstruct (uri2,i2,j2,exp_named_subst2) ->
- if UriManager.eq uri1 uri2 && i1 = i2 && j1 = j2 then
- fo_unif_subst_exp_named_subst
- test_equality_only
- subst context metasenv exp_named_subst1 exp_named_subst2 ugraph
- else
- raise (UnificationFailure (lazy "5"))
- (* (sprintf
- "Can't unify %s with %s due to different inductive constructors"
- (CicMetaSubst.ppterm subst t1)
- (CicMetaSubst.ppterm subst t2))) *)
- | (C.Implicit _, _) | (_, C.Implicit _) -> assert false
- | (C.Cast (te,ty), t2) -> fo_unif_subst test_equality_only
- subst context metasenv te t2 ugraph
- | (t1, C.Cast (te,ty)) -> fo_unif_subst test_equality_only
- subst context metasenv t1 te ugraph
- | (C.Prod (n1,s1,t1), C.Prod (_,s2,t2)) ->
- let subst',metasenv',ugraph1 =
- fo_unif_subst true subst context metasenv s1 s2 ugraph
- in
- fo_unif_subst test_equality_only
- subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2 ugraph1
- | (C.Lambda (n1,s1,t1), C.Lambda (_,s2,t2)) ->
- let subst',metasenv',ugraph1 =
- fo_unif_subst test_equality_only subst context metasenv s1 s2 ugraph
- in
- fo_unif_subst test_equality_only
- subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2 ugraph1
- | (C.LetIn (_,s1,t1), t2)
- | (t2, C.LetIn (_,s1,t1)) ->
- fo_unif_subst
- test_equality_only subst context metasenv t2 (S.subst s1 t1) ugraph
- | (C.Appl l1, C.Appl l2) ->
- (* andrea: this case should be probably rewritten in the
- spirit of deref *)
- (match l1,l2 with
- | C.Meta (i,_)::args1, C.Meta (j,_)::args2 when i = j ->
- (try
- List.fold_left2
- (fun (subst,metasenv,ugraph) t1 t2 ->
- fo_unif_subst
- test_equality_only subst context metasenv t1 t2 ugraph)
- (subst,metasenv,ugraph) l1 l2
- with (Invalid_argument msg) ->
- raise (UnificationFailure (lazy msg)))
- | C.Meta (i,l)::args, _ when not(exists_a_meta args) ->
- (* we verify that none of the args is a Meta,
- since beta expanding with respoect to a metavariable
- makes no sense *)
- (*
- (try
- let (_,t,_) = CicUtil.lookup_subst i subst in
- let lifted = S.subst_meta l t in
- let reduced = CicReduction.head_beta_reduce (Cic.Appl (lifted::args)) in
- fo_unif_subst
- test_equality_only
- subst context metasenv reduced t2 ugraph
- with CicUtil.Subst_not_found _ -> *)
- let subst,metasenv,beta_expanded,ugraph1 =
- beta_expand_many
- test_equality_only metasenv subst context t2 args ugraph
- in
- fo_unif_subst test_equality_only subst context metasenv
- (C.Meta (i,l)) beta_expanded ugraph1
- | _, C.Meta (i,l)::args when not(exists_a_meta args) ->
- (* (try
- let (_,t,_) = CicUtil.lookup_subst i subst in
- let lifted = S.subst_meta l t in
- let reduced = CicReduction.head_beta_reduce (Cic.Appl (lifted::args)) in
- fo_unif_subst
- test_equality_only
- subst context metasenv t1 reduced ugraph
- with CicUtil.Subst_not_found _ -> *)
- let subst,metasenv,beta_expanded,ugraph1 =
- beta_expand_many
- test_equality_only
- metasenv subst context t1 args ugraph
- in
- fo_unif_subst test_equality_only subst context metasenv
- (C.Meta (i,l)) beta_expanded ugraph1
- | _,_ ->
- let lr1 = List.rev l1 in
- let lr2 = List.rev l2 in
- let rec
- fo_unif_l test_equality_only subst metasenv (l1,l2) ugraph =
- match (l1,l2) with
- [],_
- | _,[] -> assert false
- | ([h1],[h2]) ->
- fo_unif_subst
- test_equality_only subst context metasenv h1 h2 ugraph
- | ([h],l)
- | (l,[h]) ->
- fo_unif_subst test_equality_only subst context metasenv
- h (C.Appl (List.rev l)) ugraph
- | ((h1::l1),(h2::l2)) ->
- let subst', metasenv',ugraph1 =
- fo_unif_subst
- test_equality_only
- subst context metasenv h1 h2 ugraph
- in
- fo_unif_l
- test_equality_only subst' metasenv' (l1,l2) ugraph1
- in
- (try
- fo_unif_l
- test_equality_only subst metasenv (lr1, lr2) ugraph
- with
- | UnificationFailure _
- | Uncertain _ as exn ->
- (match l1, l2 with
- | (((Cic.Const (uri1, ens1)) as c1) :: tl1),
- (((Cic.Const (uri2, ens2)) as c2) :: tl2) when
- CoercGraph.is_a_coercion c1 &&
- CoercGraph.is_a_coercion c2 ->
- let body1, attrs1, ugraph =
- match CicEnvironment.get_obj ugraph uri1 with
- | Cic.Constant (_,Some bo, _, _, attrs),u -> bo,attrs,u
- | _ -> assert false
- in
- let body2, attrs2, ugraph =
- match CicEnvironment.get_obj ugraph uri2 with
- | Cic.Constant (_,Some bo, _, _, attrs),u -> bo, attrs,u
- | _ -> assert false
- in
- let is_composite1 =
- List.exists ((=) (`Class `Coercion)) attrs1 in
- let is_composite2 =
- List.exists ((=) (`Class `Coercion)) attrs2 in
- (match is_composite1, is_composite2 with
- | false, false -> raise exn
- | true, false ->
- let body1 = CicSubstitution.subst_vars ens1 body1 in
- let appl = Cic.Appl (body1::tl1) in
- let redappl = CicReduction.head_beta_reduce appl in
- fo_unif_subst
- test_equality_only subst context metasenv
- redappl t2 ugraph
- | false, true ->
- let body2 = CicSubstitution.subst_vars ens2 body2 in
- let appl = Cic.Appl (body2::tl2) in
- let redappl = CicReduction.head_beta_reduce appl in
- fo_unif_subst
- test_equality_only subst context metasenv
- t1 redappl ugraph
- | true, true ->
- let body1 = CicSubstitution.subst_vars ens1 body1 in
- let appl1 = Cic.Appl (body1::tl1) in
- let redappl1 = CicReduction.head_beta_reduce appl1 in
- let body2 = CicSubstitution.subst_vars ens2 body2 in
- let appl2 = Cic.Appl (body2::tl2) in
- let redappl2 = CicReduction.head_beta_reduce appl2 in
- fo_unif_subst
- test_equality_only subst context metasenv
- redappl1 redappl2 ugraph)
- | _ -> raise exn)))
- | (C.MutCase (_,_,outt1,t1',pl1), C.MutCase (_,_,outt2,t2',pl2))->
- let subst', metasenv',ugraph1 =
- fo_unif_subst test_equality_only subst context metasenv outt1 outt2
- ugraph in
- let subst'',metasenv'',ugraph2 =
- fo_unif_subst test_equality_only subst' context metasenv' t1' t2'
- ugraph1 in
- (try
- List.fold_left2
- (fun (subst,metasenv,ugraph) t1 t2 ->
- fo_unif_subst
- test_equality_only subst context metasenv t1 t2 ugraph
- ) (subst'',metasenv'',ugraph2) pl1 pl2
- with
- Invalid_argument _ ->
- raise (UnificationFailure (lazy "6.1")))
- (* (sprintf
- "Error trying to unify %s with %s: the number of branches is not the same."
- (CicMetaSubst.ppterm subst t1)
- (CicMetaSubst.ppterm subst t2)))) *)
- | (C.Rel _, _) | (_, C.Rel _) ->
- if t1 = t2 then
- subst, metasenv,ugraph
- else
- raise (UnificationFailure (lazy
- (sprintf
- "Can't unify %s with %s because they are not convertible"
- (CicMetaSubst.ppterm subst t1)
- (CicMetaSubst.ppterm subst t2))))
- | (C.Appl (C.Meta(i,l)::args),t2) when not(exists_a_meta args) ->
- let subst,metasenv,beta_expanded,ugraph1 =
- beta_expand_many
- test_equality_only metasenv subst context t2 args ugraph
- in
- fo_unif_subst test_equality_only subst context metasenv
- (C.Meta (i,l)) beta_expanded ugraph1
- | (t1,C.Appl (C.Meta(i,l)::args)) when not(exists_a_meta args) ->
- let subst,metasenv,beta_expanded,ugraph1 =
- beta_expand_many
- test_equality_only metasenv subst context t1 args ugraph
- in
- fo_unif_subst test_equality_only subst context metasenv
- beta_expanded (C.Meta (i,l)) ugraph1
- | (C.Sort _ ,_) | (_, C.Sort _)
- | (C.Const _, _) | (_, C.Const _)
- | (C.MutInd _, _) | (_, C.MutInd _)
- | (C.MutConstruct _, _) | (_, C.MutConstruct _)
- | (C.Fix _, _) | (_, C.Fix _)
- | (C.CoFix _, _) | (_, C.CoFix _) ->
- if t1 = t2 then
- subst, metasenv, ugraph
- else
- let b,ugraph1 =
- R.are_convertible ~subst ~metasenv context t1 t2 ugraph
- in
- if b then
- subst, metasenv, ugraph1
- else
- raise
- (UnificationFailure (lazy (sprintf
- "Can't unify %s with %s because they are not convertible"
- (CicMetaSubst.ppterm subst t1)
- (CicMetaSubst.ppterm subst t2))))
- | (C.Prod _, t2) ->
- let t2' = R.whd ~subst context t2 in
- (match t2' with
- C.Prod _ ->
- fo_unif_subst test_equality_only
- subst context metasenv t1 t2' ugraph
- | _ -> raise (UnificationFailure (lazy "8")))
- | (t1, C.Prod _) ->
- let t1' = R.whd ~subst context t1 in
- (match t1' with
- C.Prod _ ->
- fo_unif_subst test_equality_only
- subst context metasenv t1' t2 ugraph
- | _ -> (* raise (UnificationFailure "9")) *)
- raise
- (UnificationFailure (lazy (sprintf
- "Can't unify %s with %s because they are not convertible"
- (CicMetaSubst.ppterm subst t1)
- (CicMetaSubst.ppterm subst t2)))))
- | (_,_) ->
- raise (UnificationFailure (lazy "10"))
- (* (sprintf
- "Can't unify %s with %s because they are not convertible"
- (CicMetaSubst.ppterm subst t1)
- (CicMetaSubst.ppterm subst t2))) *)
-
-and fo_unif_subst_exp_named_subst test_equality_only subst context metasenv
- exp_named_subst1 exp_named_subst2 ugraph
-=
- try
- List.fold_left2
- (fun (subst,metasenv,ugraph) (uri1,t1) (uri2,t2) ->
- assert (uri1=uri2) ;
- fo_unif_subst test_equality_only subst context metasenv t1 t2 ugraph
- ) (subst,metasenv,ugraph) exp_named_subst1 exp_named_subst2
- with
- Invalid_argument _ ->
- let print_ens ens =
- String.concat " ; "
- (List.map
- (fun (uri,t) ->
- UriManager.string_of_uri uri ^ " := " ^ (CicMetaSubst.ppterm subst t)
- ) ens)
- in
- raise (UnificationFailure (lazy (sprintf
- "Error trying to unify the two explicit named substitutions (local contexts) %s and %s: their lengths is different." (print_ens exp_named_subst1) (print_ens exp_named_subst2))))
-
-(* A substitution is a (int * Cic.term) list that associates a *)
-(* metavariable i with its body. *)
-(* metasenv is of type Cic.metasenv *)
-(* fo_unif takes a metasenv, a context, two terms t1 and t2 and gives back *)
-(* a new substitution which is already unwinded and ready to be applied and *)
-(* a new metasenv in which some hypothesis in the contexts of the *)
-(* metavariables may have been restricted. *)
-let fo_unif metasenv context t1 t2 ugraph =
- fo_unif_subst false [] context metasenv t1 t2 ugraph ;;
-
-let enrich_msg msg subst context metasenv t1 t2 ugraph =
- lazy (
- if verbose then
- sprintf "[Verbose] Unification error unifying %s of type %s with %s of type %s in context\n%s\nand metasenv\n%s\nand substitution\n%s\nbecause %s"
- (CicMetaSubst.ppterm subst t1)
- (try
- let ty_t1,_ = type_of_aux' metasenv subst context t1 ugraph in
- CicPp.ppterm ty_t1
- with
- | UnificationFailure s
- | Uncertain s
- | AssertFailure s -> sprintf "MALFORMED(t1): \n<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))
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception 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
-
+++ /dev/null
-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
+++ /dev/null
-PACKAGE = content_pres
-PREDICATES =
-
-INTERFACE_FILES = \
- renderingAttrs.mli \
- cicNotationLexer.mli \
- cicNotationParser.mli \
- mpresentation.mli \
- box.mli \
- content2presMatcher.mli \
- termContentPres.mli \
- cicNotationPres.mli \
- boxPp.mli \
- content2pres.mli \
- sequent2pres.mli \
- $(NULL)
-IMPLEMENTATION_FILES = \
- $(INTERFACE_FILES:%.mli=%.ml)
-
-cicNotationPres.cmi: OCAMLOPTIONS += -rectypes
-cicNotationPres.cmo: OCAMLOPTIONS += -rectypes
-cicNotationPres.cmx: OCAMLOPTIONS += -rectypes
-
-all: test_lexer
-clean: clean_tests
-
-LOCAL_LINKOPTS = -package helm-content_pres -linkpkg
-test: test_lexer
-test_lexer: test_lexer.ml $(PACKAGE).cma
- @echo " OCAMLC $<"
- @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
-
-clean_tests:
- rm -f test_lexer{,.opt}
-
-cicNotationLexer.cmo: OCAMLC = $(OCAMLC_P4)
-cicNotationParser.cmo: OCAMLC = $(OCAMLC_P4)
-cicNotationLexer.cmx: OCAMLOPT = $(OCAMLOPT_P4)
-cicNotationParser.cmx: OCAMLOPT = $(OCAMLOPT_P4)
-cicNotationLexer.ml.annot: OCAMLC = $(OCAMLC_P4)
-cicNotationParser.ml.annot: OCAMLC = $(OCAMLC_P4)
-
-include ../../Makefile.defs
-include ../Makefile.common
-
-# <cross> 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>
-
+++ /dev/null
-(* 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 b_toggle items = Action ([ None, "type", "toggle"], items)
-
-let pp_attr attr =
- let pp (ns, n, v) =
- Printf.sprintf "%s%s=%s" (match ns with None -> "" | Some s -> s ^ ":") n v
- in
- String.concat " " (List.map pp attr)
-
-let get_attr = function
- | Text (attr, _)
- | Space attr
- | Ink attr
- | H (attr, _)
- | V (attr, _)
- | HV (attr, _)
- | HOV (attr, _)
- | Object (attr, _)
- | Action (attr, _) ->
- attr
-
-let set_attr attr = function
- | Text (_, x) -> Text (attr, x)
- | Space _ -> Space attr
- | Ink _ -> Ink attr
- | H (_, x) -> H (attr, x)
- | V (_, x) -> V (attr, x)
- | HV (_, x) -> HV (attr, x)
- | HOV (_, x) -> HOV (attr, x)
- | Object (_, x) -> Object (attr, x)
- | Action (_, x) -> Action (attr, x)
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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 b_toggle: 'expr box list -> 'expr box (** action which toggle among items *)
-
-val pp_attr: attr -> string
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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)
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 _ -> []
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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: *)
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-
-module Ast = CicNotationPt
-module Mpres = Mpresentation
-
-type mathml_markup = boxml_markup Mpres.mpres
-and boxml_markup = mathml_markup Box.box
-
-type markup = mathml_markup
-
-let atop_attributes = [None, "linethickness", "0pt"]
-
-let to_unicode = Utf8Macro.unicode_of_tex
-
-let rec make_attributes l1 = function
- | [] -> []
- | hd :: tl ->
- (match hd with
- | None -> make_attributes (List.tl l1) tl
- | Some s ->
- let p,n = List.hd l1 in
- (p,n,s) :: make_attributes (List.tl l1) tl)
-
-let box_of_mpres =
- function
- | Mpresentation.Mobject (attrs, box) ->
- assert (attrs = []);
- box
- | mpres -> Box.Object ([], mpres)
-
-let mpres_of_box =
- function
- | Box.Object (attrs, mpres) ->
- assert (attrs = []);
- mpres
- | box -> Mpresentation.Mobject ([], box)
-
-let rec genuine_math =
- function
- | Mpresentation.Mobject ([], obj) -> not (genuine_box obj)
- | _ -> true
-and genuine_box =
- function
- | Box.Object ([], mpres) -> not (genuine_math mpres)
- | _ -> true
-
-let rec eligible_math =
- function
- | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> eligible_math mpres
- | Mpresentation.Mobject ([], _) -> false
- | _ -> true
-
-let rec promote_to_math =
- function
- | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> promote_to_math mpres
- | math -> math
-
-let small_skip =
- Mpresentation.Mspace (RenderingAttrs.small_skip_attributes `MathML)
-
-let rec add_mpres_attributes new_attr = function
- | Mpresentation.Mobject (attr, box) ->
- Mpresentation.Mobject (attr, add_box_attributes new_attr box)
- | mpres ->
- Mpresentation.set_attr (new_attr @ Mpresentation.get_attr mpres) mpres
-and add_box_attributes new_attr = function
- | Box.Object (attr, mpres) ->
- Box.Object (attr, add_mpres_attributes new_attr mpres)
- | box -> Box.set_attr (new_attr @ Box.get_attr box) box
-
-let box_of mathonly spec attrs children =
- match children with
- | [t] -> add_mpres_attributes attrs t
- | _ ->
- let kind, spacing, indent = spec in
- let dress children =
- if spacing then
- CicNotationUtil.dress small_skip children
- else
- children
- in
- if mathonly then Mpresentation.Mrow (attrs, dress children)
- else
- let attrs' =
- (if spacing then RenderingAttrs.spacing_attributes `BoxML else [])
- @ (if indent then RenderingAttrs.indent_attributes `BoxML else [])
- @ attrs
- in
- match kind with
- | Ast.H ->
- if List.for_all eligible_math children then
- Mpresentation.Mrow (attrs',
- dress (List.map promote_to_math children))
- else
- mpres_of_box (Box.H (attrs',
- List.map box_of_mpres children))
-(* | Ast.H when List.for_all genuine_math children ->
- Mpresentation.Mrow (attrs', dress children) *)
- | Ast.V ->
- mpres_of_box (Box.V (attrs',
- List.map box_of_mpres children))
- | Ast.HV ->
- mpres_of_box (Box.HV (attrs',
- List.map box_of_mpres children))
- | Ast.HOV ->
- mpres_of_box (Box.HOV (attrs',
- List.map box_of_mpres children))
-
-let open_paren = Mpresentation.Mo ([], "(")
-let closed_paren = Mpresentation.Mo ([], ")")
-let open_brace = Mpresentation.Mo ([], "{")
-let closed_brace = Mpresentation.Mo ([], "}")
-let hidden_substs = Mpresentation.Mtext ([], "{...}")
-let open_box_paren = Box.Text ([], "(")
-let closed_box_paren = Box.Text ([], ")")
-let semicolon = Mpresentation.Mo ([], ";")
-let toggle_action children =
- Mpresentation.Maction ([None, "actiontype", "toggle"], children)
-
-type child_pos = [ `Left | `Right | `Inner ]
-
-let pp_assoc =
- function
- | Gramext.LeftA -> "LeftA"
- | Gramext.RightA -> "RightA"
- | Gramext.NonA -> "NonA"
-
-let is_atomic t =
- let rec aux_mpres = function
- | Mpres.Mi _
- | Mpres.Mo _
- | Mpres.Mn _
- | Mpres.Ms _
- | Mpres.Mtext _
- | Mpres.Mspace _ -> true
- | Mpres.Mobject (_, box) -> aux_box box
- | Mpres.Maction (_, [mpres])
- | Mpres.Mrow (_, [mpres]) -> aux_mpres mpres
- | _ -> false
- and aux_box = function
- | Box.Space _
- | Box.Ink _
- | Box.Text _ -> true
- | Box.Object (_, mpres) -> aux_mpres mpres
- | Box.H (_, [box])
- | Box.V (_, [box])
- | Box.HV (_, [box])
- | Box.HOV (_, [box])
- | Box.Action (_, [box]) -> aux_box box
- | _ -> false
- in
- aux_mpres t
-
-let add_parens child_prec child_assoc child_pos curr_prec t =
-(* eprintf
- ("add_parens: " ^^
- "child_prec = %d\nchild_assoc = %s\nchild_pos = %s\ncurr_prec= %d\n\n%!")
- child_prec (pp_assoc child_assoc) (CicNotationPp.pp_pos child_pos)
- curr_prec; *)
- if is_atomic t then t
- else if child_prec >= 0
- && (child_prec < curr_prec
- || (child_prec = curr_prec &&
- child_assoc = Gramext.LeftA &&
- child_pos <> `Left)
- || (child_prec = curr_prec &&
- child_assoc = Gramext.RightA &&
- child_pos <> `Right))
- then begin (* parens should be added *)
-(* prerr_endline "adding parens!"; *)
- match t with
- | Mpresentation.Mobject (_, box) ->
- mpres_of_box (Box.H ([], [ open_box_paren; box; closed_box_paren ]))
- | mpres -> Mpresentation.Mrow ([], [open_paren; t; closed_paren])
- end else
- t
-
-let render ids_to_uris =
- let module A = Ast in
- let module P = Mpresentation in
-(* let use_unicode = true in *)
- let lookup_uri id =
- (try
- let uri = Hashtbl.find ids_to_uris id in
- Some (UriManager.string_of_uri uri)
- with Not_found -> None)
- in
- let make_href xmlattrs xref =
- let xref_uris =
- List.fold_right
- (fun xref uris ->
- match lookup_uri xref with
- | None -> uris
- | Some uri -> uri :: uris)
- !xref []
- in
- let xmlattrs_uris, xmlattrs =
- let xref_attrs, other_attrs =
- List.partition
- (function Some "xlink", "href", _ -> true | _ -> false)
- xmlattrs
- in
- List.map (fun (_, _, uri) -> uri) xref_attrs,
- other_attrs
- in
- let uris =
- match xmlattrs_uris @ xref_uris with
- | [] -> None
- | uris ->
- Some (String.concat " "
- (HExtlib.list_uniq (List.sort String.compare uris)))
- in
- let xrefs =
- match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs)
- in
- xref := [];
- xmlattrs
- @ make_attributes [Some "helm", "xref"; Some "xlink", "href"]
- [xrefs; uris]
- in
- let make_xref xref =
- let xrefs =
- match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs)
- in
- xref := [];
- make_attributes [Some "helm","xref"] [xrefs]
- in
- (* when mathonly is true no boxes should be generated, only mrows *)
- (* "xref" is *)
- let rec aux xmlattrs mathonly xref pos prec t =
- match t with
- | A.AttributedTerm _ ->
- aux_attributes xmlattrs mathonly xref pos prec t
- | A.Num (literal, _) ->
- let attrs =
- (RenderingAttrs.number_attributes `MathML)
- @ make_href xmlattrs xref
- in
- Mpres.Mn (attrs, literal)
- | A.Symbol (literal, _) ->
- let attrs =
- (RenderingAttrs.symbol_attributes `MathML)
- @ make_href xmlattrs xref
- in
- Mpres.Mo (attrs, to_unicode literal)
- | A.Ident (literal, subst)
- | A.Uri (literal, subst) ->
- let attrs =
- (RenderingAttrs.ident_attributes `MathML)
- @ make_href xmlattrs xref
- in
- let name = Mpres.Mi (attrs, to_unicode literal) in
- (match subst with
- | Some []
- | None -> name
- | Some substs ->
- let substs' =
- box_of mathonly (A.H, false, false) []
- (open_brace
- :: (CicNotationUtil.dress semicolon
- (List.map
- (fun (name, t) ->
- box_of mathonly (A.H, false, false) [] [
- Mpres.Mi ([], name);
- Mpres.Mo ([], to_unicode "\\def");
- aux [] mathonly xref pos prec t ])
- substs))
- @ [ closed_brace ])
- in
- let substs_maction = toggle_action [ hidden_substs; substs' ] in
- box_of mathonly (A.H, false, false) [] [ name; substs_maction ])
- | A.Literal l -> aux_literal xmlattrs xref prec l
- | A.UserInput -> Mpres.Mtext ([], "%")
- | A.Layout l -> aux_layout mathonly xref pos prec l
- | A.Magic _
- | A.Variable _ -> assert false (* should have been instantiated *)
- | t ->
- prerr_endline ("unexpected ast: " ^ CicNotationPp.pp_term t);
- assert false
- and aux_attributes xmlattrs mathonly xref pos prec t =
- let reset = ref false in
- let new_level = ref None in
- let new_xref = ref [] in
- let new_xmlattrs = ref [] in
- let new_pos = ref pos in
-(* let reinit = ref false in *)
- let rec aux_attribute =
- function
- | A.AttributedTerm (attr, t) ->
- (match attr with
- | `Loc _
- | `Raw _ -> ()
- | `Level (-1, _) -> reset := true
- | `Level (child_prec, child_assoc) ->
- new_level := Some (child_prec, child_assoc)
- | `IdRef xref -> new_xref := xref :: !new_xref
- | `ChildPos pos -> new_pos := pos
- | `XmlAttrs attrs -> new_xmlattrs := attrs @ !new_xmlattrs);
- aux_attribute t
- | t ->
- (match !new_level with
- | None -> aux !new_xmlattrs mathonly new_xref !new_pos prec t
- | Some (child_prec, child_assoc) ->
- let t' =
- aux !new_xmlattrs mathonly new_xref !new_pos child_prec t in
- if !reset
- then t'
- else add_parens child_prec child_assoc !new_pos prec t')
- in
- aux_attribute t
- and aux_literal xmlattrs xref prec l =
- let attrs = make_href xmlattrs xref in
- (match l with
- | `Symbol s -> Mpres.Mo (attrs, to_unicode s)
- | `Keyword s -> Mpres.Mo (attrs, to_unicode s)
- | `Number s -> Mpres.Mn (attrs, to_unicode s))
- and aux_layout mathonly xref pos prec l =
- let attrs = make_xref xref in
- let invoke' t = aux [] true (ref []) pos prec t in
- (* use the one below to reset precedence and associativity *)
- let invoke_reinit t = aux [] mathonly xref `Inner ~-1 t in
- match l with
- | A.Sub (t1, t2) -> Mpres.Msub (attrs, invoke' t1, invoke_reinit t2)
- | A.Sup (t1, t2) -> Mpres.Msup (attrs, invoke' t1, invoke_reinit t2)
- | A.Below (t1, t2) -> Mpres.Munder (attrs, invoke' t1, invoke_reinit t2)
- | A.Above (t1, t2) -> Mpres.Mover (attrs, invoke' t1, invoke_reinit t2)
- | A.Frac (t1, t2)
- | A.Over (t1, t2) ->
- Mpres.Mfrac (attrs, invoke_reinit t1, invoke_reinit t2)
- | A.Atop (t1, t2) ->
- Mpres.Mfrac (atop_attributes @ attrs, invoke_reinit t1,
- invoke_reinit t2)
- | A.Sqrt t -> Mpres.Msqrt (attrs, invoke_reinit t)
- | A.Root (t1, t2) ->
- Mpres.Mroot (attrs, invoke_reinit t1, invoke_reinit t2)
- | A.Box ((_, spacing, _) as kind, terms) ->
- let children =
- aux_children mathonly spacing xref pos prec
- (CicNotationUtil.ungroup terms)
- in
- box_of mathonly kind attrs children
- | A.Group terms ->
- let children =
- aux_children mathonly false xref pos prec
- (CicNotationUtil.ungroup terms)
- in
- box_of mathonly (A.H, false, false) attrs children
- | A.Break -> assert false (* TODO? *)
- and aux_children mathonly spacing xref pos prec terms =
- let find_clusters =
- let rec aux_list first clusters acc =
- function
- [] when acc = [] -> List.rev clusters
- | [] -> aux_list first (List.rev acc :: clusters) [] []
- | (A.Layout A.Break) :: tl when acc = [] ->
- aux_list first clusters [] tl
- | (A.Layout A.Break) :: tl ->
- aux_list first (List.rev acc :: clusters) [] tl
- | [hd] ->
-(* let pos' =
- if first then
- pos
- else
- match pos with
- `None -> `Right
- | `Inner -> `Inner
- | `Right -> `Right
- | `Left -> `Inner
- in *)
- aux_list false clusters
- (aux [] mathonly xref pos prec hd :: acc) []
- | hd :: tl ->
-(* let pos' =
- match pos, first with
- `None, true -> `Left
- | `None, false -> `Inner
- | `Left, true -> `Left
- | `Left, false -> `Inner
- | `Right, _ -> `Inner
- | `Inner, _ -> `Inner
- in *)
- aux_list false clusters
- (aux [] mathonly xref pos prec hd :: acc) tl
- in
- aux_list true [] []
- in
- let boxify_pres =
- function
- [t] -> t
- | tl -> box_of mathonly (A.H, spacing, false) [] tl
- in
- List.map boxify_pres (find_clusters terms)
- in
- aux [] false (ref []) `Inner ~-1
-
-let rec print_box (t: boxml_markup) =
- Box.box2xml print_mpres t
-and print_mpres (t: mathml_markup) =
- Mpresentation.print_mpres print_box t
-
-let print_xml = print_mpres
-
-(* let render_to_boxml id_to_uri t =
- let xml_stream = print_box (box_of_mpres (render id_to_uri t)) in
- Xml.add_xml_declaration xml_stream *)
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* 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 ->
- let concl =
- make_concl ~attrs:[ Some "helm", "xref", p.Con.proof_id ]
- "proof of" ac in
- B.b_toggle [ concl; body ]
- in
- B.V ([],
- [B.Text ([],"(" ^ name ^ ")");
- B.indent action])
-
- and context2pres c continuation =
- (* we generate a subtable for each context element, for selection
- purposes
- The table generated by the head-element does not have an xref;
- the whole context-proof is already selectable *)
- match c with
- [] -> continuation
- | hd::tl ->
- let continuation' =
- List.fold_right
- (fun ce continuation ->
- let xref = get_xref ce in
- B.V([Some "helm", "xref", xref ],
- [B.H([Some "helm", "xref", "ce_"^xref],
- [ce2pres_in_proof_context_element ce]);
- continuation])) tl continuation in
- let hd_xref= get_xref hd in
- B.V([],
- [B.H([Some "helm", "xref", "ce_"^hd_xref],
- [ce2pres_in_proof_context_element hd]);
- continuation'])
-
- and ce2pres_in_joint_context_element = function
- | `Inductive _ -> assert false (* TODO *)
- | (`Declaration _) as x -> ce2pres x
- | (`Hypothesis _) as x -> ce2pres x
- | (`Proof _) as x -> ce2pres x
- | (`Definition _) as x -> ce2pres x
-
- and ce2pres_in_proof_context_element = function
- | `Joint ho ->
- B.H ([],(List.map ce2pres_in_joint_context_element ho.Content.joint_defs))
- | (`Declaration _) as x -> ce2pres x
- | (`Hypothesis _) as x -> ce2pres x
- | (`Proof _) as x -> ce2pres x
- | (`Definition _) as x -> ce2pres x
-
- and ce2pres =
- function
- `Declaration d ->
- (match d.Con.dec_name with
- Some s ->
- let ty = term2pres d.Con.dec_type in
- B.H ([],
- [(B.b_kw "Assume");
- B.b_space;
- B.Object ([], P.Mi([],s));
- B.Text([],":");
- ty])
- | None ->
- prerr_endline "NO NAME!!"; assert false)
- | `Hypothesis h ->
- (match h.Con.dec_name with
- Some s ->
- let ty = term2pres h.Con.dec_type in
- B.H ([],
- [(B.b_kw "Suppose");
- B.b_space;
- B.Text([],"(");
- B.Object ([], P.Mi ([],s));
- B.Text([],")");
- B.b_space;
- ty])
- | None ->
- prerr_endline "NO NAME!!"; assert false)
- | `Proof p ->
- proof2pres p
- | `Definition d ->
- (match d.Con.def_name with
- Some s ->
- let term = term2pres d.Con.def_term in
- B.H ([],
- [ B.b_kw "Let"; B.b_space;
- B.Object ([], P.Mi([],s));
- B.Text([]," = ");
- term])
- | None ->
- prerr_endline "NO NAME!!"; assert false)
-
- and acontext2pres ac continuation indent =
- List.fold_right
- (fun p continuation ->
- let hd =
- if indent then
- B.indent (proof2pres p)
- else
- proof2pres p in
- B.V([Some "helm","xref",p.Con.proof_id],
- [B.H([Some "helm","xref","ace_"^p.Con.proof_id],[hd]);
- continuation])) ac continuation
-
- and conclude2pres conclude indent omit_conclusion =
- let tconclude_body =
- match conclude.Con.conclude_conclusion with
- Some t when
- not omit_conclusion or
- (* CSC: I ignore the omit_conclusion flag in this case. *)
- (* CSC: Is this the correct behaviour? In the stylesheets *)
- (* CSC: we simply generated nothing (i.e. the output type *)
- (* CSC: of the function should become an option. *)
- conclude.Con.conclude_method = "BU_Conversion" ->
- let concl = (term2pres t) in
- if conclude.Con.conclude_method = "BU_Conversion" then
- make_concl "that is equivalent to" concl
- else if conclude.Con.conclude_method = "FalseInd" then
- (* false ind is in charge to add the conclusion *)
- falseind conclude
- else
- let conclude_body = conclude_aux conclude in
- let ann_concl =
- if conclude.Con.conclude_method = "TD_Conversion" then
- make_concl "that is equivalent to" concl
- else make_concl "we conclude" concl in
- B.V ([], [conclude_body; ann_concl])
- | _ -> conclude_aux conclude in
- if indent then
- B.indent (B.H ([Some "helm", "xref", conclude.Con.conclude_id],
- [tconclude_body]))
- else
- B.H ([Some "helm", "xref", conclude.Con.conclude_id],[tconclude_body])
-
- and conclude_aux conclude =
- if conclude.Con.conclude_method = "TD_Conversion" then
- let expected =
- (match conclude.Con.conclude_conclusion with
- None -> B.Text([],"NO EXPECTED!!!")
- | Some c -> term2pres c) in
- let subproof =
- (match conclude.Con.conclude_args with
- [Con.ArgProof p] -> p
- | _ -> assert false) in
- let synth =
- (match subproof.Con.proof_conclude.Con.conclude_conclusion with
- None -> B.Text([],"NO SYNTH!!!")
- | Some c -> (term2pres c)) in
- B.V
- ([],
- [make_concl "we must prove" expected;
- make_concl "or equivalently" synth;
- proof2pres subproof])
- else if conclude.Con.conclude_method = "BU_Conversion" then
- assert false
- else if conclude.Con.conclude_method = "Exact" then
- let arg =
- (match conclude.Con.conclude_args with
- [Con.Term t] -> term2pres t
- | [Con.Premise p] ->
- (match p.Con.premise_binder with
- | None -> assert false; (* unnamed hypothesis ??? *)
- | Some s -> B.Text([],s))
- | err -> assert false) in
- (match conclude.Con.conclude_conclusion with
- None ->
- B.b_h [] [B.b_kw "Consider"; B.b_space; arg]
- | Some c -> let conclusion = term2pres c in
- make_row
- [arg; B.b_space; B.b_kw "proves"]
- conclusion
- )
- else if conclude.Con.conclude_method = "Intros+LetTac" then
- (match conclude.Con.conclude_args with
- [Con.ArgProof p] -> proof2pres p
- | _ -> assert false)
-(* OLD CODE
- let conclusion =
- (match conclude.Con.conclude_conclusion with
- None -> B.Text([],"NO Conclusion!!!")
- | Some c -> term2pres c) in
- (match conclude.Con.conclude_args with
- [Con.ArgProof p] ->
- B.V
- ([None,"align","baseline 1"; None,"equalrows","false";
- None,"columnalign","left"],
- [B.H([],[B.Object([],proof2pres p)]);
- B.H([],[B.Object([],
- (make_concl "we proved 1" conclusion))])]);
- | _ -> assert false)
-*)
- else if (conclude.Con.conclude_method = "Case") then
- case conclude
- else if (conclude.Con.conclude_method = "ByInduction") then
- byinduction conclude
- else if (conclude.Con.conclude_method = "Exists") then
- exists conclude
- else if (conclude.Con.conclude_method = "AndInd") then
- andind conclude
- else if (conclude.Con.conclude_method = "FalseInd") then
- falseind conclude
- else if (conclude.Con.conclude_method = "Rewrite") then
- let justif =
- (match (List.nth conclude.Con.conclude_args 6) with
- Con.ArgProof p -> justification term2pres p
- | _ -> assert false) in
- let term1 =
- (match List.nth conclude.Con.conclude_args 2 with
- Con.Term t -> term2pres t
- | _ -> assert false) in
- let term2 =
- (match List.nth conclude.Con.conclude_args 5 with
- Con.Term t -> term2pres t
- | _ -> assert false) in
- B.V ([],
- [B.H ([],[
- (B.b_kw "rewrite");
- B.b_space; term1;
- B.b_space; (B.b_kw "with");
- B.b_space; term2;
- B.indent justif])])
- else if conclude.Con.conclude_method = "Apply" then
- let pres_args =
- make_args_for_apply term2pres conclude.Con.conclude_args in
- B.H([],
- (B.b_kw "by")::
- B.b_space::
- B.Text([],"(")::pres_args@[B.Text([],")")])
- else
- B.V ([], [
- B.b_kw ("Apply method" ^ conclude.Con.conclude_method ^ " to");
- (B.indent (B.V ([], args2pres conclude.Con.conclude_args)))])
-
- and args2pres l = List.map arg2pres l
-
- and arg2pres =
- function
- Con.Aux n -> B.b_kw ("aux " ^ n)
- | Con.Premise prem -> B.b_kw "premise"
- | Con.Lemma lemma -> B.b_kw "lemma"
- | Con.Term t -> term2pres t
- | Con.ArgProof p -> proof2pres p
- | Con.ArgMethod s -> B.b_kw "method"
-
- and case conclude =
- let proof_conclusion =
- (match conclude.Con.conclude_conclusion with
- None -> B.b_kw "No conclusion???"
- | Some t -> term2pres t) in
- let arg,args_for_cases =
- (match conclude.Con.conclude_args with
- Con.Aux(_)::Con.Aux(_)::Con.Term(_)::arg::tl ->
- arg,tl
- | _ -> assert false) in
- let case_on =
- let case_arg =
- (match arg with
- Con.Aux n -> B.b_kw "an aux???"
- | Con.Premise prem ->
- (match prem.Con.premise_binder with
- None -> B.b_kw "the previous result"
- | Some n -> B.Object ([], P.Mi([],n)))
- | Con.Lemma lemma -> B.Object ([], P.Mi([],lemma.Con.lemma_name))
- | Con.Term t ->
- term2pres t
- | Con.ArgProof p -> B.b_kw "a proof???"
- | Con.ArgMethod s -> B.b_kw "a method???")
- in
- (make_concl "we proceed by cases on" case_arg) in
- let to_prove =
- (make_concl "to prove" proof_conclusion) in
- B.V ([], case_on::to_prove::(make_cases args_for_cases))
-
- and byinduction conclude =
- let proof_conclusion =
- (match conclude.Con.conclude_conclusion with
- None -> B.b_kw "No conclusion???"
- | Some t -> term2pres t) in
- let inductive_arg,args_for_cases =
- (match conclude.Con.conclude_args with
- Con.Aux(n)::_::tl ->
- let l1,l2 = split (int_of_string n) tl in
- let last_pos = (List.length l2)-1 in
- List.nth l2 last_pos,l1
- | _ -> assert false) in
- let induction_on =
- let arg =
- (match inductive_arg with
- Con.Aux n -> B.b_kw "an aux???"
- | Con.Premise prem ->
- (match prem.Con.premise_binder with
- None -> B.b_kw "the previous result"
- | Some n -> B.Object ([], P.Mi([],n)))
- | Con.Lemma lemma -> B.Object ([], P.Mi([],lemma.Con.lemma_name))
- | Con.Term t ->
- term2pres t
- | Con.ArgProof p -> B.b_kw "a proof???"
- | Con.ArgMethod s -> B.b_kw "a method???") in
- (make_concl "we proceed by induction on" arg) in
- let to_prove =
- (make_concl "to prove" proof_conclusion) in
- B.V ([], induction_on::to_prove:: (make_cases args_for_cases))
-
- and make_cases l = List.map make_case l
-
- and make_case =
- function
- Con.ArgProof p ->
- let name =
- (match p.Con.proof_name with
- None -> B.b_kw "no name for case!!"
- | Some n -> B.Object ([], P.Mi([],n))) in
- let indhyps,args =
- List.partition
- (function
- `Hypothesis h -> h.Con.dec_inductive
- | _ -> false) p.Con.proof_context in
- let pattern_aux =
- List.fold_right
- (fun e p ->
- let dec =
- (match e with
- `Declaration h
- | `Hypothesis h ->
- let name =
- (match h.Con.dec_name with
- None -> "NO NAME???"
- | Some n ->n) in
- [B.b_space;
- B.Object ([], P.Mi ([],name));
- B.Text([],":");
- (term2pres h.Con.dec_type)]
- | _ -> [B.Text ([],"???")]) in
- dec@p) args [] in
- let pattern =
- B.H ([],
- (B.b_kw "Case"::B.b_space::name::pattern_aux)@
- [B.b_space;
- B.Text([], Utf8Macro.unicode_of_tex "\\Rightarrow")]) in
- let subconcl =
- (match p.Con.proof_conclude.Con.conclude_conclusion with
- None -> B.b_kw "No conclusion!!!"
- | Some t -> term2pres t) in
- let asubconcl = B.indent (make_concl "the thesis becomes" subconcl) in
- let induction_hypothesis =
- (match indhyps with
- [] -> []
- | _ ->
- let text = B.indent (B.b_kw "by induction hypothesis we know") in
- let make_hyp =
- function
- `Hypothesis h ->
- let name =
- (match h.Con.dec_name with
- None -> "no name"
- | Some s -> s) in
- B.indent (B.H ([],
- [B.Text([],"(");
- B.Object ([], P.Mi ([],name));
- B.Text([],")");
- B.b_space;
- term2pres h.Con.dec_type]))
- | _ -> assert false in
- let hyps = List.map make_hyp indhyps in
- text::hyps) in
- (* let acontext =
- acontext2pres_old p.Con.proof_apply_context true in *)
- let body = conclude2pres p.Con.proof_conclude true false in
- let presacontext =
- let acontext_id =
- match p.Con.proof_apply_context with
- [] -> p.Con.proof_conclude.Con.conclude_id
- | {Con.proof_id = id}::_ -> id
- in
- B.Action([None,"type","toggle"],
- [ B.indent (add_xref acontext_id (B.b_kw "Proof"));
- acontext2pres p.Con.proof_apply_context body true]) in
- B.V ([], pattern::asubconcl::induction_hypothesis@[presacontext])
- | _ -> assert false
-
- and falseind conclude =
- let proof_conclusion =
- (match conclude.Con.conclude_conclusion with
- None -> B.b_kw "No conclusion???"
- | Some t -> term2pres t) in
- let case_arg =
- (match conclude.Con.conclude_args with
- [Con.Aux(n);_;case_arg] -> case_arg
- | _ -> assert false;
- (*
- List.map (ContentPp.parg 0) conclude.Con.conclude_args;
- assert false *)) in
- let arg =
- (match case_arg with
- Con.Aux n -> assert false
- | Con.Premise prem ->
- (match prem.Con.premise_binder with
- None -> [B.b_kw "Contradiction, hence"]
- | Some n ->
- [ B.Object ([],P.Mi([],n)); B.skip;
- B.b_kw "is contradictory, hence"])
- | Con.Lemma lemma ->
- [ B.Object ([], P.Mi([],lemma.Con.lemma_name)); B.skip;
- B.b_kw "is contradictory, hence" ]
- | _ -> assert false) in
- (* let body = proof2pres {proof with Con.proof_context = tl} in *)
- make_row arg proof_conclusion
-
- and andind conclude =
- let proof,case_arg =
- (match conclude.Con.conclude_args with
- [Con.Aux(n);_;Con.ArgProof proof;case_arg] -> proof,case_arg
- | _ -> assert false;
- (*
- List.map (ContentPp.parg 0) conclude.Con.conclude_args;
- assert false *)) in
- let arg =
- (match case_arg with
- Con.Aux n -> assert false
- | Con.Premise prem ->
- (match prem.Con.premise_binder with
- None -> []
- | Some n -> [(B.b_kw "by"); B.b_space; B.Object([], P.Mi([],n))])
- | Con.Lemma lemma ->
- [(B.b_kw "by");B.skip;
- B.Object([], P.Mi([],lemma.Con.lemma_name))]
- | _ -> assert false) in
- match proof.Con.proof_context with
- `Hypothesis hyp1::`Hypothesis hyp2::tl ->
- let get_name hyp =
- (match hyp.Con.dec_name with
- None -> "_"
- | Some s -> s) in
- let preshyp1 =
- B.H ([],
- [B.Text([],"(");
- B.Object ([], P.Mi([],get_name hyp1));
- B.Text([],")");
- B.skip;
- term2pres hyp1.Con.dec_type]) in
- let preshyp2 =
- B.H ([],
- [B.Text([],"(");
- B.Object ([], P.Mi([],get_name hyp2));
- B.Text([],")");
- B.skip;
- term2pres hyp2.Con.dec_type]) in
- (* let body = proof2pres {proof with Con.proof_context = tl} in *)
- let body = conclude2pres proof.Con.proof_conclude false true in
- let presacontext =
- acontext2pres proof.Con.proof_apply_context body false in
- B.V
- ([],
- [B.H ([],arg@[B.skip; B.b_kw "we have"]);
- preshyp1;
- B.b_kw "and";
- preshyp2;
- presacontext]);
- | _ -> assert false
-
- and exists conclude =
- let proof =
- (match conclude.Con.conclude_args with
- [Con.Aux(n);_;Con.ArgProof proof;_] -> proof
- | _ -> assert false;
- (*
- List.map (ContentPp.parg 0) conclude.Con.conclude_args;
- assert false *)) in
- match proof.Con.proof_context with
- `Declaration decl::`Hypothesis hyp::tl
- | `Hypothesis decl::`Hypothesis hyp::tl ->
- let get_name decl =
- (match decl.Con.dec_name with
- None -> "_"
- | Some s -> s) in
- let presdecl =
- B.H ([],
- [(B.b_kw "let");
- B.skip;
- B.Object ([], P.Mi([],get_name decl));
- B.Text([],":"); term2pres decl.Con.dec_type]) in
- let suchthat =
- B.H ([],
- [(B.b_kw "such that");
- B.skip;
- B.Text([],"(");
- B.Object ([], P.Mi([],get_name hyp));
- B.Text([],")");
- B.skip;
- term2pres hyp.Con.dec_type]) in
- (* let body = proof2pres {proof with Con.proof_context = tl} in *)
- let body = conclude2pres proof.Con.proof_conclude false true in
- let presacontext =
- acontext2pres proof.Con.proof_apply_context body false in
- B.V
- ([],
- [presdecl;
- suchthat;
- presacontext]);
- | _ -> assert false
-
- in
- proof2pres p
-
-exception ToDo
-
-let counter = ref 0
-
-let conjecture2pres term2pres (id, n, context, ty) =
- B.b_indent
- (B.b_hv [Some "helm", "xref", id]
- ((B.b_toggle [
- B.b_h [] [B.b_text [] "{...}"; B.b_space];
- B.b_hv [] (List.map
- (function
- | None ->
- B.b_h []
- [ B.b_object (p_mi [] "_") ;
- B.b_object (p_mo [] ":?") ;
- B.b_object (p_mi [] "_")]
- | Some (`Declaration d)
- | Some (`Hypothesis d) ->
- let { Content.dec_name =
- dec_name ; Content.dec_type = ty } = d
- in
- B.b_h []
- [ B.b_object
- (p_mi []
- (match dec_name with
- None -> "_"
- | Some n -> n));
- B.b_text [] ":";
- term2pres ty ]
- | Some (`Definition d) ->
- let
- { Content.def_name = def_name ;
- Content.def_term = bo } = d
- in
- B.b_h []
- [ B.b_object (p_mi []
- (match def_name with
- None -> "_"
- | Some n -> n)) ;
- B.b_text [] (Utf8Macro.unicode_of_tex "\\Assign");
- term2pres bo]
- | Some (`Proof p) ->
- let proof_name = p.Content.proof_name in
- B.b_h []
- [ B.b_object (p_mi []
- (match proof_name with
- None -> "_"
- | Some n -> n)) ;
- B.b_text [] (Utf8Macro.unicode_of_tex "\\Assign");
- proof2pres term2pres p])
- (List.rev context)) ] ::
- [ B.b_h []
- [ B.b_text [] (Utf8Macro.unicode_of_tex "\\vdash");
- B.b_object (p_mi [] (string_of_int n)) ;
- B.b_text [] ":" ;
- term2pres ty ]])))
-
-let metasenv2pres term2pres = function
- | None -> []
- | Some metasenv' ->
- (* Conjectures are in their own table to make *)
- (* diffing the DOM trees easier. *)
- [B.b_v []
- ((B.b_kw ("Conjectures:" ^
- (let _ = incr counter; in (string_of_int !counter)))) ::
- (List.map (conjecture2pres term2pres) metasenv'))]
-
-let params2pres params =
- let param2pres uri =
- B.b_text [Some "xlink", "href", UriManager.string_of_uri uri]
- (UriManager.name_of_uri uri)
- in
- let rec spatiate = function
- | [] -> []
- | hd :: [] -> [hd]
- | hd :: tl -> hd :: B.b_text [] ", " :: spatiate tl
- in
- match params with
- | [] -> []
- | p ->
- let params = spatiate (List.map param2pres p) in
- [B.b_space;
- B.b_h [] (B.b_text [] "[" :: params @ [ B.b_text [] "]" ])]
-
-let recursion_kind2pres params kind =
- let kind =
- match kind with
- | `Recursive _ -> "Recursive definition"
- | `CoRecursive -> "CoRecursive definition"
- | `Inductive _ -> "Inductive definition"
- | `CoInductive _ -> "CoInductive definition"
- in
- B.b_h [] (B.b_kw kind :: params2pres params)
-
-let inductive2pres term2pres ind =
- let constructor2pres decl =
- B.b_h [] [
- B.b_text [] ("| " ^ get_name decl.Content.dec_name ^ ":");
- B.b_space;
- term2pres decl.Content.dec_type
- ]
- in
- B.b_v []
- (B.b_h [] [
- B.b_kw (ind.Content.inductive_name ^ " of arity");
- B.smallskip;
- term2pres ind.Content.inductive_type ]
- :: List.map constructor2pres ind.Content.inductive_constructors)
-
-let joint_def2pres term2pres def =
- match def with
- | `Inductive ind -> inductive2pres term2pres ind
- | _ -> assert false (* ZACK or raise ToDo? *)
-
-let content2pres term2pres (id,params,metasenv,obj) =
- match obj with
- | `Def (Content.Const, thesis, `Proof p) ->
- let name = get_name p.Content.proof_name in
- B.b_v
- [Some "helm","xref","id"]
- ([ B.b_h [] (B.b_kw ("Proof " ^ name) :: params2pres params);
- B.b_kw "Thesis:";
- B.indent (term2pres thesis) ] @
- metasenv2pres term2pres metasenv @
- [proof2pres term2pres p])
- | `Def (_, ty, `Definition body) ->
- let name = get_name body.Content.def_name in
- B.b_v
- [Some "helm","xref","id"]
- ([B.b_h [] (B.b_kw ("Definition " ^ name) :: params2pres params);
- B.b_kw "Type:";
- B.indent (term2pres ty)] @
- metasenv2pres term2pres metasenv @
- [B.b_kw "Body:"; term2pres body.Content.def_term])
- | `Decl (_, `Declaration decl)
- | `Decl (_, `Hypothesis decl) ->
- let name = get_name decl.Content.dec_name in
- B.b_v
- [Some "helm","xref","id"]
- ([B.b_h [] (B.b_kw ("Axiom " ^ name) :: params2pres params);
- B.b_kw "Type:";
- B.indent (term2pres decl.Content.dec_type)] @
- metasenv2pres term2pres metasenv)
- | `Joint joint ->
- B.b_v []
- (recursion_kind2pres params joint.Content.joint_kind
- :: List.map (joint_def2pres term2pres) joint.Content.joint_defs)
- | _ -> raise ToDo
-
-let content2pres ~ids_to_inner_sorts =
- content2pres
- (fun annterm ->
- let ast, ids_to_uris =
- TermAcicContent.ast_of_acic ids_to_inner_sorts annterm
- in
- CicNotationPres.box_of_mpres
- (CicNotationPres.render ids_to_uris
- (TermContentPres.pp_ast ast)))
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(**************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(**************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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)
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-type xml_attribute = string option * string * string
-type markup = [ `MathML | `BoxML ]
-
-let color1 = "blue"
-(* let color2 = "red" *)
-let color2 = "blue"
-
-let keyword_attributes = function
- | `MathML -> [ None, "mathcolor", color1 ]
- | `BoxML -> [ None, "color", color1 ]
-
-let builtin_symbol_attributes = function
- | `MathML -> [ None, "mathcolor", color1 ]
- | `BoxML -> [ None, "color", color1 ]
-
-let object_keyword_attributes = function
- | `MathML -> [ None, "mathcolor", color2 ]
- | `BoxML -> [ None, "color", color2 ]
-
-let symbol_attributes _ = []
-let ident_attributes _ = []
-let number_attributes _ = []
-
-let spacing_attributes _ = [ None, "spacing", "0.5em" ]
-let indent_attributes _ = [ None, "indent", "0.5em" ]
-let small_skip_attributes _ = [ None, "width", "0.5em" ]
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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)))
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(***************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 []
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 -> ()
-
+++ /dev/null
-componentsConf.cmo: componentsConf.cmi
-componentsConf.cmx: componentsConf.cmi
-hExtlib.cmo: componentsConf.cmi hExtlib.cmi
-hExtlib.cmx: componentsConf.cmx hExtlib.cmi
-hMarshal.cmo: hExtlib.cmi hMarshal.cmi
-hMarshal.cmx: hExtlib.cmx hMarshal.cmi
-patternMatcher.cmo: patternMatcher.cmi
-patternMatcher.cmx: patternMatcher.cmi
-hLog.cmo: hLog.cmi
-hLog.cmx: hLog.cmi
-trie.cmo: trie.cmi
-trie.cmx: trie.cmi
+++ /dev/null
-PACKAGE = extlib
-PREDICATES =
-
-INTERFACE_FILES = \
- componentsConf.mli \
- hExtlib.mli \
- hMarshal.mli \
- patternMatcher.mli \
- hLog.mli \
- trie.mli \
- $(NULL)
-IMPLEMENTATION_FILES = \
- $(INTERFACE_FILES:%.mli=%.ml)
-EXTRA_OBJECTS_TO_INSTALL =
-EXTRA_OBJECTS_TO_CLEAN =
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2006, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-let debug = @DEBUG@
-let profiling = debug
-
+++ /dev/null
-(* Copyright (C) 2006, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-val debug: bool
-val profiling: bool
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-(** PROFILING *)
-
-let profiling_enabled = ComponentsConf.profiling
-
-let profiling_printings = ref (fun () -> true)
-let set_profiling_printings f = profiling_printings := f
-
-type profiler = { profile : 'a 'b. ('a -> 'b) -> 'a -> 'b }
-let profile ?(enable = true) =
- if profiling_enabled && enable then
- function s ->
- let total = ref 0.0 in
- let profile f x =
- let before = Unix.gettimeofday () in
- try
- let res = f x in
- let after = Unix.gettimeofday () in
- total := !total +. (after -. before);
- res
- with
- exc ->
- let after = Unix.gettimeofday () in
- total := !total +. (after -. before);
- raise exc
- in
- at_exit
- (fun () ->
- if !profiling_printings () then
- prerr_endline
- ("!! TOTAL TIME SPENT IN " ^ s ^ ": " ^ string_of_float !total));
- { profile = profile }
- else
- function _ -> { profile = fun f x -> f x }
-
-(** {2 Optional values} *)
-
-let map_option f = function None -> None | Some v -> Some (f v)
-let iter_option f = function None -> () | Some v -> f v
-let unopt = function None -> failwith "unopt: None" | Some v -> v
-
-(** {2 String processing} *)
-
-let split ?(sep = ' ') s =
- let pieces = ref [] in
- let rec aux idx =
- match (try Some (String.index_from s idx sep) with Not_found -> None) with
- | Some pos ->
- pieces := String.sub s idx (pos - idx) :: !pieces;
- aux (pos + 1)
- | None -> pieces := String.sub s idx (String.length s - idx) :: !pieces
- in
- aux 0;
- List.rev !pieces
-
-let trim_blanks s =
- let rec find_left idx =
- match s.[idx] with
- | ' ' | '\t' | '\r' | '\n' -> find_left (idx + 1)
- | _ -> idx
- in
- let rec find_right idx =
- match s.[idx] with
- | ' ' | '\t' | '\r' | '\n' -> find_right (idx - 1)
- | _ -> idx
- in
- let s_len = String.length s in
- let left, right = find_left 0, find_right (s_len - 1) in
- String.sub s left (right - left + 1)
-
-(** {2 Char processing} *)
-
-let is_alpha c =
- let code = Char.code c in
- (code >= 65 && code <= 90) || (code >= 97 && code <= 122)
-
-let is_digit c =
- let code = Char.code c in
- code >= 48 && code <= 57
-
-let is_blank c =
- let code = Char.code c in
- code = 9 || code = 10 || code = 13 || code = 32
-
-let is_alphanum c = is_alpha c || is_digit c
-
-(** {2 List processing} *)
-
-let rec list_uniq ?(eq=(=)) = function
- | [] -> []
- | h::[] -> [h]
- | h1::h2::tl when eq h1 h2 -> list_uniq ~eq (h2 :: tl)
- | h1::tl (* when h1 <> h2 *) -> h1 :: list_uniq ~eq tl
-
-let rec filter_map f =
- function
- | [] -> []
- | hd :: tl ->
- (match f hd with
- | None -> filter_map f tl
- | Some v -> v :: filter_map f tl)
-
-let list_concat ?(sep = []) =
- let rec aux acc =
- function
- | [] -> []
- | [ last ] -> List.flatten (List.rev (last :: acc))
- | hd :: tl -> aux ([sep; hd] @ acc) tl
- in
- aux []
-
-let rec list_findopt f l =
- let rec aux = function
- | [] -> None
- | x::tl ->
- (match f x with
- | None -> aux tl
- | Some _ as rc -> rc)
- in
- aux l
-
-(** {2 File predicates} *)
-
-let is_dir fname =
- try
- (Unix.stat fname).Unix.st_kind = Unix.S_DIR
- with Unix.Unix_error _ -> false
-
-let is_regular fname =
- try
- (Unix.stat fname).Unix.st_kind = Unix.S_REG
- with Unix.Unix_error _ -> false
-
-let mkdir path =
- let components = split ~sep:'/' path in
- let rec aux where = function
- | [] -> ()
- | piece::tl ->
- let path =
- if where = "" then piece else where ^ "/" ^ piece in
- (try
- Unix.mkdir path 0o755
- with
- | Unix.Unix_error (Unix.EEXIST,_,_) -> ()
- | Unix.Unix_error (e,_,_) ->
- raise
- (Failure
- ("Unix.mkdir " ^ path ^ " 0o755 :" ^ (Unix.error_message e))));
- aux path tl
- in
- let where = if path.[0] = '/' then "/" else "" in
- aux where components
-
-(** {2 Filesystem} *)
-
-let input_file fname =
- let size = (Unix.stat fname).Unix.st_size in
- let buf = Buffer.create size in
- let ic = open_in fname in
- Buffer.add_channel buf ic size;
- close_in ic;
- Buffer.contents buf
-
-let input_all ic =
- let size = 10240 in
- let buf = Buffer.create size in
- let s = String.create size in
- (try
- while true do
- let bytes = input ic s 0 size in
- if bytes = 0 then raise End_of_file
- else Buffer.add_substring buf s 0 bytes
- done
- with End_of_file -> ());
- Buffer.contents buf
-
-let output_file ~filename ~text =
- let oc = open_out filename in
- output_string oc text;
- close_out oc
-
-let blank_split s =
- let len = String.length s in
- let buf = Buffer.create 0 in
- let rec aux acc i =
- if i >= len
- then begin
- if Buffer.length buf > 0
- then List.rev (Buffer.contents buf :: acc)
- else List.rev acc
- end else begin
- if is_blank s.[i] then
- if Buffer.length buf > 0 then begin
- let s = Buffer.contents buf in
- Buffer.clear buf;
- aux (s :: acc) (i + 1)
- end else
- aux acc (i + 1)
- else begin
- Buffer.add_char buf s.[i];
- aux acc (i + 1)
- end
- end
- in
- aux [] 0
-
- (* Rules: * "~name" -> home dir of "name"
- * "~" -> value of $HOME if defined, home dir of the current user otherwise *)
-let tilde_expand s =
- let get_home login = (Unix.getpwnam login).Unix.pw_dir in
- let expand_one s =
- let len = String.length s in
- if len > 0 && s.[0] = '~' then begin
- let login_len = ref 1 in
- while !login_len < len && is_alphanum (s.[!login_len]) do
- incr login_len
- done;
- let login = String.sub s 1 (!login_len - 1) in
- try
- let home =
- if login = "" then
- try Sys.getenv "HOME" with Not_found -> get_home (Unix.getlogin ())
- else
- get_home login
- in
- home ^ String.sub s !login_len (len - !login_len)
- with Not_found | Invalid_argument _ -> s
- end else
- s
- in
- String.concat " " (List.map expand_one (blank_split s))
-
-let find ?(test = fun _ -> true) path =
- let rec aux acc todo =
- match todo with
- | [] -> acc
- | path :: tl ->
- try
- let handle = Unix.opendir path in
- let dirs = ref [] in
- let matching_files = ref [] in
- (try
- while true do
- match Unix.readdir handle with
- | "." | ".." -> ()
- | entry ->
- let qentry = path ^ "/" ^ entry in
- (try
- if is_dir qentry then
- dirs := qentry :: !dirs
- else if test qentry then
- matching_files := qentry :: !matching_files;
- with Unix.Unix_error _ -> ())
- done
- with End_of_file -> Unix.closedir handle);
- aux (!matching_files @ acc) (!dirs @ tl)
- with Unix.Unix_error _ -> aux acc tl
- in
- aux [] [path]
-
-let safe_remove fname = if Sys.file_exists fname then Sys.remove fname
-
-let is_dir_empty d =
- let od = Unix.opendir d in
- let rec aux () =
- let name = Unix.readdir od in
- if name <> "." && name <> ".." then false else aux () in
- let res = try aux () with End_of_file -> true in
- Unix.closedir od;
- res
-
-let safe_rmdir d = try Unix.rmdir d with Unix.Unix_error _ -> ()
-
-let rec rmdir_descend d =
- if is_dir_empty d then
- begin
- safe_rmdir d;
- rmdir_descend (Filename.dirname d)
- end
-
-
-(** {2 Exception handling} *)
-
-let finally at_end f arg =
- let res =
- try f arg
- with exn -> at_end (); raise exn
- in
- at_end ();
- res
-
-(** {2 Localized exceptions } *)
-
-exception Localized of Token.flocation * exn
-
-let loc_of_floc = function
- | { Lexing.pos_cnum = loc_begin }, { Lexing.pos_cnum = loc_end } ->
- (loc_begin, loc_end)
-
-let floc_of_loc (loc_begin, loc_end) =
- let floc_begin =
- { Lexing.pos_fname = ""; Lexing.pos_lnum = -1; Lexing.pos_bol = -1;
- Lexing.pos_cnum = loc_begin }
- in
- let floc_end = { floc_begin with Lexing.pos_cnum = loc_end } in
- (floc_begin, floc_end)
-
-let dummy_floc = floc_of_loc (-1, -1)
-
-let raise_localized_exception ~offset floc exn =
- let (x, y) = loc_of_floc floc in
- let x = offset + x in
- let y = offset + y in
- let flocb,floce = floc in
- let floc =
- { flocb with Lexing.pos_cnum = x }, { floce with Lexing.pos_cnum = y }
- in
- raise (Localized (floc, exn))
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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))
- ()
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(*
- * 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-http_getter_env.cmi: http_getter_types.cmo
-http_getter_common.cmi: http_getter_types.cmo
-http_getter.cmi: http_getter_types.cmo
-http_getter_wget.cmo: http_getter_types.cmo http_getter_wget.cmi
-http_getter_wget.cmx: http_getter_types.cmx http_getter_wget.cmi
-http_getter_logger.cmo: http_getter_logger.cmi
-http_getter_logger.cmx: http_getter_logger.cmi
-http_getter_misc.cmo: http_getter_logger.cmi http_getter_misc.cmi
-http_getter_misc.cmx: http_getter_logger.cmx http_getter_misc.cmi
-http_getter_const.cmo: http_getter_const.cmi
-http_getter_const.cmx: http_getter_const.cmi
-http_getter_env.cmo: http_getter_types.cmo http_getter_misc.cmi \
- http_getter_logger.cmi http_getter_const.cmi http_getter_env.cmi
-http_getter_env.cmx: http_getter_types.cmx http_getter_misc.cmx \
- http_getter_logger.cmx http_getter_const.cmx http_getter_env.cmi
-http_getter_storage.cmo: http_getter_wget.cmi http_getter_types.cmo \
- http_getter_misc.cmi http_getter_env.cmi http_getter_storage.cmi
-http_getter_storage.cmx: http_getter_wget.cmx http_getter_types.cmx \
- http_getter_misc.cmx http_getter_env.cmx http_getter_storage.cmi
-http_getter_common.cmo: http_getter_types.cmo http_getter_misc.cmi \
- http_getter_logger.cmi http_getter_env.cmi http_getter_common.cmi
-http_getter_common.cmx: http_getter_types.cmx http_getter_misc.cmx \
- http_getter_logger.cmx http_getter_env.cmx http_getter_common.cmi
-http_getter.cmo: http_getter_wget.cmi http_getter_types.cmo \
- http_getter_storage.cmi http_getter_misc.cmi http_getter_logger.cmi \
- http_getter_env.cmi http_getter_const.cmi http_getter_common.cmi \
- http_getter.cmi
-http_getter.cmx: http_getter_wget.cmx http_getter_types.cmx \
- http_getter_storage.cmx http_getter_misc.cmx http_getter_logger.cmx \
- http_getter_env.cmx http_getter_const.cmx http_getter_common.cmx \
- http_getter.cmi
+++ /dev/null
-#use "topfind";;
-#require "helm-getter";;
-Helm_registry.load_from "sample.conf.xml";;
+++ /dev/null
-
-PACKAGE = getter
-
-INTERFACE_FILES = \
- http_getter_wget.mli \
- http_getter_logger.mli \
- http_getter_misc.mli \
- http_getter_const.mli \
- http_getter_env.mli \
- http_getter_storage.mli \
- http_getter_common.mli \
- http_getter.mli \
- $(NULL)
-
-IMPLEMENTATION_FILES = \
- http_getter_types.ml \
- $(INTERFACE_FILES:%.mli=%.ml)
-
-include ../../Makefile.defs
-include ../Makefile.common
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 = Http_getter_env.get_dtd_dir () ^ "/" ^ uri in
- if not (Sys.file_exists fname) then raise (Dtd_not_found uri);
- fname
- end
-
-let clean_cache () =
- if remote () then
- clean_cache_remote ()
- else
- Http_getter_storage.clean_cache ()
-
-let (++) (oldann, oldtypes, oldbody, oldtree)
- (newann, newtypes, newbody, newtree) =
- ((if newann > oldann then newann else oldann),
- (if newtypes > oldtypes then newtypes else oldtypes),
- (if newbody > oldbody then newbody else oldbody),
- (if newtree > oldtree then newtree else oldtree))
-
-let store_obj tbl o =
-(* prerr_endline ("Http_getter.store_obj " ^ o); *)
- if Pcre.pmatch ~rex:showable_file_RE o then begin
- let basepart = Pcre.replace ~rex:basepart_RE ~templ:"$1" o in
- let no_flags = false, No, No, No in
- let oldflags =
- try
- Hashtbl.find tbl basepart
- with Not_found -> (* no ann, no types, no body, no proof tree *)
- no_flags
- in
- let newflags =
- match o with
- | s when Pcre.pmatch ~rex:types_RE s -> (false, Yes, No, No)
- | s when Pcre.pmatch ~rex:types_ann_RE s -> (true, Ann, No, No)
- | s when Pcre.pmatch ~rex:body_RE s -> (false, No, Yes, No)
- | s when Pcre.pmatch ~rex:body_ann_RE s -> (true, No, Ann, No)
- | s when Pcre.pmatch ~rex:proof_tree_RE s -> (false, No, No, Yes)
- | s when Pcre.pmatch ~rex:proof_tree_ann_RE s -> (true, No, No, Ann)
- | s -> no_flags
- in
- Hashtbl.replace tbl basepart (oldflags ++ newflags)
- end
-
-let store_dir set_ref d =
- set_ref := StringSet.add (List.hd (Pcre.split ~rex:slash_RE d)) !set_ref
-
-let collect_ls_items dirs_set objs_tbl =
- let items = ref [] in
- StringSet.iter (fun dir -> items := Ls_section dir :: !items) dirs_set;
- Http_getter_misc.hashtbl_sorted_iter
- (fun uri (annflag, typesflag, bodyflag, treeflag) ->
- items :=
- Ls_object {
- uri = uri; ann = annflag;
- types = typesflag; body = bodyflag; proof_tree = treeflag
- } :: !items)
- objs_tbl;
- List.rev !items
-
-let contains_object = (<>) []
-
- (** non regexp-aware version of ls *)
-let rec dumb_ls uri_prefix =
-(* prerr_endline ("Http_getter.dumb_ls " ^ uri_prefix); *)
- if is_cic_obj_uri uri_prefix then begin
- let dirs = ref StringSet.empty in
- let objs = Hashtbl.create 17 in
- List.iter
- (fun fname ->
- if ends_with_slash fname then
- store_dir dirs fname
- else
- try
- store_obj objs (strip_suffix ~suffix:xml_suffix fname)
- with Invalid_argument _ -> ())
- (Http_getter_storage.ls uri_prefix);
- collect_ls_items !dirs objs
- end else if is_theory_uri uri_prefix then begin
- let items = ref [] in
- let add_theory fname =
- items :=
- Ls_object {
- uri = fname; ann = false; types = No; body = No; proof_tree = No }
- :: !items
- in
- let cic_uri_prefix =
- Pcre.replace_first ~rex:heading_theory_RE ~templ:"cic:" uri_prefix
- in
- List.iter
- (fun fname ->
- if ends_with_slash fname then
- items := Ls_section (strip_trailing_slash fname) :: !items
- else
- try
- let fname = strip_suffix ~suffix:xml_suffix fname in
- let theory_name = strip_suffix ~suffix:theory_suffix fname in
- let sub_theory = normalize_dir cic_uri_prefix ^ theory_name ^ "/" in
- if is_empty_theory sub_theory then add_theory fname
- with Invalid_argument _ -> ())
- (Http_getter_storage.ls uri_prefix);
- (try
- if contains_object (dumb_ls cic_uri_prefix)
- && exists (strip_trailing_slash uri_prefix ^ theory_suffix)
- then
- add_theory "index.theory";
- with Unresolvable_URI _ -> ());
- !items
- end else
- raise (Invalid_URI uri_prefix)
-
-and is_empty_theory uri_prefix =
-(* prerr_endline ("is_empty_theory " ^ uri_prefix); *)
- not (contains_object (dumb_ls uri_prefix))
-
- (* handle simple regular expressions of the form "...(..|..|..)..." on cic
- * uris, not meant to be a real implementation of regexp. The only we use is
- * "(cic|theory):/..." *)
-let explode_ls_regexp regexp =
- try
- let len = String.length regexp in
- let lparen_idx = String.index regexp '(' in
- let rparen_idx = String.index_from regexp lparen_idx ')' in
- let choices_str = (* substring between parens, parens excluded *)
- String.sub regexp (lparen_idx + 1) (rparen_idx - lparen_idx - 1)
- in
- let choices = Pcre.split ~rex:pipe_RE choices_str in
- let prefix = String.sub regexp 0 lparen_idx in
- let suffix = String.sub regexp (rparen_idx + 1) (len - (rparen_idx + 1)) in
- List.map (fun choice -> prefix ^ choice ^ suffix) choices
- with Not_found -> [regexp]
-
-let merge_results results =
- let rec aux objects_acc dirs_acc = function
- | [] -> dirs_acc @ objects_acc
- | Ls_object _ as obj :: tl -> aux (obj :: objects_acc) dirs_acc tl
- | Ls_section _ as dir :: tl ->
- if List.mem dir dirs_acc then (* filters out dir duplicates *)
- aux objects_acc dirs_acc tl
- else
- aux objects_acc (dir :: dirs_acc) tl
- in
- aux [] [] (List.concat results)
-
-let ls regexp =
- if remote () then
- ls_remote regexp
- else
- let prefixes = explode_ls_regexp regexp in
- merge_results (List.map dumb_ls prefixes)
-
-let getalluris () =
- let rec aux acc = function
- | [] -> acc
- | dir :: todo ->
- let acc', todo' =
- List.fold_left
- (fun (acc, subdirs) result ->
- match result with
- | Ls_object obj -> (dir ^ obj.uri) :: acc, subdirs
- | Ls_section sect -> acc, (dir ^ sect ^ "/") :: subdirs)
- (acc, todo)
- (dumb_ls dir)
- in
- aux acc' todo'
- in
- aux [] ["cic:/"] (* trailing slash required *)
-
-(* Shorthands from now on *)
-
-let getxml' uri = getxml (UriManager.string_of_uri uri)
-let resolve' uri = resolve (UriManager.string_of_uri uri)
-let exists' uri = exists (UriManager.string_of_uri uri)
-
-let tilde_expand_key k =
- try
- Helm_registry.set k (HExtlib.tilde_expand (Helm_registry.get k))
- with Helm_registry.Key_not_found _ -> ()
-
-let init () =
- List.iter tilde_expand_key ["getter.cache_dir"; "getter.dtd_dir"];
- Http_getter_logger.set_log_level
- (Helm_registry.get_opt_default Helm_registry.int ~default:1
- "getter.log_level");
- Http_getter_logger.set_log_file
- (Helm_registry.get_opt Helm_registry.string "getter.log_file")
-
+++ /dev/null
-(*
- * 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
-
+++ /dev/null
-(*
- * 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 (Http_getter_env.get_dtd_dir ())
- in
- fun line -> Pcre.replace ~rex ~templ line
-
-let patch_entity = patch_system "ENTITY"
-let patch_doctype = patch_system "DOCTYPE"
-
-let patch_xmlbase =
- let rex = Pcre.regexp "^(\\s*<\\w[^ ]*)(\\s|>)" in
- fun xmlbases baseurl baseuri s ->
- let s' =
- Pcre.replace ~rex
- ~templ:(sprintf "$1 xml:base=\"%s\" helm:base=\"%s\"$2" baseurl baseuri)
- s
- in
- if s <> s' then xmlbases := None;
- s'
-
-let patch_dtd = patch_entity
-let patch_xml ?via_http ?xmlbases () =
- let xmlbases = ref xmlbases in
- fun line ->
- match !xmlbases with
- | None -> patch_doctype ?via_http () (patch_entity ?via_http () line)
- | Some (xmlbaseuri, xmlbaseurl) ->
- patch_xmlbase xmlbases xmlbaseurl xmlbaseuri
- (patch_doctype ?via_http () (patch_entity ?via_http () line))
-
-let return_file
- ~fname ?contype ?contenc ?patch_fun ?(gunzip = false) ?(via_http = true)
- ~enc outchan
-=
- if via_http then begin
- let headers =
- match (contype, contenc) with
- | (Some t, Some e) -> ["Content-Encoding", e; "Content-Type", t]
- | (Some t, None) -> ["Content-Type" , t]
- | (None, Some e) -> ["Content-Encoding", e]
- | (None, None) -> []
- in
- Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
- Http_daemon.send_headers headers outchan;
- Http_daemon.send_CRLF outchan
- end;
- match gunzip, patch_fun with
- | true, Some patch_fun ->
- Http_getter_logger.log ~level:2
- "Patch required, uncompress/compress cycle needed :-(";
- (* gunzip needed, uncompress file, apply patch_fun to it, compress the
- * result and sent it to client *)
- let (tmp1, tmp2) =
- (Http_getter_misc.tempfile (), Http_getter_misc.tempfile ())
- in
- (try
- Http_getter_misc.gunzip ~keep:true ~output:tmp1 fname; (* gunzip tmp1 *)
- let new_file = open_out tmp2 in
- Http_getter_misc.iter_file (* tmp2 = patch(tmp1) *)
- (fun line ->
- output_string new_file (patch_fun line ^ "\n");
- flush outchan)
- tmp1;
- close_out new_file;
- Http_getter_misc.gzip ~output:tmp1 tmp2;(* tmp1 = gzip(tmp2); rm tmp2 *)
- Http_getter_misc.iter_file (* send tmp1 to client as is*)
- (fun line -> output_string outchan (line ^ "\n"); flush outchan)
- tmp1;
- Sys.remove tmp1 (* rm tmp1 *)
- with e ->
- Sys.remove tmp1;
- raise e)
- | false, Some patch_fun ->
- (match enc with
- | `Normal ->
- Http_getter_misc.iter_file
- (fun line -> output_string outchan (patch_fun (line ^ "\n")))
- fname
- | `Gzipped -> assert false)
- (* dangerous case, if this happens it needs to be investigated *)
- | _, None -> Http_getter_misc.iter_file_data (output_string outchan) fname
-;;
-
+++ /dev/null
-(*
- * 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
-
+++ /dev/null
-(*
- * 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[&format=(normal|gz)][&patch_dtd=(yes|no)]</kbd></b><br />
- </p>
- <p>
- <b><kbd>resolve?uri=URI</kbd></b><br />
- </p>
- <p>
- <b><kbd>getdtd?uri=URI[&patch_dtd=(yes|no)]</kbd></b><br />
- </p>
- <p>
- <b><kbd>getxslt?uri=URI[&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&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 />
-"
-
+++ /dev/null
-(*
- * 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
-
+++ /dev/null
-(*
- * 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 (
- match Helm_registry.get_opt Helm_registry.get_string "getter.dtd_dir" with
- | None -> None
- | Some dir -> Some (normalize_dir dir))
-let dtd_base_urls = lazy (
- let rex = Pcre.regexp "/*$" in
- let raw_urls =
- match
- Helm_registry.get_list Helm_registry.string "getter.dtd_base_urls"
- with
- | [] -> ["http://helm.cs.unibo.it/dtd"; "http://mowgli.cs.unibo.it/dtd"]
- | urls -> urls
- in
- List.map (Pcre.replace ~rex) raw_urls)
-let port = lazy (
- Helm_registry.get_opt_default Helm_registry.int ~default:58081 "getter.port")
-
-let parse_prefix_attrs s =
- List.fold_right
- (fun s acc ->
- match s with
- | "ro" -> `Read_only :: acc
- | "legacy" -> `Legacy :: acc
- | s ->
- Http_getter_logger.log ("ignoring unknown attribute: " ^ s);
- acc)
- (Pcre.split s) []
-
-let prefixes = lazy (
- let prefixes = Helm_registry.get_list Helm_registry.string "getter.prefix" in
- List.fold_left
- (fun acc prefix ->
- let subs = Pcre.extract ~rex:prefix_RE prefix in
- try
- (subs.(1), (subs.(2), parse_prefix_attrs subs.(3))) :: acc
- with Invalid_argument _ ->
- Http_getter_logger.log ("skipping invalid prefix: " ^ prefix);
- acc)
- [] prefixes)
-
-let host = lazy (Http_getter_misc.backtick "hostname -f")
-
-let my_own_url =
- lazy
- (let (host, port) = (Lazy.force host, Lazy.force port) in
- sprintf "http://%s%s" (* without trailing '/' *)
- host (if port = 80 then "" else (sprintf ":%d" port)))
-
-let env_to_string () =
- let pp_attr = function `Read_only -> "ro" | `Legacy -> "legacy" in
- let pp_prefix (uri_prefix, (url_prefix, attrs)) =
- sprintf " %s -> %s [%s]" uri_prefix url_prefix
- (String.concat "," (List.map pp_attr attrs)) in
- let pp_prefixes prefixes =
- match prefixes with
- | [] -> ""
- | l -> "\n" ^ String.concat "\n" (List.map pp_prefix l)
- in
- sprintf
-"HTTP Getter %s
-
-prefixes:%s
-dtd_dir:\t%s
-host:\t\t%s
-port:\t\t%d
-my_own_url:\t%s
-dtd_base_urls:\t%s
-log_file:\t%s
-log_level:\t%d
-"
- version
- (pp_prefixes (Lazy.force prefixes))
- (match Lazy.force dtd_dir with Some dir -> dir | None -> "NONE")
- (Lazy.force host) (Lazy.force port)
- (Lazy.force my_own_url) (String.concat " " (Lazy.force dtd_base_urls))
- (match Http_getter_logger.get_log_file () with None -> "None" | Some f -> f)
- (Http_getter_logger.get_log_level ())
-
-let get_dtd_dir () =
- match Lazy.force dtd_dir with
- | None -> raise (Internal_error "dtd_dir is not available")
- | Some dtd_dir -> dtd_dir
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Http_getter_types
-
- (** {2 general information} *)
-
-val version : string (* getter version *)
-
- (** {2 environment gathered data} *)
- (** all *_dir values are returned with trailing "/" *)
-
-val cache_dir : string lazy_t (* cache root *)
-val dtd_dir : string option lazy_t (* DTDs' root directory *)
-val port : int lazy_t (* port on which getter listens *)
-val dtd_base_urls : string list lazy_t (* base URLs for document patching *)
-val prefixes : (string * (string * prefix_attr list)) list lazy_t
- (* prefix map uri -> url + attrs *)
-
- (* {2 derived data} *)
-
-val host : string lazy_t (* host on which getter listens *)
-val my_own_url : string lazy_t (* URL at which contact getter *)
-
- (* {2 misc} *)
-
-val env_to_string : unit -> string (* dump a textual representation of the
- current http_getter settings on an output
- channel *)
-
-val get_dtd_dir : unit -> string
-
+++ /dev/null
-(*
- * 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
-
+++ /dev/null
-(*
- * 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
-
+++ /dev/null
-(*
- * 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
-
+++ /dev/null
-(*
- * 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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)))
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(*
- * 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 ]
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-#!/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;
-}
+++ /dev/null
-<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>
+++ /dev/null
-(* $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 -> ())
-
+++ /dev/null
-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
+++ /dev/null
-PACKAGE = grafite
-PREDICATES =
-
-INTERFACE_FILES = \
- grafiteAstPp.mli \
- grafiteMarshal.mli \
- $(NULL)
-IMPLEMENTATION_FILES = \
- grafiteAst.ml \
- $(INTERFACE_FILES:%.mli=%.ml)
-
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-type direction = [ `LeftToRight | `RightToLeft ]
-
-type loc = Token.flocation
-
-type ('term, 'lazy_term, 'ident) pattern =
- 'lazy_term option * ('ident * 'term) list * 'term option
-
-type ('term, 'ident) type_spec =
- | Ident of 'ident
- | Type of UriManager.uri * int
-
-type 'lazy_term reduction =
- [ `Demodulate
- | `Normalize
- | `Reduce
- | `Simpl
- | `Unfold of 'lazy_term option
- | `Whd ]
-
-type ('term, 'lazy_term, 'reduction, 'ident) tactic =
- | Absurd of loc * 'term
- | Apply of loc * 'term
- | Assumption of loc
- | Auto of loc * int option * int option * string option * string option
- (* depth, width, paramodulation, full *) (* ALB *)
- | Change of loc * ('term, 'lazy_term, 'ident) pattern * 'lazy_term
- | Clear of loc * 'ident
- | ClearBody of loc * 'ident
- | Compare of loc * 'term
- | Constructor of loc * int
- | Contradiction of loc
- | Cut of loc * 'ident option * 'term
- | DecideEquality of loc
- | Decompose of loc * ('term, 'ident) type_spec list * 'ident * 'ident list
- | Discriminate of loc * 'term
- | Elim of loc * 'term * 'term option * int option * 'ident list
- | ElimType of loc * 'term * 'term option * int option * 'ident list
- | Exact of loc * 'term
- | Exists of loc
- | Fail of loc
- | Fold of loc * 'reduction * 'lazy_term * ('term, 'lazy_term, 'ident) pattern
- | Fourier of loc
- | FwdSimpl of loc * string * 'ident list
- | Generalize of loc * ('term, 'lazy_term, 'ident) pattern * 'ident option
- | Goal of loc * int (* change current goal, argument is goal number 1-based *)
- | IdTac of loc
- | Injection of loc * 'term
- | Intros of loc * int option * 'ident list
- | Inversion of loc * 'term
- | LApply of loc * int option * 'term list * 'term * 'ident option
- | Left of loc
- | LetIn of loc * 'term * 'ident
- | Reduce of loc * 'reduction * ('term, 'lazy_term, 'ident) pattern
- | Reflexivity of loc
- | Replace of loc * ('term, 'lazy_term, 'ident) pattern * 'lazy_term
- | Rewrite of loc * direction * 'term *
- ('term, 'lazy_term, 'ident) pattern
- | Right of loc
- | Ring of loc
- | Split of loc
- | Symmetry of loc
- | Transitivity of loc * 'term
-
-type search_kind = [ `Locate | `Hint | `Match | `Elim ]
-
-type print_kind = [ `Env | `Coer ]
-
-type 'term macro =
- (* Whelp's stuff *)
- | WHint of loc * 'term
- | WMatch of loc * 'term
- | WInstance of loc * 'term
- | WLocate of loc * string
- | WElim of loc * 'term
- (* real macros *)
-(* | Abort of loc *)
- | Print of loc * string
- | Check of loc * 'term
- | Hint of loc
- | Quit of loc
-(* | Redo of loc * int option
- | Undo of loc * int option *)
-(* | Print of loc * print_kind *)
- | Search_pat of loc * search_kind * string (* searches with string pattern *)
- | Search_term of loc * search_kind * 'term (* searches with term pattern *)
-
-(** To be increased each time the command type below changes, used for "safe"
- * marshalling *)
-let magic = 5
-
-type 'obj command =
- | Default of loc * string * UriManager.uri list
- | Include of loc * string
- | Set of loc * string * string
- | Drop of loc
- | Qed of loc
- | Coercion of loc * UriManager.uri * bool (* add composites *)
- | Obj of loc * 'obj
-
-type ('term, 'lazy_term, 'reduction, 'ident) tactical =
- | Tactic of loc * ('term, 'lazy_term, 'reduction, 'ident) tactic
- | Do of loc * int * ('term, 'lazy_term, 'reduction, 'ident) tactical
- | Repeat of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical
- | Seq of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list
- (* sequential composition *)
- | Then of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical *
- ('term, 'lazy_term, 'reduction, 'ident) tactical list
- | First of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list
- (* try a sequence of loc * tactical until one succeeds, fail otherwise *)
- | Try of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical
- (* try a tactical and mask failures *)
- | Solve of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list
-
- | Dot of loc
- | Semicolon of loc
- | Branch of loc
- | Shift of loc
- | Pos of loc * int
- | Merge of loc
- | Focus of loc * int list
- | Unfocus of loc
- | Skip of loc
-
-let is_punctuation =
- function
- | Dot _ | Semicolon _ | Branch _ | Shift _ | Merge _ | Pos _ -> true
- | _ -> false
-
-type ('term, 'lazy_term, 'reduction, 'obj, 'ident) code =
- | Command of loc * 'obj command
- | Macro of loc * 'term macro
- | Tactical of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical
- * ('term, 'lazy_term, 'reduction, 'ident) tactical option(* punctuation *)
-
-type ('term, 'lazy_term, 'reduction, 'obj, 'ident) comment =
- | Note of loc * string
- | Code of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) code
-
-type ('term, 'lazy_term, 'reduction, 'obj, 'ident) statement =
- | Executable of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) code
- | Comment of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) comment
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-
-open GrafiteAst
-
-let tactical_terminator = ""
-let tactic_terminator = tactical_terminator
-let command_terminator = tactical_terminator
-
-let pp_idents idents = "[" ^ String.concat "; " idents ^ "]"
-
-let pp_reduction_kind ~term_pp = function
- | `Demodulate -> "demodulate"
- | `Normalize -> "normalize"
- | `Reduce -> "reduce"
- | `Simpl -> "simplify"
- | `Unfold (Some t) -> "unfold " ^ term_pp t
- | `Unfold None -> "unfold"
- | `Whd -> "whd"
-
-let pp_tactic_pattern ~term_pp ~lazy_term_pp (what, hyp, goal) =
- let what_text =
- match what with
- | None -> ""
- | Some t -> sprintf "in match (%s) " (lazy_term_pp t) in
- let hyp_text =
- String.concat " "
- (List.map (fun (name, p) -> sprintf "%s:(%s)" name (term_pp p)) hyp) in
- let goal_text =
- match goal with
- | None -> ""
- | Some t -> sprintf "\\vdash (%s)" (term_pp t) in
- sprintf "%sin %s%s" what_text hyp_text goal_text
-
-let pp_intros_specs = function
- | None, [] -> ""
- | Some num, [] -> Printf.sprintf " names %i" num
- | None, idents -> Printf.sprintf " names %s" (pp_idents idents)
- | Some num, idents -> Printf.sprintf " names %i %s" num (pp_idents idents)
-
-let terms_pp ~term_pp terms = String.concat ", " (List.map term_pp terms)
-
-let rec pp_tactic ~term_pp ~lazy_term_pp =
- let pp_reduction_kind = pp_reduction_kind ~term_pp in
- let pp_tactic_pattern = pp_tactic_pattern ~lazy_term_pp ~term_pp in
- function
- | Absurd (_, term) -> "absurd" ^ term_pp term
- | Apply (_, term) -> "apply " ^ term_pp term
- | Auto _ -> "auto"
- | Assumption _ -> "assumption"
- | Change (_, where, with_what) ->
- sprintf "change %s with %s" (pp_tactic_pattern where) (lazy_term_pp with_what)
- | Clear (_,id) -> sprintf "clear %s" id
- | ClearBody (_,id) -> sprintf "clearbody %s" id
- | Compare (_,term) -> "compare " ^ term_pp term
- | Constructor (_,n) -> "constructor " ^ string_of_int n
- | Contradiction _ -> "contradiction"
- | Cut (_, ident, term) ->
- "cut " ^ term_pp term ^
- (match ident with None -> "" | Some id -> " as " ^ id)
- | DecideEquality _ -> "decide equality"
- | Decompose (_, [], what, names) ->
- sprintf "decompose %s%s" what (pp_intros_specs (None, names))
- | Decompose (_, types, what, names) ->
- let to_ident = function
- | Ident id -> id
- | Type _ -> assert false
- in
- let types = List.rev_map to_ident types in
- sprintf "decompose %s %s%s" (pp_idents types) what (pp_intros_specs (None, names))
- | Discriminate (_, term) -> "discriminate " ^ term_pp term
- | Elim (_, term, using, num, idents) ->
- sprintf "elim " ^ term_pp term ^
- (match using with None -> "" | Some term -> " using " ^ term_pp term)
- ^ pp_intros_specs (num, idents)
- | ElimType (_, term, using, num, idents) ->
- sprintf "elim type " ^ term_pp term ^
- (match using with None -> "" | Some term -> " using " ^ term_pp term)
- ^ pp_intros_specs (num, idents)
- | Exact (_, term) -> "exact " ^ term_pp term
- | Exists _ -> "exists"
- | Fold (_, kind, term, pattern) ->
- sprintf "fold %s %s %s" (pp_reduction_kind kind)
- (lazy_term_pp term) (pp_tactic_pattern pattern)
- | FwdSimpl (_, hyp, idents) ->
- sprintf "fwd %s%s" hyp
- (match idents with [] -> "" | idents -> " " ^ pp_idents idents)
- | Generalize (_, pattern, ident) ->
- sprintf "generalize %s%s" (pp_tactic_pattern pattern)
- (match ident with None -> "" | Some id -> " as " ^ id)
- | Goal (_, n) -> "goal " ^ string_of_int n
- | Fail _ -> "fail"
- | Fourier _ -> "fourier"
- | IdTac _ -> "id"
- | Injection (_, term) -> "injection " ^ term_pp term
- | Intros (_, None, []) -> "intro"
- | Inversion (_, term) -> "inversion " ^ term_pp term
- | Intros (_, num, idents) ->
- sprintf "intros%s%s"
- (match num with None -> "" | Some num -> " " ^ string_of_int num)
- (match idents with [] -> "" | idents -> " " ^ pp_idents idents)
- | LApply (_, level_opt, terms, term, ident_opt) ->
- sprintf "lapply %s%s%s%s"
- (match level_opt with None -> "" | Some i -> " depth = " ^ string_of_int i ^ " ")
- (term_pp term)
- (match terms with [] -> "" | _ -> " to " ^ terms_pp ~term_pp terms)
- (match ident_opt with None -> "" | Some ident -> " using " ^ ident)
- | Left _ -> "left"
- | LetIn (_, term, ident) -> sprintf "let %s in %s" (term_pp term) ident
- | Reduce (_, kind, pat) ->
- sprintf "%s %s" (pp_reduction_kind kind) (pp_tactic_pattern pat)
- | Reflexivity _ -> "reflexivity"
- | Replace (_, pattern, t) ->
- sprintf "replace %s with %s" (pp_tactic_pattern pattern) (lazy_term_pp t)
- | Rewrite (_, pos, t, pattern) ->
- sprintf "rewrite %s %s %s"
- (if pos = `LeftToRight then ">" else "<")
- (term_pp t)
- (pp_tactic_pattern pattern)
- | Right _ -> "right"
- | Ring _ -> "ring"
- | Split _ -> "split"
- | Symmetry _ -> "symmetry"
- | Transitivity (_, term) -> "transitivity " ^ term_pp term
-
-let pp_search_kind = function
- | `Locate -> "locate"
- | `Hint -> "hint"
- | `Match -> "match"
- | `Elim -> "elim"
- | `Instance -> "instance"
-
-let pp_macro ~term_pp = function
- (* Whelp *)
- | WInstance (_, term) -> "whelp instance " ^ term_pp term
- | WHint (_, t) -> "whelp hint " ^ term_pp t
- | WLocate (_, s) -> "whelp locate " ^ s
- | WElim (_, t) -> "whelp elim " ^ term_pp t
- | WMatch (_, term) -> "whelp match " ^ term_pp term
- (* real macros *)
- | Check (_, term) -> sprintf "Check %s" (term_pp term)
- | Hint _ -> "hint"
- | Search_pat (_, kind, pat) ->
- sprintf "search %s \"%s\"" (pp_search_kind kind) pat
- | Search_term (_, kind, term) ->
- sprintf "search %s %s" (pp_search_kind kind) (term_pp term)
- | Print (_, name) -> sprintf "Print \"%s\"" name
- | Quit _ -> "Quit"
-
-let pp_associativity = function
- | Gramext.LeftA -> "left associative"
- | Gramext.RightA -> "right associative"
- | Gramext.NonA -> "non associative"
-
-let pp_precedence i = sprintf "with precedence %d" i
-
-let pp_dir_opt = function
- | None -> ""
- | Some `LeftToRight -> "> "
- | Some `RightToLeft -> "< "
-
-let pp_default what uris =
- sprintf "default \"%s\" %s" what
- (String.concat " " (List.map UriManager.string_of_uri uris))
-
-let pp_coercion uri do_composites =
- sprintf "coercion %s (* %s *)" (UriManager.string_of_uri uri)
- (if do_composites then "compounds" else "no compounds")
-
-let pp_command ~obj_pp = function
- | Include (_,path) -> "include " ^ path
- | Qed _ -> "qed"
- | Drop _ -> "drop"
- | Set (_, name, value) -> sprintf "set \"%s\" \"%s\"" name value
- | Coercion (_, uri, do_composites) -> pp_coercion uri do_composites
- | Obj (_,obj) -> obj_pp obj
- | Default (_,what,uris) ->
- pp_default what uris
-
-let rec pp_tactical ~term_pp ~lazy_term_pp =
- let pp_tactic = pp_tactic ~lazy_term_pp ~term_pp in
- let pp_tacticals = pp_tacticals ~lazy_term_pp ~term_pp in
- function
- | Tactic (_, tac) -> pp_tactic tac
- | Do (_, count, tac) ->
- sprintf "do %d %s" count (pp_tactical ~term_pp ~lazy_term_pp tac)
- | Repeat (_, tac) -> "repeat " ^ pp_tactical ~term_pp ~lazy_term_pp tac
- | Seq (_, tacs) -> pp_tacticals ~sep:"; " tacs
- | Then (_, tac, tacs) ->
- sprintf "%s; [%s]" (pp_tactical ~term_pp ~lazy_term_pp tac)
- (pp_tacticals ~sep:" | " tacs)
- | First (_, tacs) -> sprintf "tries [%s]" (pp_tacticals ~sep:" | " tacs)
- | Try (_, tac) -> "try " ^ pp_tactical ~term_pp ~lazy_term_pp tac
- | Solve (_, tac) -> sprintf "solve [%s]" (pp_tacticals ~sep:" | " tac)
-
- | Dot _ -> "."
- | Semicolon _ -> ";"
- | Branch _ -> "["
- | Shift _ -> "|"
- | Pos (_, i) -> sprintf "%d:" i
- | Merge _ -> "]"
- | Focus (_, goals) ->
- sprintf "focus %s" (String.concat " " (List.map string_of_int goals))
- | Unfocus _ -> "unfocus"
- | Skip _ -> "skip"
-
-and pp_tacticals ~term_pp ~lazy_term_pp ~sep tacs =
- String.concat sep (List.map (pp_tactical~lazy_term_pp ~term_pp) tacs)
-
-let pp_executable ~term_pp ~lazy_term_pp ~obj_pp =
- function
- | Macro (_, macro) -> pp_macro ~term_pp macro
- | Tactical (_, tac, Some punct) ->
- pp_tactical ~lazy_term_pp ~term_pp tac
- ^ pp_tactical ~lazy_term_pp ~term_pp punct
- | Tactical (_, tac, None) -> pp_tactical ~lazy_term_pp ~term_pp tac
- | Command (_, cmd) -> pp_command ~obj_pp cmd
-
-let pp_comment ~term_pp ~lazy_term_pp ~obj_pp =
- function
- | Note (_,str) -> sprintf "(* %s *)" str
- | Code (_,code) ->
- sprintf "(** %s. **)" (pp_executable ~term_pp ~lazy_term_pp ~obj_pp code)
-
-let pp_statement ~term_pp ~lazy_term_pp ~obj_pp =
- function
- | Executable (_, ex) -> pp_executable ~lazy_term_pp ~term_pp ~obj_pp ex
- | Comment (_, c) -> pp_comment ~term_pp ~lazy_term_pp ~obj_pp c
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-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
+++ /dev/null
-PACKAGE = grafite_engine
-PREDICATES =
-
-INTERFACE_FILES = \
- grafiteTypes.mli \
- grafiteSync.mli \
- grafiteMisc.mli \
- grafiteEngine.mli \
- $(NULL)
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-
-exception Drop
-exception IncludedFileNotCompiled of string (* file name *)
-exception Macro of
- GrafiteAst.loc *
- (Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro)
-exception ReadOnlyUri of string
-
-type options = {
- do_heavy_checks: bool ;
- clean_baseuri: bool
-}
-
-(** create a ProofEngineTypes.mk_fresh_name_type function which uses given
- * names as long as they are available, then it fallbacks to name generation
- * using FreshNamesGenerator module *)
-let namer_of names =
- let len = List.length names in
- let count = ref 0 in
- fun metasenv context name ~typ ->
- if !count < len then begin
- let name = Cic.Name (List.nth names !count) in
- incr count;
- name
- end else
- FreshNamesGenerator.mk_fresh_name ~subst:[] metasenv context name ~typ
-
-let tactic_of_ast ast =
- let module PET = ProofEngineTypes in
- match ast with
- | GrafiteAst.Absurd (_, term) -> Tactics.absurd term
- | GrafiteAst.Apply (_, term) -> Tactics.apply term
- | GrafiteAst.Assumption _ -> Tactics.assumption
- | GrafiteAst.Auto (_,depth,width,paramodulation,full) ->
- AutoTactic.auto_tac ?depth ?width ?paramodulation ?full
- ~dbd:(LibraryDb.instance ()) ()
- | GrafiteAst.Change (_, pattern, with_what) ->
- Tactics.change ~pattern with_what
- | GrafiteAst.Clear (_,id) -> Tactics.clear id
- | GrafiteAst.ClearBody (_,id) -> Tactics.clearbody id
- | GrafiteAst.Contradiction _ -> Tactics.contradiction
- | GrafiteAst.Compare (_, term) -> Tactics.compare term
- | GrafiteAst.Constructor (_, n) -> Tactics.constructor n
- | GrafiteAst.Cut (_, ident, term) ->
- let names = match ident with None -> [] | Some id -> [id] in
- Tactics.cut ~mk_fresh_name_callback:(namer_of names) term
- | GrafiteAst.DecideEquality _ -> Tactics.decide_equality
- | GrafiteAst.Decompose (_, types, what, names) ->
- let to_type = function
- | GrafiteAst.Type (uri, typeno) -> uri, typeno
- | GrafiteAst.Ident _ -> assert false
- in
- let user_types = List.rev_map to_type types in
- let dbd = LibraryDb.instance () in
- let mk_fresh_name_callback = namer_of names in
- Tactics.decompose ~mk_fresh_name_callback ~dbd ~user_types what
- | GrafiteAst.Discriminate (_,term) -> Tactics.discriminate term
- | GrafiteAst.Elim (_, what, using, depth, names) ->
- Tactics.elim_intros ?using ?depth ~mk_fresh_name_callback:(namer_of names)
- what
- | GrafiteAst.ElimType (_, what, using, depth, names) ->
- Tactics.elim_type ?using ?depth ~mk_fresh_name_callback:(namer_of names)
- what
- | GrafiteAst.Exact (_, term) -> Tactics.exact term
- | GrafiteAst.Exists _ -> Tactics.exists
- | GrafiteAst.Fail _ -> Tactics.fail
- | GrafiteAst.Fold (_, reduction_kind, term, pattern) ->
- let reduction =
- match reduction_kind with
- | `Demodulate ->
- GrafiteTypes.command_error "demodulation can't be folded"
- | `Normalize ->
- PET.const_lazy_reduction
- (CicReduction.normalize ~delta:false ~subst:[])
- | `Reduce -> PET.const_lazy_reduction ProofEngineReduction.reduce
- | `Simpl -> PET.const_lazy_reduction ProofEngineReduction.simpl
- | `Unfold None ->
- PET.const_lazy_reduction (ProofEngineReduction.unfold ?what:None)
- | `Unfold (Some lazy_term) ->
- (fun context metasenv ugraph ->
- let what, metasenv, ugraph = lazy_term context metasenv ugraph in
- ProofEngineReduction.unfold ~what, metasenv, ugraph)
- | `Whd ->
- PET.const_lazy_reduction (CicReduction.whd ~delta:false ~subst:[])
- in
- Tactics.fold ~reduction ~term ~pattern
- | GrafiteAst.Fourier _ -> Tactics.fourier
- | GrafiteAst.FwdSimpl (_, hyp, names) ->
- Tactics.fwd_simpl ~mk_fresh_name_callback:(namer_of names)
- ~dbd:(LibraryDb.instance ()) hyp
- | GrafiteAst.Generalize (_,pattern,ident) ->
- let names = match ident with None -> [] | Some id -> [id] in
- Tactics.generalize ~mk_fresh_name_callback:(namer_of names) pattern
- | GrafiteAst.Goal (_, n) -> Tactics.set_goal n
- | GrafiteAst.IdTac _ -> Tactics.id
- | GrafiteAst.Injection (_,term) -> Tactics.injection term
- | GrafiteAst.Intros (_, None, names) ->
- PrimitiveTactics.intros_tac ~mk_fresh_name_callback:(namer_of names) ()
- | GrafiteAst.Intros (_, Some num, names) ->
- PrimitiveTactics.intros_tac ~howmany:num
- ~mk_fresh_name_callback:(namer_of names) ()
- | GrafiteAst.Inversion (_, term) ->
- Tactics.inversion term
- | GrafiteAst.LApply (_, how_many, to_what, what, ident) ->
- let names = match ident with None -> [] | Some id -> [id] in
- Tactics.lapply ~mk_fresh_name_callback:(namer_of names) ?how_many
- ~to_what what
- | GrafiteAst.Left _ -> Tactics.left
- | GrafiteAst.LetIn (loc,term,name) ->
- Tactics.letin term ~mk_fresh_name_callback:(namer_of [name])
- | GrafiteAst.Reduce (_, reduction_kind, pattern) ->
- (match reduction_kind with
- | `Demodulate -> Tactics.demodulate ~dbd:(LibraryDb.instance ()) ~pattern
- | `Normalize -> Tactics.normalize ~pattern
- | `Reduce -> Tactics.reduce ~pattern
- | `Simpl -> Tactics.simpl ~pattern
- | `Unfold what -> Tactics.unfold ~pattern what
- | `Whd -> Tactics.whd ~pattern)
- | GrafiteAst.Reflexivity _ -> Tactics.reflexivity
- | GrafiteAst.Replace (_, pattern, with_what) ->
- Tactics.replace ~pattern ~with_what
- | GrafiteAst.Rewrite (_, direction, t, pattern) ->
- EqualityTactics.rewrite_tac ~direction ~pattern t
- | GrafiteAst.Right _ -> Tactics.right
- | GrafiteAst.Ring _ -> Tactics.ring
- | GrafiteAst.Split _ -> Tactics.split
- | GrafiteAst.Symmetry _ -> Tactics.symmetry
- | GrafiteAst.Transitivity (_, term) -> Tactics.transitivity term
-
-(* maybe we only need special cases for apply and goal *)
-let classify_tactic tactic =
- match tactic with
- (* tactics that can't close the goal (return a goal we want to "select") *)
- | GrafiteAst.Rewrite _
- | GrafiteAst.Split _
- | GrafiteAst.Replace _
- | GrafiteAst.Reduce _
- | GrafiteAst.Injection _
- | GrafiteAst.IdTac _
- | GrafiteAst.Generalize _
- | GrafiteAst.Elim _
- | GrafiteAst.Cut _
- | GrafiteAst.Decompose _ -> true, true
- (* tactics we don't want to reorder goals. I think only Goal needs this. *)
- | GrafiteAst.Goal _ -> false, true
- (* tactics like apply *)
- | _ -> true, false
-
-let reorder_metasenv start refine tactic goals current_goal always_opens_a_goal=
- let module PEH = ProofEngineHelpers in
-(* let print_m name metasenv =
- prerr_endline (">>>>> " ^ name);
- prerr_endline (CicMetaSubst.ppmetasenv [] metasenv)
- in *)
- (* phase one calculates:
- * new_goals_from_refine: goals added by refine
- * head_goal: the first goal opened by ythe tactic
- * other_goals: other goals opened by the tactic
- *)
- let new_goals_from_refine = PEH.compare_metasenvs start refine in
- let new_goals_from_tactic = PEH.compare_metasenvs refine tactic in
- let head_goal, other_goals, goals =
- match goals with
- | [] -> None,[],goals
- | hd::tl ->
- (* assert (List.mem hd new_goals_from_tactic);
- * invalidato dalla goal_tac
- * *)
- Some hd, List.filter ((<>) hd) new_goals_from_tactic, List.filter ((<>)
- hd) goals
- in
- let produced_goals =
- match head_goal with
- | None -> new_goals_from_refine @ other_goals
- | Some x -> x :: new_goals_from_refine @ other_goals
- in
- (* extract the metas generated by refine and tactic *)
- let metas_for_tactic_head =
- match head_goal with
- | None -> []
- | Some head_goal -> List.filter (fun (n,_,_) -> n = head_goal) tactic in
- let metas_for_tactic_goals =
- List.map
- (fun x -> List.find (fun (metano,_,_) -> metano = x) tactic)
- goals
- in
- let metas_for_refine_goals =
- List.filter (fun (n,_,_) -> List.mem n new_goals_from_refine) tactic in
- let produced_metas, goals =
- let produced_metas =
- if always_opens_a_goal then
- metas_for_tactic_head @ metas_for_refine_goals @
- metas_for_tactic_goals
- else begin
-(* print_m "metas_for_refine_goals" metas_for_refine_goals;
- print_m "metas_for_tactic_head" metas_for_tactic_head;
- print_m "metas_for_tactic_goals" metas_for_tactic_goals; *)
- metas_for_refine_goals @ metas_for_tactic_head @
- metas_for_tactic_goals
- end
- in
- let goals = List.map (fun (metano, _, _) -> metano) produced_metas in
- produced_metas, goals
- in
- (* residual metas, preserving the original order *)
- let before, after =
- let rec split e =
- function
- | [] -> [],[]
- | (metano, _, _) :: tl when metano = e ->
- [], List.map (fun (x,_,_) -> x) tl
- | (metano, _, _) :: tl -> let b, a = split e tl in metano :: b, a
- in
- let find n metasenv =
- try
- Some (List.find (fun (metano, _, _) -> metano = n) metasenv)
- with Not_found -> None
- in
- let extract l =
- List.fold_right
- (fun n acc ->
- match find n tactic with
- | Some x -> x::acc
- | None -> acc
- ) l [] in
- let before_l, after_l = split current_goal start in
- let before_l =
- List.filter (fun x -> not (List.mem x produced_goals)) before_l in
- let after_l =
- List.filter (fun x -> not (List.mem x produced_goals)) after_l in
- let before = extract before_l in
- let after = extract after_l in
- before, after
- in
-(* |+ DEBUG CODE +|
- print_m "BEGIN" start;
- prerr_endline ("goal was: " ^ string_of_int current_goal);
- prerr_endline ("and metas from refine are:");
- List.iter
- (fun t -> prerr_string (" " ^ string_of_int t))
- new_goals_from_refine;
- prerr_endline "";
- print_m "before" before;
- print_m "metas_for_tactic_head" metas_for_tactic_head;
- print_m "metas_for_refine_goals" metas_for_refine_goals;
- print_m "metas_for_tactic_goals" metas_for_tactic_goals;
- print_m "produced_metas" produced_metas;
- print_m "after" after;
-|+ FINE DEBUG CODE +| *)
- before @ produced_metas @ after, goals
-
-let apply_tactic ~disambiguate_tactic tactic (status, goal) =
-(* prerr_endline "apply_tactic"; *)
-(* prerr_endline (Continuationals.Stack.pp (GrafiteTypes.get_stack status)); *)
- let starting_metasenv = GrafiteTypes.get_proof_metasenv status in
- let before = List.map (fun g, _, _ -> g) starting_metasenv in
-(* prerr_endline "disambiguate"; *)
- let status, tactic = disambiguate_tactic status goal tactic in
- let metasenv_after_refinement = GrafiteTypes.get_proof_metasenv status in
- let proof = GrafiteTypes.get_current_proof status in
- let proof_status = proof, goal in
- let needs_reordering, always_opens_a_goal = classify_tactic tactic in
- let tactic = tactic_of_ast tactic in
- (* apply tactic will change the lexicon_status ... *)
-(* prerr_endline "apply_tactic bassa"; *)
- let (proof, opened) = ProofEngineTypes.apply_tactic tactic proof_status in
- let after = ProofEngineTypes.goals_of_proof proof in
- let opened_goals, closed_goals = Tacticals.goals_diff ~before ~after ~opened in
-(* prerr_endline("before: " ^ String.concat ", " (List.map string_of_int before));
-prerr_endline("after: " ^ String.concat ", " (List.map string_of_int after));
-prerr_endline("opened: " ^ String.concat ", " (List.map string_of_int opened)); *)
-(* prerr_endline("opened_goals: " ^ String.concat ", " (List.map string_of_int opened_goals));
-prerr_endline("closed_goals: " ^ String.concat ", " (List.map string_of_int closed_goals)); *)
- let proof, opened_goals =
- if needs_reordering then begin
- let uri, metasenv_after_tactic, t, ty = proof in
-(* prerr_endline ("goal prima del riordino: " ^ String.concat " " (List.map string_of_int (ProofEngineTypes.goals_of_proof proof))); *)
- let reordered_metasenv, opened_goals =
- reorder_metasenv
- starting_metasenv
- metasenv_after_refinement metasenv_after_tactic
- opened goal always_opens_a_goal
- in
- let proof' = uri, reordered_metasenv, t, ty in
-(* prerr_endline ("goal dopo il riordino: " ^ String.concat " " (List.map string_of_int (ProofEngineTypes.goals_of_proof proof'))); *)
- proof', opened_goals
- end
- else
- proof, opened_goals
- in
- let incomplete_proof =
- match status.GrafiteTypes.proof_status with
- | GrafiteTypes.Incomplete_proof p -> p
- | _ -> assert false
- in
- { status with GrafiteTypes.proof_status =
- GrafiteTypes.Incomplete_proof
- { incomplete_proof with GrafiteTypes.proof = proof } },
- opened_goals, closed_goals
-
-type eval_ast =
- {ea_go:
- 'term 'lazy_term 'reduction 'obj 'ident.
- disambiguate_tactic:
- (GrafiteTypes.status ->
- ProofEngineTypes.goal ->
- ('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic ->
- GrafiteTypes.status *
- (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) ->
-
- disambiguate_command:
- (GrafiteTypes.status ->
- 'obj GrafiteAst.command ->
- GrafiteTypes.status * Cic.obj GrafiteAst.command) ->
-
- disambiguate_macro:
- (GrafiteTypes.status ->
- 'term GrafiteAst.macro ->
- Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) ->
-
- ?do_heavy_checks:bool ->
- ?clean_baseuri:bool ->
- GrafiteTypes.status ->
- ('term, 'lazy_term, 'reduction, 'obj, 'ident) GrafiteAst.statement ->
- GrafiteTypes.status * UriManager.uri list
- }
-
-type 'a eval_command =
- {ec_go: 'term 'obj.
- disambiguate_command:
- (GrafiteTypes.status ->
- 'obj GrafiteAst.command ->
- GrafiteTypes.status * Cic.obj GrafiteAst.command) ->
- options -> GrafiteTypes.status -> 'obj GrafiteAst.command ->
- GrafiteTypes.status * UriManager.uri list
- }
-
-type 'a eval_executable =
- {ee_go: 'term 'lazy_term 'reduction 'obj 'ident.
- disambiguate_tactic:
- (GrafiteTypes.status ->
- ProofEngineTypes.goal ->
- ('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic ->
- GrafiteTypes.status *
- (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) ->
-
- disambiguate_command:
- (GrafiteTypes.status ->
- 'obj GrafiteAst.command ->
- GrafiteTypes.status * Cic.obj GrafiteAst.command) ->
-
- disambiguate_macro:
- (GrafiteTypes.status ->
- 'term GrafiteAst.macro ->
- Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) ->
-
- options ->
- GrafiteTypes.status ->
- ('term, 'lazy_term, 'reduction, 'obj, 'ident) GrafiteAst.code ->
- GrafiteTypes.status * UriManager.uri list
- }
-
-type 'a eval_from_moo =
- { efm_go: GrafiteTypes.status -> string -> GrafiteTypes.status }
-
-let coercion_moo_statement_of uri =
- GrafiteAst.Coercion (HExtlib.dummy_floc, uri, false)
-
-let eval_coercion status ~add_composites uri =
- let basedir = Helm_registry.get "matita.basedir" in
- let status,compounds =
- prerr_endline "evaluating a coercion command";
- GrafiteSync.add_coercion ~basedir ~add_composites status uri in
- let moo_content = coercion_moo_statement_of uri in
- let status = GrafiteTypes.add_moo_content [moo_content] status in
- {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof},
- compounds
-
-let eval_tactical ~disambiguate_tactic status tac =
- let apply_tactic = apply_tactic ~disambiguate_tactic in
- let module MatitaStatus =
- struct
- type input_status = GrafiteTypes.status * ProofEngineTypes.goal
-
- type output_status =
- GrafiteTypes.status * ProofEngineTypes.goal list * ProofEngineTypes.goal list
-
- type tactic = input_status -> output_status
-
- let id_tactic = apply_tactic (GrafiteAst.IdTac HExtlib.dummy_floc)
- let mk_tactic tac = tac
- let apply_tactic tac = tac
- let goals (_, opened, closed) = opened, closed
- let set_goals (opened, closed) (status, _, _) = (status, opened, closed)
- let get_stack (status, _) = GrafiteTypes.get_stack status
-
- let set_stack stack (status, opened, closed) =
- GrafiteTypes.set_stack stack status, opened, closed
-
- let inject (status, _) = (status, [], [])
- let focus goal (status, _, _) = (status, goal)
- end
- in
- let module MatitaTacticals = Tacticals.Make (MatitaStatus) in
- let rec tactical_of_ast l tac =
- match tac with
- | GrafiteAst.Tactic (loc, tactic) ->
- MatitaTacticals.tactic (MatitaStatus.mk_tactic (apply_tactic tactic))
- | GrafiteAst.Seq (loc, tacticals) -> (* tac1; tac2; ... *)
- assert (l > 0);
- MatitaTacticals.seq ~tactics:(List.map (tactical_of_ast (l+1)) tacticals)
- | GrafiteAst.Do (loc, n, tactical) ->
- MatitaTacticals.do_tactic ~n ~tactic:(tactical_of_ast (l+1) tactical)
- | GrafiteAst.Repeat (loc, tactical) ->
- MatitaTacticals.repeat_tactic ~tactic:(tactical_of_ast (l+1) tactical)
- | GrafiteAst.Then (loc, tactical, tacticals) -> (* tac; [ tac1 | ... ] *)
- assert (l > 0);
- MatitaTacticals.thens ~start:(tactical_of_ast (l+1) tactical)
- ~continuations:(List.map (tactical_of_ast (l+1)) tacticals)
- | GrafiteAst.First (loc, tacticals) ->
- MatitaTacticals.first
- ~tactics:(List.map (fun t -> "", tactical_of_ast (l+1) t) tacticals)
- | GrafiteAst.Try (loc, tactical) ->
- MatitaTacticals.try_tactic ~tactic:(tactical_of_ast (l+1) tactical)
- | GrafiteAst.Solve (loc, tacticals) ->
- MatitaTacticals.solve_tactics
- ~tactics:(List.map (fun t -> "", tactical_of_ast (l+1) t) tacticals)
-
- | GrafiteAst.Skip loc -> MatitaTacticals.skip
- | GrafiteAst.Dot loc -> MatitaTacticals.dot
- | GrafiteAst.Semicolon loc -> MatitaTacticals.semicolon
- | GrafiteAst.Branch loc -> MatitaTacticals.branch
- | GrafiteAst.Shift loc -> MatitaTacticals.shift
- | GrafiteAst.Pos (loc, i) -> MatitaTacticals.pos i
- | GrafiteAst.Merge loc -> MatitaTacticals.merge
- | GrafiteAst.Focus (loc, goals) -> MatitaTacticals.focus goals
- | GrafiteAst.Unfocus loc -> MatitaTacticals.unfocus
- in
- let status, _, _ = tactical_of_ast 0 tac (status, ~-1) in
- let status = (* is proof completed? *)
- match status.GrafiteTypes.proof_status with
- | GrafiteTypes.Incomplete_proof
- { GrafiteTypes.stack = stack; proof = proof }
- when Continuationals.Stack.is_empty stack ->
- { status with GrafiteTypes.proof_status = GrafiteTypes.Proof proof }
- | _ -> status
- in
- status
-
-let eval_comment status c = status
-
-(* since the record syntax allows to declare coercions, we have to put this
- * information inside the moo *)
-let add_coercions_of_record_to_moo obj lemmas status =
- let attributes = CicUtil.attributes_of_obj obj in
- let is_record = function `Class (`Record att) -> Some att | _-> None in
- match HExtlib.list_findopt is_record attributes with
- | None -> status,[]
- | Some fields ->
- let is_a_coercion uri =
- try
- let obj,_ =
- CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri in
- let attrs = CicUtil.attributes_of_obj obj in
- List.mem (`Class `Projection) attrs
- with Not_found -> assert false
- in
- (* looking at the fields we can know the 'wanted' coercions, but not the
- * actually generated ones. So, only the intersection between the wanted
- * and the actual should be in the moo as coercion, while everithing in
- * lemmas should go as aliases *)
- let wanted_coercions =
- HExtlib.filter_map
- (function
- | (name,true) ->
- Some
- (UriManager.uri_of_string
- (GrafiteTypes.qualify status name ^ ".con"))
- | _ -> None)
- fields
- in
- prerr_endline "wanted coercions:";
- List.iter
- (fun u -> prerr_endline (UriManager.string_of_uri u))
- wanted_coercions;
- let coercions, moo_content =
- List.split
- (HExtlib.filter_map
- (fun uri ->
- let is_a_wanted_coercion =
- List.exists (UriManager.eq uri) wanted_coercions in
- if is_a_coercion uri && is_a_wanted_coercion then
- Some (uri, coercion_moo_statement_of uri)
- else
- None)
- lemmas)
- in
- prerr_endline "actual coercions:";
- List.iter
- (fun u -> prerr_endline (UriManager.string_of_uri u))
- coercions;
- let status = GrafiteTypes.add_moo_content moo_content status in
- {status with
- GrafiteTypes.coercions = coercions @ status.GrafiteTypes.coercions},
- lemmas
-
-let add_obj uri obj status =
- let basedir = Helm_registry.get "matita.basedir" in
- let status,lemmas = GrafiteSync.add_obj ~basedir uri obj status in
- status, lemmas
-
-let rec eval_command = {ec_go = fun ~disambiguate_command opts status cmd ->
- let status,cmd = disambiguate_command status cmd in
- let basedir = Helm_registry.get "matita.basedir" in
- let status,uris =
- match cmd with
- | GrafiteAst.Default (loc, what, uris) as cmd ->
- LibraryObjects.set_default what uris;
- GrafiteTypes.add_moo_content [cmd] status,[]
- | GrafiteAst.Include (loc, baseuri) ->
- let moopath = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in
- if not (Sys.file_exists moopath) then
- raise (IncludedFileNotCompiled moopath);
- let status = eval_from_moo.efm_go status moopath in
- status,[]
- | GrafiteAst.Set (loc, name, value) ->
- if name = "baseuri" then begin
- let value =
- let v = Http_getter_misc.strip_trailing_slash value in
- try
- ignore (String.index v ' ');
- GrafiteTypes.command_error "baseuri can't contain spaces"
- with Not_found -> v
- in
- if Http_getter_storage.is_read_only value then begin
- HLog.error (sprintf "uri %s belongs to a read-only repository" value);
- raise (ReadOnlyUri value)
- end;
- if not (GrafiteMisc.is_empty value) && opts.clean_baseuri then begin
- HLog.message ("baseuri " ^ value ^ " is not empty");
- HLog.message ("cleaning baseuri " ^ value);
- LibraryClean.clean_baseuris ~basedir [value];
- end;
- end;
- GrafiteTypes.set_option status name value,[]
- | GrafiteAst.Drop loc -> raise Drop
- | GrafiteAst.Qed loc ->
- let uri, metasenv, bo, ty =
- match status.GrafiteTypes.proof_status with
- | GrafiteTypes.Proof (Some uri, metasenv, body, ty) ->
- uri, metasenv, body, ty
- | GrafiteTypes.Proof (None, metasenv, body, ty) ->
- raise (GrafiteTypes.Command_error
- ("Someone allows to start a theorem without giving the "^
- "name/uri. This should be fixed!"))
- | _->
- raise
- (GrafiteTypes.Command_error "You can't Qed an incomplete theorem")
- in
- if metasenv <> [] then
- raise
- (GrafiteTypes.Command_error
- "Proof not completed! metasenv is not empty!");
- let name = UriManager.name_of_uri uri in
- let obj = Cic.Constant (name,Some bo,ty,[],[]) in
- let status, lemmas = add_obj uri obj status in
- {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof},
- uri::lemmas
- | GrafiteAst.Coercion (loc, uri, add_composites) ->
- eval_coercion status ~add_composites uri
- | GrafiteAst.Obj (loc,obj) ->
- let ext,name =
- match obj with
- Cic.Constant (name,_,_,_,_)
- | Cic.CurrentProof (name,_,_,_,_,_) -> ".con",name
- | Cic.InductiveDefinition (types,_,_,_) ->
- ".ind",
- (match types with (name,_,_,_)::_ -> name | _ -> assert false)
- | _ -> assert false in
- let uri =
- UriManager.uri_of_string (GrafiteTypes.qualify status name ^ ext)
- in
- let metasenv = GrafiteTypes.get_proof_metasenv status in
- match obj with
- | Cic.CurrentProof (_,metasenv',bo,ty,_,_) ->
- let name = UriManager.name_of_uri uri in
- if not(CicPp.check name ty) then
- HLog.error ("Bad name: " ^ name);
- if opts.do_heavy_checks then
- begin
- let dbd = LibraryDb.instance () in
- let similar = Whelp.match_term ~dbd ty in
- let similar_len = List.length similar in
- if similar_len> 30 then
- (HLog.message
- ("Duplicate check will compare your theorem with " ^
- string_of_int similar_len ^
- " theorems, this may take a while."));
- let convertible =
- List.filter (
- fun u ->
- let t = CicUtil.term_of_uri u in
- let ty',g =
- CicTypeChecker.type_of_aux'
- metasenv' [] t CicUniv.empty_ugraph
- in
- fst(CicReduction.are_convertible [] ty' ty g))
- similar
- in
- (match convertible with
- | [] -> ()
- | x::_ ->
- HLog.warn
- ("Theorem already proved: " ^ UriManager.string_of_uri x ^
- "\nPlease use a variant."));
- end;
- assert (metasenv = metasenv');
- let initial_proof = (Some uri, metasenv, bo, ty) in
- let initial_stack = Continuationals.Stack.of_metasenv metasenv in
- { status with GrafiteTypes.proof_status =
- GrafiteTypes.Incomplete_proof
- { GrafiteTypes.proof = initial_proof; stack = initial_stack } },
- []
- | _ ->
- if metasenv <> [] then
- raise (GrafiteTypes.Command_error (
- "metasenv not empty while giving a definition with body: " ^
- CicMetaSubst.ppmetasenv [] metasenv));
- let status, lemmas = add_obj uri obj status in
- let status,new_lemmas =
- add_coercions_of_record_to_moo obj lemmas status
- in
- {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof},
- uri::new_lemmas@lemmas
- in
- match status.GrafiteTypes.proof_status with
- GrafiteTypes.Intermediate _ ->
- {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof},uris
- | _ -> status,uris
-
-} and eval_executable = {ee_go = fun ~disambiguate_tactic ~disambiguate_command ~disambiguate_macro opts status ex ->
- match ex with
- | GrafiteAst.Tactical (_, tac, None) ->
- eval_tactical ~disambiguate_tactic status tac,[]
- | GrafiteAst.Tactical (_, tac, Some punct) ->
- let status = eval_tactical ~disambiguate_tactic status tac in
- eval_tactical ~disambiguate_tactic status punct,[]
- | GrafiteAst.Command (_, cmd) ->
- eval_command.ec_go ~disambiguate_command opts status cmd
- | GrafiteAst.Macro (loc, macro) ->
- raise (Macro (loc,disambiguate_macro status macro))
-
-} and eval_from_moo = {efm_go = fun status fname ->
- let ast_of_cmd cmd =
- GrafiteAst.Executable (HExtlib.dummy_floc,
- GrafiteAst.Command (HExtlib.dummy_floc,
- cmd))
- in
- let moo = GrafiteMarshal.load_moo fname in
- List.fold_left
- (fun status ast ->
- let ast = ast_of_cmd ast in
- let status,lemmas =
- eval_ast.ea_go
- ~disambiguate_tactic:(fun status _ tactic -> status,tactic)
- ~disambiguate_command:(fun status cmd -> status,cmd)
- ~disambiguate_macro:(fun _ _ -> assert false)
- status ast
- in
- assert (lemmas=[]);
- status)
- status moo
-} and eval_ast = {ea_go = fun ~disambiguate_tactic ~disambiguate_command ~disambiguate_macro ?(do_heavy_checks=false) ?(clean_baseuri=true) status st
-->
- let opts = {
- do_heavy_checks = do_heavy_checks ;
- clean_baseuri = clean_baseuri }
- in
- match st with
- | GrafiteAst.Executable (_,ex) ->
- eval_executable.ee_go ~disambiguate_tactic ~disambiguate_command
- ~disambiguate_macro opts status ex
- | GrafiteAst.Comment (_,c) -> eval_comment status c,[]
-}
-
-let eval_ast = eval_ast.ea_go
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 ^ "/"))
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 = [];
- }
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
+++ /dev/null
-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
+++ /dev/null
-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
- @echo " OCAMLC $<"
- @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
-print_grammar: print_grammar.ml $(PACKAGE).cma
- @echo " OCAMLC $<"
- @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
-test_dep: test_dep.ml $(PACKAGE).cma
- @echo " OCAMLC $<"
- @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-exception BaseUriNotSetYet
-
-let singleton = function
- | [x], _ -> x
- | _ -> assert false
-
- (** @param term not meaningful when context is given *)
-let disambiguate_term lexicon_status_ref context metasenv term =
- let lexicon_status = !lexicon_status_ref in
- let (diff, metasenv, cic, _) =
- singleton
- (GrafiteDisambiguator.disambiguate_term ~dbd:(LibraryDb.instance ())
- ~aliases:lexicon_status.LexiconEngine.aliases
- ~universe:(Some lexicon_status.LexiconEngine.multi_aliases)
- ~context ~metasenv term)
- in
- let lexicon_status = LexiconEngine.set_proof_aliases lexicon_status diff in
- lexicon_status_ref := lexicon_status;
- metasenv,cic
-
- (** disambiguate_lazy_term (circa): term -> (unit -> status) * lazy_term
- * rationale: lazy_term will be invoked in different context to obtain a term,
- * each invocation will disambiguate the term and can add aliases. Once all
- * disambiguations have been performed, the first returned function can be
- * used to obtain the resulting aliases *)
-let disambiguate_lazy_term lexicon_status_ref term =
- (fun context metasenv ugraph ->
- let lexicon_status = !lexicon_status_ref in
- let (diff, metasenv, cic, ugraph) =
- singleton
- (GrafiteDisambiguator.disambiguate_term ~dbd:(LibraryDb.instance ())
- ~initial_ugraph:ugraph ~aliases:lexicon_status.LexiconEngine.aliases
- ~universe:(Some lexicon_status.LexiconEngine.multi_aliases)
- ~context ~metasenv
- term) in
- let lexicon_status = LexiconEngine.set_proof_aliases lexicon_status diff in
- lexicon_status_ref := lexicon_status;
- cic, metasenv, ugraph)
-
-let disambiguate_pattern lexicon_status_ref (wanted, hyp_paths, goal_path) =
- let interp path = Disambiguate.interpretate_path [] path in
- let goal_path = HExtlib.map_option interp goal_path in
- let hyp_paths = List.map (fun (name, path) -> name, interp path) hyp_paths in
- let wanted =
- match wanted with
- None -> None
- | Some wanted ->
- let wanted = disambiguate_lazy_term lexicon_status_ref wanted in
- Some wanted
- in
- (wanted, hyp_paths, goal_path)
-
-let disambiguate_reduction_kind lexicon_status_ref = function
- | `Unfold (Some t) ->
- let t = disambiguate_lazy_term lexicon_status_ref t in
- `Unfold (Some t)
- | `Demodulate
- | `Normalize
- | `Reduce
- | `Simpl
- | `Unfold None
- | `Whd as kind -> kind
-
-let disambiguate_tactic lexicon_status_ref context metasenv tactic =
- let disambiguate_term = disambiguate_term lexicon_status_ref in
- let disambiguate_pattern = disambiguate_pattern lexicon_status_ref in
- let disambiguate_reduction_kind = disambiguate_reduction_kind lexicon_status_ref in
- let disambiguate_lazy_term = disambiguate_lazy_term lexicon_status_ref in
- match tactic with
- | GrafiteAst.Absurd (loc, term) ->
- let metasenv,cic = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.Absurd (loc, cic)
- | GrafiteAst.Apply (loc, term) ->
- let metasenv,cic = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.Apply (loc, cic)
- | GrafiteAst.Assumption loc ->
- metasenv,GrafiteAst.Assumption loc
- | GrafiteAst.Auto (loc,depth,width,paramodulation,full) ->
- metasenv,GrafiteAst.Auto (loc,depth,width,paramodulation,full)
- | GrafiteAst.Change (loc, pattern, with_what) ->
- let with_what = disambiguate_lazy_term with_what in
- let pattern = disambiguate_pattern pattern in
- metasenv,GrafiteAst.Change (loc, pattern, with_what)
- | GrafiteAst.Clear (loc,id) ->
- metasenv,GrafiteAst.Clear (loc,id)
- | GrafiteAst.ClearBody (loc,id) ->
- metasenv,GrafiteAst.ClearBody (loc,id)
- | GrafiteAst.Compare (loc,term) ->
- let metasenv,term = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.Compare (loc,term)
- | GrafiteAst.Constructor (loc,n) ->
- metasenv,GrafiteAst.Constructor (loc,n)
- | GrafiteAst.Contradiction loc ->
- metasenv,GrafiteAst.Contradiction loc
- | GrafiteAst.Cut (loc, ident, term) ->
- let metasenv,cic = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.Cut (loc, ident, cic)
- | GrafiteAst.DecideEquality loc ->
- metasenv,GrafiteAst.DecideEquality loc
- | GrafiteAst.Decompose (loc, types, what, names) ->
- let disambiguate (metasenv,types) = function
- | GrafiteAst.Type _ -> assert false
- | GrafiteAst.Ident id ->
- (match
- disambiguate_term context metasenv
- (CicNotationPt.Ident(id, None))
- with
- | metasenv,Cic.MutInd (uri, tyno, _) ->
- metasenv,(GrafiteAst.Type (uri, tyno) :: types)
- | _ ->
- raise (GrafiteDisambiguator.DisambiguationError
- (0,[[None,lazy "Decompose works only on inductive types"]])))
- in
- let metasenv,types =
- List.fold_left disambiguate (metasenv,[]) types
- in
- metasenv,GrafiteAst.Decompose (loc, types, what, names)
- | GrafiteAst.Discriminate (loc,term) ->
- let metasenv,term = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.Discriminate(loc,term)
- | GrafiteAst.Exact (loc, term) ->
- let metasenv,cic = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.Exact (loc, cic)
- | GrafiteAst.Elim (loc, what, Some using, depth, idents) ->
- let metasenv,what = disambiguate_term context metasenv what in
- let metasenv,using = disambiguate_term context metasenv using in
- metasenv,GrafiteAst.Elim (loc, what, Some using, depth, idents)
- | GrafiteAst.Elim (loc, what, None, depth, idents) ->
- let metasenv,what = disambiguate_term context metasenv what in
- metasenv,GrafiteAst.Elim (loc, what, None, depth, idents)
- | GrafiteAst.ElimType (loc, what, Some using, depth, idents) ->
- let metasenv,what = disambiguate_term context metasenv what in
- let metasenv,using = disambiguate_term context metasenv using in
- metasenv,GrafiteAst.ElimType (loc, what, Some using, depth, idents)
- | GrafiteAst.ElimType (loc, what, None, depth, idents) ->
- let metasenv,what = disambiguate_term context metasenv what in
- metasenv,GrafiteAst.ElimType (loc, what, None, depth, idents)
- | GrafiteAst.Exists loc ->
- metasenv,GrafiteAst.Exists loc
- | GrafiteAst.Fail loc ->
- metasenv,GrafiteAst.Fail loc
- | GrafiteAst.Fold (loc,red_kind, term, pattern) ->
- let pattern = disambiguate_pattern pattern in
- let term = disambiguate_lazy_term term in
- let red_kind = disambiguate_reduction_kind red_kind in
- metasenv,GrafiteAst.Fold (loc, red_kind, term, pattern)
- | GrafiteAst.FwdSimpl (loc, hyp, names) ->
- metasenv,GrafiteAst.FwdSimpl (loc, hyp, names)
- | GrafiteAst.Fourier loc ->
- metasenv,GrafiteAst.Fourier loc
- | GrafiteAst.Generalize (loc,pattern,ident) ->
- let pattern = disambiguate_pattern pattern in
- metasenv,GrafiteAst.Generalize (loc,pattern,ident)
- | GrafiteAst.Goal (loc, g) ->
- metasenv,GrafiteAst.Goal (loc, g)
- | GrafiteAst.IdTac loc ->
- metasenv,GrafiteAst.IdTac loc
- | GrafiteAst.Injection (loc, term) ->
- let metasenv,term = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.Injection (loc,term)
- | GrafiteAst.Intros (loc, num, names) ->
- metasenv,GrafiteAst.Intros (loc, num, names)
- | GrafiteAst.Inversion (loc, term) ->
- let metasenv,term = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.Inversion (loc, term)
- | GrafiteAst.LApply (loc, depth, to_what, what, ident) ->
- let f term to_what =
- let metasenv,term = disambiguate_term context metasenv term in
- term :: to_what
- in
- let to_what = List.fold_right f to_what [] in
- let metasenv,what = disambiguate_term context metasenv what in
- metasenv,GrafiteAst.LApply (loc, depth, to_what, what, ident)
- | GrafiteAst.Left loc ->
- metasenv,GrafiteAst.Left loc
- | GrafiteAst.LetIn (loc, term, name) ->
- let metasenv,term = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.LetIn (loc,term,name)
- | GrafiteAst.Reduce (loc, red_kind, pattern) ->
- let pattern = disambiguate_pattern pattern in
- let red_kind = disambiguate_reduction_kind red_kind in
- metasenv,GrafiteAst.Reduce(loc, red_kind, pattern)
- | GrafiteAst.Reflexivity loc ->
- metasenv,GrafiteAst.Reflexivity loc
- | GrafiteAst.Replace (loc, pattern, with_what) ->
- let pattern = disambiguate_pattern pattern in
- let with_what = disambiguate_lazy_term with_what in
- metasenv,GrafiteAst.Replace (loc, pattern, with_what)
- | GrafiteAst.Rewrite (loc, dir, t, pattern) ->
- let metasenv,term = disambiguate_term context metasenv t in
- let pattern = disambiguate_pattern pattern in
- metasenv,GrafiteAst.Rewrite (loc, dir, term, pattern)
- | GrafiteAst.Right loc ->
- metasenv,GrafiteAst.Right loc
- | GrafiteAst.Ring loc ->
- metasenv,GrafiteAst.Ring loc
- | GrafiteAst.Split loc ->
- metasenv,GrafiteAst.Split loc
- | GrafiteAst.Symmetry loc ->
- metasenv,GrafiteAst.Symmetry loc
- | GrafiteAst.Transitivity (loc, term) ->
- let metasenv,cic = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.Transitivity (loc, cic)
-
-let disambiguate_obj lexicon_status ~baseuri metasenv obj =
- let uri =
- match obj with
- | CicNotationPt.Inductive (_,(name,_,_,_)::_)
- | CicNotationPt.Record (_,name,_,_) ->
- (match baseuri with
- | Some baseuri ->
- Some (UriManager.uri_of_string (baseuri ^ "/" ^ name ^ ".ind"))
- | None -> raise BaseUriNotSetYet)
- | CicNotationPt.Inductive _ -> assert false
- | CicNotationPt.Theorem _ -> None in
- let (diff, metasenv, cic, _) =
- singleton
- (GrafiteDisambiguator.disambiguate_obj ~dbd:(LibraryDb.instance ())
- ~aliases:lexicon_status.LexiconEngine.aliases
- ~universe:(Some lexicon_status.LexiconEngine.multi_aliases) ~uri obj) in
- let lexicon_status = LexiconEngine.set_proof_aliases lexicon_status diff in
- lexicon_status, metasenv, cic
-
-let disambiguate_command lexicon_status ~baseuri metasenv =
- function
- | GrafiteAst.Coercion _
- | GrafiteAst.Default _
- | GrafiteAst.Drop _
- | GrafiteAst.Include _
- | GrafiteAst.Qed _
- | GrafiteAst.Set _ as cmd ->
- lexicon_status,metasenv,cmd
- | GrafiteAst.Obj (loc,obj) ->
- let lexicon_status,metasenv,obj =
- disambiguate_obj lexicon_status ~baseuri metasenv obj in
- lexicon_status, metasenv, GrafiteAst.Obj (loc,obj)
-
-let disambiguate_macro lexicon_status_ref metasenv context macro =
- let disambiguate_term = disambiguate_term lexicon_status_ref in
- match macro with
- | GrafiteAst.WMatch (loc,term) ->
- let metasenv,term = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.WMatch (loc,term)
- | GrafiteAst.WInstance (loc,term) ->
- let metasenv,term = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.WInstance (loc,term)
- | GrafiteAst.WElim (loc,term) ->
- let metasenv,term = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.WElim (loc,term)
- | GrafiteAst.WHint (loc,term) ->
- let metasenv,term = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.WHint (loc,term)
- | GrafiteAst.Check (loc,term) ->
- let metasenv,term = disambiguate_term context metasenv term in
- metasenv,GrafiteAst.Check (loc,term)
- | GrafiteAst.Hint _
- | GrafiteAst.WLocate _ as macro ->
- metasenv,macro
- | GrafiteAst.Quit _
- | GrafiteAst.Print _
- | GrafiteAst.Search_pat _
- | GrafiteAst.Search_term _ -> assert false
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-
-exception Ambiguous_input
-(* the integer is an offset to be added to each location *)
-exception DisambiguationError of
- int * (Token.flocation option * string Lazy.t) list list
- (** parameters are: option name, error message *)
-exception Unbound_identifier of string
-
-type choose_uris_callback =
- id:string -> UriManager.uri list -> UriManager.uri list
-
-type choose_interp_callback = (string * string) list list -> int list
-
-let mono_uris_callback ~id =
- if Helm_registry.get_opt_default Helm_registry.get_bool ~default:true
- "matita.auto_disambiguation"
- then
- function l -> l
- else
- raise Ambiguous_input
-
-let mono_interp_callback _ = raise Ambiguous_input
-
-let _choose_uris_callback = ref mono_uris_callback
-let _choose_interp_callback = ref mono_interp_callback
-let set_choose_uris_callback f = _choose_uris_callback := f
-let set_choose_interp_callback f = _choose_interp_callback := f
-
-module Callbacks =
- struct
- let interactive_user_uri_choice ~selection_mode ?ok
- ?(enable_button_for_non_vars = true) ~title ~msg ~id uris =
- !_choose_uris_callback ~id uris
-
- let interactive_interpretation_choice interp =
- !_choose_interp_callback interp
-
- let input_or_locate_uri ~(title:string) ?id =
- (* Zack: I try to avoid using this callback. I therefore assume that
- * the presence of an identifier that can't be resolved via "locate"
- * query is a syntax error *)
- let msg = match id with Some id -> id | _ -> "_" in
- raise (Unbound_identifier msg)
- end
-
-module Disambiguator = Disambiguate.Make (Callbacks)
-
-(* implement module's API *)
-
-let disambiguate_thing ~aliases ~universe
- ~(f:?fresh_instances:bool ->
- aliases:DisambiguateTypes.environment ->
- universe:DisambiguateTypes.multiple_environment option ->
- 'a -> 'b)
- ~(drop_aliases: 'b -> 'b)
- ~(drop_aliases_and_clear_diff: 'b -> 'b)
- (thing: 'a)
-=
- assert (universe <> None);
- let library = false, DisambiguateTypes.Environment.empty, None in
- let multi_aliases = false, DisambiguateTypes.Environment.empty, universe in
- let mono_aliases = true, aliases, Some DisambiguateTypes.Environment.empty in
- let passes = (* <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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf
-
-module Ast = CicNotationPt
-
-type 'a localized_option =
- LSome of 'a
- | LNone of Token.flocation
-
-type statement =
- include_paths:string list ->
- LexiconEngine.status ->
- LexiconEngine.status *
- (CicNotationPt.term, CicNotationPt.term,
- CicNotationPt.term GrafiteAst.reduction, CicNotationPt.obj, string)
- GrafiteAst.statement localized_option
-
-let grammar = CicNotationParser.level2_ast_grammar
-
-let term = CicNotationParser.term
-let statement = Grammar.Entry.create grammar "statement"
-
-let add_raw_attribute ~text t = Ast.AttributedTerm (`Raw text, t)
-
-let default_precedence = 50
-let default_associativity = Gramext.NonA
-
-EXTEND
- GLOBAL: term statement;
- arg: [
- [ LPAREN; names = LIST1 IDENT SEP SYMBOL ",";
- SYMBOL ":"; ty = term; RPAREN -> names,ty
- | name = IDENT -> [name],Ast.Implicit
- ]
- ];
- constructor: [ [ name = IDENT; SYMBOL ":"; typ = term -> (name, typ) ] ];
- tactic_term: [ [ t = term LEVEL "90N" -> t ] ];
- ident_list0: [ [ LPAREN; idents = LIST0 IDENT; RPAREN -> idents ] ];
- tactic_term_list1: [
- [ tactic_terms = LIST1 tactic_term SEP SYMBOL "," -> tactic_terms ]
- ];
- reduction_kind: [
- [ IDENT "demodulate" -> `Demodulate
- | IDENT "normalize" -> `Normalize
- | IDENT "reduce" -> `Reduce
- | IDENT "simplify" -> `Simpl
- | IDENT "unfold"; t = OPT term -> `Unfold t
- | IDENT "whd" -> `Whd ]
- ];
- sequent_pattern_spec: [
- [ hyp_paths =
- LIST0
- [ id = IDENT ;
- path = OPT [SYMBOL ":" ; path = tactic_term -> path ] ->
- (id,match path with Some p -> p | None -> Ast.UserInput) ];
- goal_path = OPT [ SYMBOL <:unicode<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)))
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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] []
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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)
-
+++ /dev/null
-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
+++ /dev/null
-
-# Targets description:
-# all (default) -> builds hbugs bytecode library hbugs.cma
-# opt -> builds hbugs native library hbugs.cmxa
-# daemons -> builds hbugs broker and tutors executables
-#
-# start -> starts up broker and tutors
-# stop -> stop broker and tutors
-#
-# broker -> builds broker executable
-# tutors -> builds tutors executables
-# client -> builds hbugs client
-
-PACKAGE = hbugs
-
-IMPLEMENTATION_FILES = \
- hbugs_misc.ml \
- hbugs_common.ml \
- hbugs_id_generator.ml \
- hbugs_messages.ml \
- hbugs_client_gui.ml \
- hbugs_client.ml
-INTERFACE_FILES = \
- hbugs_types.mli \
- $(patsubst %.ml, %.mli, $(IMPLEMENTATION_FILES))
-
-include ../../Makefile.defs
-include ../Makefile.common
-include .tutors.ml
-include .generated_tutors.ml
-
-.tutors.ml:
- echo -n "TUTORS_ML = " > $@
- scripts/ls_tutors.ml | xargs >> $@
-.generated_tutors.ml:
- echo -n "GENERATED_TUTORS_ML = " > $@
- scripts/ls_tutors.ml -auto | xargs >> $@
-
-TUTORS = $(patsubst %.ml, %, $(TUTORS_ML))
-TUTORS_OPT = $(patsubst %, %.opt, $(TUTORS))
-GENERATED_TUTORS = $(patsubst %.ml, %, $(GENERATED_TUTORS_ML))
-
-hbugs_client_gui.ml hbugs_client_gui.mli: hbugs_client_gui.glade
- lablgladecc2 $< > hbugs_client_gui.ml
- $(OCAMLC) -i hbugs_client_gui.ml > hbugs_client_gui.mli
-
-clean: clean_mains
-.PHONY: clean_mains
-clean_mains:
- rm -f $(TUTORS) $(TUTORS_OPT) broker{,.opt} client{,.opt}
-distclean: clean
- rm -f $(GENERATED_TUTORS_ML) hbugs_client_gui.ml{,i}
- rm -f .tutors.ml .generated_tutors.ml
-
-MAINS_DEPS = \
- hbugs_misc.cmo \
- hbugs_messages.cmo \
- hbugs_id_generator.cmo
-TUTOR_DEPS = $(MAINS_DEPS) \
- hbugs_tutors.cmo
-BROKER_DEPS = $(MAINS_DEPS) \
- hbugs_broker_registry.cmo
-CLIENT_DEPS = $(MAINS_DEPS) \
- hbugs_client_gui.cmo \
- hbugs_common.cmo \
- hbugs_client.cmo
-TUTOR_DEPS_OPT = $(patsubst %.cmo, %.cmx, $(TUTOR_DEPS))
-BROKER_DEPS_OPT = $(patsubst %.cmo, %.cmx, $(BROKER_DEPS))
-CLIENT_DEPS_OPT = $(patsubst %.cmo, %.cmx, $(CLIENT_DEPS))
-$(GENERATED_TUTORS_ML): scripts/build_tutors.ml data/tutors_index.xml data/hbugs_tutor.TPL.ml
- scripts/build_tutors.ml
-hbugs_tutors.cmo: hbugs_tutors.cmi
-hbugs_broker_registry.cmo: hbugs_broker_registry.cmi
-.PHONY: daemons
-daemons: tutors broker
-.PHONY: tutors
-tutors: all $(TUTORS)
-%_tutor: $(TUTOR_DEPS) %_tutor.ml
- $(OCAMLC) -linkpkg -o $@ $^
-%_tutor.opt: $(TUTOR_DEPS_OPT) %_tutor.ml
- $(OCAMLOPT) -linkpkg -o $@ $^
-broker: $(BROKER_DEPS) broker.ml
- $(OCAMLC) -linkpkg -o $@ $^
-broker.opt: $(BROKER_DEPS_OPT) broker.ml
- $(OCAMLOPT) -linkpkg -o $@ $^
-client: $(CLIENT_DEPS) client.ml
- $(OCAMLC) -linkpkg -o $@ $^
-client.opt: $(CLIENT_DEPS_OPT) client.ml
- $(OCAMLOPT) -linkpkg -o $@ $^
-
-.PHONY: start stop
-start:
- scripts/brokerctl.sh start
- scripts/sabba.sh start
-stop:
- scripts/brokerctl.sh stop
- scripts/sabba.sh stop
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $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 ()
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-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 () ;;
-
+++ /dev/null
-<!--
- 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>
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Hbugs_types;;
-
-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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $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
-;;
-
+++ /dev/null
-
-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
-
+++ /dev/null
-<?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>
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $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)
-;;
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Hbugs_types;;
-
-val string_of_hint: hint -> string
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Hbugs_types;;
-
-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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $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));;
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Hbugs_types;;
-
-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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $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)
-;;
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
- (** 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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open Hbugs_types;;
-
-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
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-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 *)
-
+++ /dev/null
-#!/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
+++ /dev/null
-#!/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 ()
-
+++ /dev/null
-#!/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 ()
-
+++ /dev/null
-#!/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
+++ /dev/null
-(* $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 ()
-
+++ /dev/null
-<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>
+++ /dev/null
-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
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-open 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"
-;;
-
+++ /dev/null
-domMisc.cmo: domMisc.cmi
-domMisc.cmx: domMisc.cmi
-xml2Gdome.cmo: xml2Gdome.cmi
-xml2Gdome.cmx: xml2Gdome.cmi
+++ /dev/null
-PACKAGE = hgdome
-
-# modules which have both a .ml and a .mli
-INTERFACE_FILES = \
- domMisc.mli \
- xml2Gdome.mli \
- $(NULL)
-
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 06/01/2002 *)
-(* *)
-(* *)
-(******************************************************************************)
-
-(* $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"
-
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 15/01/2003 *)
-(* *)
-(* *)
-(******************************************************************************)
-
-val domImpl : Gdome.domImplementation
-
-val 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 *)
-
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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
-;;
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val document_of_xml :
- Gdome.domImplementation -> Xml.token Stream.t -> Gdome.document
+++ /dev/null
-hMysql.cmo: hMysql.cmi
-hMysql.cmx: hMysql.cmi
+++ /dev/null
-PACKAGE = hmysql
-PREDICATES =
-
-INTERFACE_FILES = \
- hMysql.mli
-IMPLEMENTATION_FILES = \
- $(INTERFACE_FILES:%.mli=%.ml)
-EXTRA_OBJECTS_TO_INSTALL =
-EXTRA_OBJECTS_TO_CLEAN =
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-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
+++ /dev/null
-PACKAGE = lexicon
-PREDICATES =
-
-INTERFACE_FILES = \
- lexiconAstPp.mli \
- disambiguatePp.mli \
- lexiconMarshal.mli \
- cicNotation.mli \
- lexiconEngine.mli \
- lexiconSync.mli \
- $(NULL)
-IMPLEMENTATION_FILES = \
- lexiconAst.ml \
- $(INTERFACE_FILES:%.mli=%.ml)
-
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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)
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-exception IncludedFileNotCompiled of string
-
-type status = {
- aliases: DisambiguateTypes.environment; (** disambiguation aliases *)
- multi_aliases: DisambiguateTypes.multiple_environment;
- lexicon_content_rev: LexiconMarshal.lexicon;
- notation_ids: CicNotation.notation_id list; (** in-scope notation ids *)
- metadata: LibraryNoDb.metadata list;
-}
-
-val eval_command : status -> LexiconAst.command -> status
-
-val set_proof_aliases:
- status ->
- (DisambiguateTypes.Environment.key * DisambiguateTypes.codomain_item) list ->
- status
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 = [];
- }
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-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
+++ /dev/null
-PACKAGE = library
-PREDICATES =
-
-INTERFACE_FILES = \
- cicElim.mli \
- cicRecord.mli \
- libraryMisc.mli \
- libraryDb.mli \
- coercDb.mli \
- cicCoercion.mli \
- coercGraph.mli \
- librarySync.mli \
- libraryNoDb.mli \
- libraryClean.mli \
- $(NULL)
-IMPLEMENTATION_FILES = \
- $(INTERFACE_FILES:%.mli=%.ml)
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-;;
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* 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))
-
+++ /dev/null
-(* 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-type coerc_carr = Uri of UriManager.uri | Sort of Cic.sort | Term of Cic.term
-exception EqCarrNotImplemented of string Lazy.t
-exception EqCarrOnNonMetaClosed
-
-let db = ref []
-
-let coerc_carr_of_term t =
- try
- Uri (CicUtil.uri_of_term t)
- with Invalid_argument _ ->
- match t with
- | Cic.Sort s -> Sort s
- | Cic.Appl ((Cic.Const (uri, _))::_)
- | Cic.Appl ((Cic.MutInd (uri, _, _))::_)
- | Cic.Appl ((Cic.MutConstruct (uri, _, _, _))::_) -> Uri uri
- | t -> Term t
-;;
-
-let name_of_carr = function
- | Uri u -> UriManager.name_of_uri u
- | Sort s -> CicPp.ppsort s
- | Term (Cic.Appl ((Cic.Const (uri, _))::_))
- | Term (Cic.Appl ((Cic.MutInd (uri, _, _))::_))
- | Term (Cic.Appl ((Cic.MutConstruct (uri, _, _, _))::_)) ->
- UriManager.name_of_uri uri
- | Term t -> (* CicPp.ppterm t *) assert false
-
-let eq_carr src tgt =
- match src, tgt with
- | Uri src, Uri tgt -> UriManager.eq src tgt
- | Sort (Cic.Type _), Sort (Cic.Type _) -> true
- | Sort src, Sort tgt when src = tgt -> true
- | Term t1, Term t2 ->
- if CicUtil.is_meta_closed t1 && CicUtil.is_meta_closed t2 then
- raise
- (EqCarrNotImplemented
- (lazy ("Unsupported carr for coercions: " ^
- CicPp.ppterm t1 ^ " or " ^ CicPp.ppterm t2)))
- else raise EqCarrOnNonMetaClosed
- | _, _ -> false
-
-let to_list () =
- !db
-
-let add_coercion c =
- db := c :: !db
-
-let remove_coercion p =
- db := List.filter (fun u -> not(p u)) !db
-
-let find_coercion f =
- List.map (fun (_,_,x) -> x) (List.filter (fun (s,t,_) -> f (s,t)) !db)
-
-let is_a_coercion u =
- List.exists (fun (_,_,x) -> UriManager.eq x u) !db
-
-let get_carr uri =
- try
- let src, tgt, _ = List.find (fun (_,_,x) -> UriManager.eq x uri) !db in
- src, tgt
- with Not_found -> assert false (* uri must be a coercion *)
-
-let term_of_carr = function
- | Uri u -> CicUtil.term_of_uri u
- | Sort s -> Cic.Sort s
- | Term _ -> assert false
-
-
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-
- (** 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
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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 *)
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-open Printf ;;
-
-let instance =
- let dbd = lazy (
- HMysql.quick_connect
- ~host:(Helm_registry.get "db.host")
- ~user:(Helm_registry.get "db.user")
- ~database:(Helm_registry.get "db.database")
- ())
- in
- fun () -> Lazy.force dbd
-
-
-let xpointer_RE = Pcre.regexp "#.*$"
-let file_scheme_RE = Pcre.regexp "^file://"
-
-let clean_owner_environment () =
- let dbd = instance () in
- let obj_tbl = MetadataTypes.obj_tbl () in
- let sort_tbl = MetadataTypes.sort_tbl () in
- let rel_tbl = MetadataTypes.rel_tbl () in
- let name_tbl = MetadataTypes.name_tbl () in
- let count_tbl = MetadataTypes.count_tbl () in
- let tbls = [
- (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ;
- (name_tbl,`ObjectName) ; (count_tbl,`Count) ]
- in
- let statements =
- (SqlStatements.drop_tables tbls) @ (SqlStatements.drop_indexes tbls)
- in
- let owned_uris =
- try
- MetadataDb.clean ~dbd
- with Mysql.Error _ as exn ->
- match HMysql.errno dbd with
- | Mysql.No_such_table -> []
- | _ -> raise exn
- in
- List.iter
- (fun uri ->
- let uri = Pcre.replace ~rex:xpointer_RE ~templ:"" uri in
- List.iter
- (fun suffix ->
- try
- HExtlib.safe_remove (Http_getter.resolve (uri ^ suffix))
- with Http_getter_types.Key_not_found _ -> ())
- [""; ".body"; ".types"])
- owned_uris;
- List.iter (fun statement ->
- try
- ignore (HMysql.exec dbd statement)
- with Mysql.Error _ as exn ->
- match HMysql.errno dbd with
- | Mysql.Bad_table_error
- | Mysql.No_such_index | Mysql.No_such_table -> ()
- | _ -> raise exn
- ) statements;
-;;
-
-let create_owner_environment () =
- let dbd = instance () in
- let obj_tbl = MetadataTypes.obj_tbl () in
- let sort_tbl = MetadataTypes.sort_tbl () in
- let rel_tbl = MetadataTypes.rel_tbl () in
- let name_tbl = MetadataTypes.name_tbl () in
- let count_tbl = MetadataTypes.count_tbl () in
- let tbls = [
- (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ;
- (name_tbl,`ObjectName) ; (count_tbl,`Count) ]
- in
- let statements =
- (SqlStatements.create_tables tbls) @ (SqlStatements.create_indexes tbls)
- in
- List.iter (fun statement ->
- try
- ignore (HMysql.exec dbd statement)
- with
- exn ->
- let status = HMysql.status dbd in
- match status with
- | Mysql.StatusError Mysql.Table_exists_error -> ()
- | Mysql.StatusError Mysql.Dup_keyname -> ()
- | Mysql.StatusError _ -> raise exn
- | _ -> ()
- ) statements
-;;
-
-(* removes uri from the ownerized tables, and returns the list of other objects
- * (theyr uris) that ref the one removed.
- * AFAIK there is no need to return it, since the MatitaTypes.staus should
- * contain all defined objects. but to double check we do not garbage the
- * metadata...
- *)
-let remove_uri uri =
- let obj_tbl = MetadataTypes.obj_tbl () in
- let sort_tbl = MetadataTypes.sort_tbl () in
- let rel_tbl = MetadataTypes.rel_tbl () in
- let name_tbl = MetadataTypes.name_tbl () in
- (*let conclno_tbl = MetadataTypes.conclno_tbl () in
- let conclno_hyp_tbl = MetadataTypes.fullno_tbl () in*)
- let count_tbl = MetadataTypes.count_tbl () in
-
- let dbd = instance () in
- let suri = UriManager.string_of_uri uri in
- let query table suri = sprintf
- "DELETE FROM %s WHERE source LIKE '%s%%'" table (HMysql.escape suri)
- in
- List.iter (fun t ->
- try
- ignore (HMysql.exec dbd (query t suri))
- with
- exn -> raise exn (* no errors should be accepted *)
- )
- [obj_tbl;sort_tbl;rel_tbl;name_tbl;(*conclno_tbl;conclno_hyp_tbl*)count_tbl];
- (* and now the debug job *)
- let dbg_q =
- sprintf "SELECT source FROM %s WHERE h_occurrence LIKE '%s%%'" obj_tbl
- (HMysql.escape suri)
- in
- try
- let rc = HMysql.exec dbd dbg_q in
- let l = ref [] in
- HMysql.iter rc (fun a -> match a.(0) with None ->()|Some a -> l := a:: !l);
- let l = List.sort Pervasives.compare !l in
- HExtlib.list_uniq l
- with
- exn -> raise exn (* no errors should be accepted *)
-
-let xpointers_of_ind uri =
- let dbd = instance () in
- let name_tbl = MetadataTypes.name_tbl () in
- let query = sprintf
- "SELECT source FROM %s WHERE source LIKE '%s#xpointer%%'" name_tbl
- (HMysql.escape (UriManager.string_of_uri uri))
- in
- let rc = HMysql.exec dbd query in
- let l = ref [] in
- HMysql.iter rc (fun a -> match a.(0) with None ->()|Some a -> l := a:: !l);
- List.map UriManager.uri_of_string !l
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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"
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-exception AlreadyDefined of UriManager.uri
-
-let auxiliary_lemmas_hashtbl = UriManager.UriHashtbl.create 29
-
-(* uri |--> (derived_coercions_in_the_coercion_DB, derived_coercions_in_lib)
- *
- * in case of remove_coercion uri, the first component is removed from the
- * coercion DB, while the second is passed to remove_obj (and is not [] only if
- * add_coercion is called with add_composites
- * *)
-let coercion_hashtbl = UriManager.UriHashtbl.create 3
-
-let rec merge_coercions =
- let module C = Cic in
- let aux = (fun (u,t) -> u,merge_coercions t) in
- function
- C.Rel _ | C.Sort _ | C.Implicit _ as t -> t
- | C.Meta (n,subst) ->
- let subst' =
- List.map
- (function None -> None | Some t -> Some (merge_coercions t)) subst
- in
- C.Meta (n,subst')
- | C.Cast (te,ty) -> C.Cast (merge_coercions te, merge_coercions ty)
- | C.Prod (name,so,dest) ->
- C.Prod (name, merge_coercions so, merge_coercions dest)
- | C.Lambda (name,so,dest) ->
- C.Lambda (name, merge_coercions so, merge_coercions dest)
- | C.LetIn (name,so,dest) ->
- C.LetIn (name, merge_coercions so, merge_coercions dest)
- | Cic.Appl [ c1 ; (Cic.Appl [c2; head]) ] when
- CoercGraph.is_a_coercion c1 && CoercGraph.is_a_coercion c2 ->
- let source_carr = CoercGraph.source_of c2 in
- let tgt_carr = CoercGraph.target_of c1 in
- (match CoercGraph.look_for_coercion source_carr tgt_carr
- with
- | CoercGraph.SomeCoercion c -> Cic.Appl [ c ; head ]
- | _ -> assert false) (* the composite coercion must exist *)
- | C.Appl l -> C.Appl (List.map merge_coercions l)
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst = List.map aux exp_named_subst in
- C.Var (uri, exp_named_subst)
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst = List.map aux exp_named_subst in
- C.Const (uri, exp_named_subst)
- | C.MutInd (uri,tyno,exp_named_subst) ->
- let exp_named_subst = List.map aux exp_named_subst in
- C.MutInd (uri,tyno,exp_named_subst)
- | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
- let exp_named_subst = List.map aux exp_named_subst in
- C.MutConstruct (uri,tyno,consno,exp_named_subst)
- | C.MutCase (uri,tyno,out,te,pl) ->
- let pl = List.map merge_coercions pl in
- C.MutCase (uri,tyno,merge_coercions out,merge_coercions te,pl)
- | C.Fix (fno, fl) ->
- let fl = List.map (fun (name,idx,ty,bo)->(name,idx,merge_coercions ty,merge_coercions bo)) fl in
- C.Fix (fno, fl)
- | C.CoFix (fno, fl) ->
- let fl = List.map (fun (name,ty,bo) -> (name, merge_coercions ty, merge_coercions bo)) fl in
- C.CoFix (fno, fl)
-
-let merge_coercions_in_obj obj =
- let module C = Cic in
- match obj with
- | C.Constant (id, body, ty, params, attrs) ->
- let body =
- match body with
- | None -> None
- | Some body -> Some (merge_coercions body)
- in
- let ty = merge_coercions ty in
- C.Constant (id, body, ty, params, attrs)
- | C.Variable (name, body, ty, params, attrs) ->
- let body =
- match body with
- | None -> None
- | Some body -> Some (merge_coercions body)
- in
- let ty = merge_coercions ty in
- C.Variable (name, body, ty, params, attrs)
- | C.CurrentProof (_name, _conjectures, _body, _ty, _params, _attrs) ->
- assert false
- | C.InductiveDefinition (indtys, params, leftno, attrs) ->
- let indtys =
- List.map
- (fun (name, ind, arity, cl) ->
- let arity = merge_coercions arity in
- let cl = List.map (fun (name, ty) -> (name,merge_coercions ty)) cl in
- (name, ind, arity, cl))
- indtys
- in
- C.InductiveDefinition (indtys, params, leftno, attrs)
-
-let uris_of_obj uri =
- let innertypesuri = UriManager.innertypesuri_of_uri uri in
- let bodyuri = UriManager.bodyuri_of_uri uri in
- let univgraphuri = UriManager.univgraphuri_of_uri uri in
- innertypesuri,bodyuri,univgraphuri
-
-let paths_and_uris_of_obj uri ~basedir =
- let basedir = basedir ^ "/xml" in
- let innertypesuri, bodyuri, univgraphuri = uris_of_obj uri in
- let innertypesfilename = Str.replace_first (Str.regexp "^cic:") ""
- (UriManager.string_of_uri innertypesuri) ^ ".xml.gz" in
- let innertypespath = basedir ^ "/" ^ innertypesfilename in
- let xmlfilename = Str.replace_first (Str.regexp "^cic:/") ""
- (UriManager.string_of_uri uri) ^ ".xml.gz" in
- let xmlpath = basedir ^ "/" ^ xmlfilename in
- let xmlbodyfilename = Str.replace_first (Str.regexp "^cic:/") ""
- (UriManager.string_of_uri uri) ^ ".body.xml.gz" in
- let xmlbodypath = basedir ^ "/" ^ xmlbodyfilename in
- let xmlunivgraphfilename = Str.replace_first (Str.regexp "^cic:/") ""
- (UriManager.string_of_uri univgraphuri) ^ ".xml.gz" in
- let xmlunivgraphpath = basedir ^ "/" ^ xmlunivgraphfilename in
- xmlpath, xmlbodypath, innertypespath, bodyuri, innertypesuri,
- xmlunivgraphpath, univgraphuri
-
-let save_object_to_disk ~basedir uri obj ugraph univlist =
- let ensure_path_exists path =
- let dir = Filename.dirname path in
- HExtlib.mkdir dir
- in
- (* generate annobj, ids_to_inner_sorts and ids_to_inner_types *)
- let annobj = Cic2acic.plain_acic_object_of_cic_object obj in
- (* prepare XML *)
- let xml, bodyxml =
- Cic2Xml.print_object
- uri ?ids_to_inner_sorts:None ~ask_dtd_to_the_getter:false annobj
- in
- let xmlpath, xmlbodypath, innertypespath, bodyuri, innertypesuri,
- xmlunivgraphpath, univgraphuri =
- paths_and_uris_of_obj uri basedir
- in
- List.iter HExtlib.mkdir (List.map Filename.dirname [xmlpath]);
- (* now write to disk *)
- ensure_path_exists xmlpath;
- Xml.pp ~gzip:true xml (Some xmlpath);
- CicUniv.write_xml_of_ugraph xmlunivgraphpath ugraph univlist;
- (* we return a list of uri,path we registered/created *)
- (uri,xmlpath) ::
- (univgraphuri,xmlunivgraphpath) ::
- (* now the optional body, both write and register *)
- (match bodyxml,bodyuri with
- None,None -> []
- | Some bodyxml,Some bodyuri->
- ensure_path_exists xmlbodypath;
- Xml.pp ~gzip:true bodyxml (Some xmlbodypath);
- [bodyuri, xmlbodypath]
- | _-> assert false)
-
-
-let typecheck_obj =
- let profiler = HExtlib.profile "add_obj.typecheck_obj" in
- fun uri obj -> profiler.HExtlib.profile (CicTypeChecker.typecheck_obj uri) obj
-
-let index_obj =
- let profiler = HExtlib.profile "add_obj.index_obj" in
- fun ~dbd ~uri ->
- profiler.HExtlib.profile (fun uri -> MetadataDb.index_obj ~dbd ~uri) uri
-
-let add_single_obj uri obj ~basedir =
- let obj =
- if (*List.mem `Generated (CicUtil.attributes_of_obj obj) &&*)
- not (CoercGraph.is_a_coercion (Cic.Const (uri, [])))
- then
- merge_coercions_in_obj obj
- else
- obj
- in
- let dbd = LibraryDb.instance () in
- if CicEnvironment.in_library uri then
- raise (AlreadyDefined uri)
- else begin
- (*CicUniv.reset_spent_time ();
- let before = Unix.gettimeofday () in*)
- typecheck_obj uri obj; (* 1 *)
- (*let after = Unix.gettimeofday () in
- let univ_time = CicUniv.get_spent_time () in
- let total_time = after -. before in
- prerr_endline
- (Printf.sprintf "QED: %%univ = %2.5f, total = %2.5f, univ = %2.5f, %s\n"
- (univ_time *. 100. /. total_time) (total_time) (univ_time)
- (UriManager.name_of_uri uri));*)
- let _, ugraph, univlist =
- CicEnvironment.get_cooked_obj_with_univlist CicUniv.empty_ugraph uri in
- try
- index_obj ~dbd ~uri; (* 2 must be in the env *)
- try
- (*3*)
- let new_stuff = save_object_to_disk ~basedir uri obj ugraph univlist in
- try
- HLog.message
- (Printf.sprintf "%s defined" (UriManager.string_of_uri uri))
- with exc ->
- List.iter HExtlib.safe_remove (List.map snd new_stuff); (* -3 *)
- raise exc
- with exc ->
- ignore(LibraryDb.remove_uri uri); (* -2 *)
- raise exc
- with exc ->
- CicEnvironment.remove_obj uri; (* -1 *)
- raise exc
- end
-
-let remove_single_obj uri =
- let derived_uris_of_uri uri =
- let innertypesuri, bodyuri, univgraphuri = uris_of_obj uri in
- innertypesuri::univgraphuri::(match bodyuri with None -> [] | Some u -> [u])
- in
- let to_remove =
- uri ::
- (if UriManager.uri_is_ind uri then LibraryDb.xpointers_of_ind uri else []) @
- derived_uris_of_uri uri
- in
- List.iter
- (fun uri ->
- (try
- let file = Http_getter.resolve' uri in
- HExtlib.safe_remove file;
- HExtlib.rmdir_descend (Filename.dirname file)
- with Http_getter_types.Key_not_found _ -> ());
- ignore (LibraryDb.remove_uri uri);
- (*CoercGraph.remove_coercion uri;*)
- CicEnvironment.remove_obj uri)
- to_remove
-
-(*** GENERATION OF AUXILIARY LEMMAS ***)
-
-let generate_elimination_principles ~basedir uri =
- let uris = ref [] in
- let elim sort =
- try
- let uri,obj = CicElim.elim_of ~sort uri 0 in
- add_single_obj uri obj ~basedir;
- uris := uri :: !uris
- with CicElim.Can_t_eliminate -> ()
- in
- try
- List.iter elim [ Cic.Prop; Cic.Set; (Cic.Type (CicUniv.fresh ())) ];
- !uris
- with exn ->
- List.iter remove_single_obj !uris;
- raise exn
-
-(* COERCIONS ***********************************************************)
-
-let remove_all_coercions () =
- UriManager.UriHashtbl.clear coercion_hashtbl;
- CoercDb.remove_coercion (fun (_,_,u1) -> true)
-
-let add_coercion ~basedir ~add_composites uri =
- let coer_ty,_ =
- let coer = CicUtil.term_of_uri uri in
- CicTypeChecker.type_of_aux' [] [] coer CicUniv.empty_ugraph
- in
- (* we have to get the source and the tgt type uri
- * in Coq syntax we have already their names, but
- * since we don't support Funclass and similar I think
- * all the coercion should be of the form
- * (A:?)(B:?)T1->T2
- * So we should be able to extract them from the coercion type
- *
- * Currently only (_:T1)T2 is supported.
- * should we saturate it with metas in case we insert it?
- *
- *)
- let extract_last_two_p ty =
- let rec aux = function
- | Cic.Prod( _, src, Cic.Prod (n,t1,t2)) ->
- assert false
- (* not implemented: aux (Cic.Prod(n,t1,t2)) *)
- | Cic.Prod( _, src, tgt) -> src, tgt
- | _ -> assert false
- in
- aux ty
- in
- let ty_src, ty_tgt = extract_last_two_p coer_ty in
- let src_uri = CoercDb.coerc_carr_of_term (CicReduction.whd [] ty_src) in
- let tgt_uri = CoercDb.coerc_carr_of_term (CicReduction.whd [] ty_tgt) in
- let new_coercions = CicCoercion.close_coercion_graph src_uri tgt_uri uri in
- let composite_uris = List.map (fun (_,_,uri,_) -> uri) new_coercions in
- (* update the DB *)
- List.iter
- (fun (src,tgt,uri,_) -> CoercDb.add_coercion (src,tgt,uri))
- new_coercions;
- CoercDb.add_coercion (src_uri, tgt_uri, uri);
- (* add the composites obj and they eventual lemmas *)
- let lemmas =
- if add_composites then
- List.fold_left
- (fun acc (_,_,uri,obj) ->
- add_single_obj ~basedir uri obj;
- uri::acc)
- composite_uris new_coercions
- else
- []
- in
- (* store that composite_uris are related to uri. the first component is the
- * stuff in the DB while the second is stuff for remove_obj *)
- prerr_endline ("aggiungo: " ^ string_of_bool add_composites ^ UriManager.string_of_uri uri);
- List.iter (fun u -> prerr_endline (UriManager.string_of_uri u))
- composite_uris;
- UriManager.UriHashtbl.add coercion_hashtbl uri
- (composite_uris,if add_composites then composite_uris else []);
- lemmas
-
-let remove_coercion uri =
- try
- let (composites_in_db, composites_in_lib) =
- UriManager.UriHashtbl.find coercion_hashtbl uri
- in
- prerr_endline ("removing: " ^UriManager.string_of_uri uri);
- List.iter (fun u -> prerr_endline (UriManager.string_of_uri u))
- composites_in_db;
- UriManager.UriHashtbl.remove coercion_hashtbl uri;
- CoercDb.remove_coercion (fun (_,_,u) -> UriManager.eq uri u);
- (* remove from the DB *)
- List.iter
- (fun u -> CoercDb.remove_coercion (fun (_,_,u1) -> UriManager.eq u u1))
- composites_in_db;
- (* remove composites from the lib *)
- List.iter remove_single_obj composites_in_lib
- with
- Not_found -> () (* mhh..... *)
-
-
-let generate_projections ~basedir uri fields =
- let uris = ref [] in
- let projections = CicRecord.projections_of uri (List.map fst fields) in
- try
- List.iter2
- (fun (uri, name, bo) (_name, coercion) ->
- try
- let ty, ugraph =
- CicTypeChecker.type_of_aux' [] [] bo CicUniv.empty_ugraph in
- let attrs = [`Class `Projection; `Generated] in
- let obj = Cic.Constant (name,Some bo,ty,[],attrs) in
- add_single_obj ~basedir uri obj;
- let composites =
- if coercion then
- add_coercion ~basedir ~add_composites:true uri
- else
- []
- in
- uris := uri :: composites @ !uris
- with
- CicTypeChecker.TypeCheckerFailure s ->
- HLog.message
- ("Unable to create projection " ^ name ^ " cause: " ^ Lazy.force s);
- | CicEnvironment.Object_not_found uri ->
- let depend = UriManager.name_of_uri uri in
- HLog.message
- ("Unable to create projection " ^ name ^ " because it requires " ^
- depend)
- ) projections fields;
- !uris
- with exn ->
- List.iter remove_single_obj !uris;
- raise exn
-
-
-let add_obj uri obj ~basedir =
- add_single_obj uri obj ~basedir;
- let uris = ref [] in
- try
- begin
- match obj with
- | Cic.Constant _ -> ()
- | Cic.InductiveDefinition (_,_,_,attrs) ->
- uris := !uris @ generate_elimination_principles ~basedir uri;
- let rec get_record_attrs =
- function
- | [] -> None
- | (`Class (`Record fields))::_ -> Some fields
- | _::tl -> get_record_attrs tl
- in
- (match get_record_attrs attrs with
- | None -> () (* not a record *)
- | Some fields ->
- uris := !uris @ (generate_projections ~basedir uri fields))
- | Cic.CurrentProof _
- | Cic.Variable _ -> assert false
- end;
- UriManager.UriHashtbl.add auxiliary_lemmas_hashtbl uri !uris;
- !uris
- with exn ->
- List.iter remove_single_obj !uris;
- raise exn
-
-let remove_obj uri =
- let uris =
- try
- let res = UriManager.UriHashtbl.find auxiliary_lemmas_hashtbl uri in
- UriManager.UriHashtbl.remove auxiliary_lemmas_hashtbl uri;
- res
- with
- Not_found -> [] (*assert false*)
- in
- List.iter remove_single_obj (uri::uris)
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-exception AlreadyDefined of UriManager.uri
-
-val merge_coercions: Cic.term -> Cic.term
-
-(* adds an object to the library together with all auxiliary lemmas on it *)
-(* (e.g. elimination principles, projections, etc.) *)
-(* it returns the list of the uris of the auxiliary lemmas generated *)
-val add_obj: UriManager.uri -> Cic.obj -> basedir:string -> UriManager.uri list
-
-(* inverse of add_obj; *)
-(* Warning: it does not remove the dependencies on the object and on its *)
-(* auxiliary lemmas! *)
-val remove_obj: UriManager.uri -> unit
-
-(* Informs the library that [uri] is a coercion. *)
-(* This can generate some composite coercions that, if [add_composites] *)
-(* is true are added to the library. *)
-(* The list of added objects is returned. *)
-val add_coercion:
- basedir:string -> add_composites:bool -> UriManager.uri ->
- UriManager.uri list
-
-(* inverse of add_coercion, removes both the eventually created composite *)
-(* coercions and the information that [uri] and the composites are coercion *)
-val remove_coercion: UriManager.uri -> unit
-
-(* mh... *)
-val remove_all_coercions: unit -> unit
-
+++ /dev/null
-(* 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/
- *)
-
+++ /dev/null
-helmLogger.cmo: helmLogger.cmi
-helmLogger.cmx: helmLogger.cmi
+++ /dev/null
-
-PACKAGE = logger
-INTERFACE_FILES = \
- helmLogger.mli
-IMPLEMENTATION_FILES = \
- $(INTERFACE_FILES:%.mli=%.ml)
-
-include ../../Makefile.defs
-include ../Makefile.common
-
+++ /dev/null
-(* $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
-
+++ /dev/null
-
-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
-
+++ /dev/null
-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
+++ /dev/null
-PACKAGE = metadata
-PREDICATES =
-
-INTERFACE_FILES = \
- sqlStatements.mli \
- metadataTypes.mli \
- metadataExtractor.mli \
- metadataPp.mli \
- metadataConstraints.mli \
- metadataDb.mli
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-EXTRA_OBJECTS_TO_INSTALL =
-EXTRA_OBJECTS_TO_CLEAN =
-
-include ../../Makefile.defs
-include ../Makefile.common
-
-all: all_table_creator all_extractor
-opt: opt_table_creator opt_extractor
-
-all_table_creator:
- @make -C table_creator/ all
-opt_table_creator:
- @make -C table_creator/ opt
-
-all_extractor:
- @make -C extractor/ all
-opt_extractor:
- @make -C extractor/ opt
-
-clean: clean_table_creator clean_extractor
-
-clean_table_creator:
- @echo " cleaning: table_creator"
- @make -C table_creator/ clean
-
-clean_extractor:
- @echo " cleaning: extractor"
- @make -C extractor/ clean
-
+++ /dev/null
-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
+++ /dev/null
-
-all: extractor extractor_manager
- @echo -n
-opt: extractor.opt extractor_manager.opt
- @echo -n
-
-clean:
- rm -f *.cm[ixo] *.[ao] extractor extractor.opt *.err *.out extractor_manager extractor_manager.opt
-
-extractor: extractor.ml
- @echo " OCAMLC $<"
- @$(OCAMLFIND) ocamlc \
- -thread -package mysql,helm-metadata -linkpkg -o $@ $<
-
-extractor.opt: extractor.ml
- @echo " OCAMLOPT $<"
- @$(OCAMLFIND) ocamlopt \
- -thread -package mysql,helm-metadata -linkpkg -o $@ $<
-
-extractor_manager: extractor_manager.ml
- @echo " OCAMLC $<"
- @$(OCAMLFIND) ocamlc \
- -thread -package mysql,helm-metadata -linkpkg -o $@ $<
-
-extractor_manager.opt: extractor_manager.ml
- @echo " OCAMLOPT $<"
- @$(OCAMLFIND) ocamlopt \
- -thread -package mysql,helm-metadata -linkpkg -o $@ $<
-
-export: extractor.opt extractor_manager.opt
- nice -n 20 \
- time \
- ./extractor_manager.opt 1>export.out 2>export.err
-
-include .depend
-include ../../../Makefile.defs
+++ /dev/null
-<?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>
+++ /dev/null
-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 ()
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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 ()
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
+++ /dev/null
-(* 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)
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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))
-*)
-
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 ]
-
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-sql.cmo: sql.cmi
-sql.cmx: sql.cmi
-table_creator.cmo: sql.cmi
-table_creator.cmx: sql.cmx
+++ /dev/null
-REQUIRES = mysql helm-metadata
-
-INTERFACE_FILES =
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-EXTRA_OBJECTS_TO_INSTALL =
-EXTRA_OBJECTS_TO_CLEAN = \
- table_creator table_creator.opt table_destructor table_destructor.opt
-
-all: table_creator table_destructor
- @echo -n
-opt: table_creator.opt table_destructor.opt
- @echo -n
-
-table_creator: table_creator.ml ../metadata.cma
- @echo " OCAMLC $<"
- @$(OCAMLFIND) ocamlc \
- -thread -package mysql,helm-metadata -linkpkg -o $@ $<
-
-table_destructor: table_creator
- @ln -f $< $@
-
-table_creator.opt: table_creator.ml ../metadata.cmxa
- @echo " OCAMLOPT $<"
- @$(OCAMLFIND) ocamlopt \
- -thread -package mysql,helm-metadata -linkpkg -o $@ $<
-
-table_destructor.opt: table_creator.opt
- @ln -f $< $@
-
-clean:
- rm -f *.cm[iox] *.a *.o
- rm -f table_creator table_creator.opt table_destructor table_destructor.opt
-
-include .depend
-include ../../../Makefile.defs
+++ /dev/null
-#!/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."
-
+++ /dev/null
-
-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 ()
-
-
+++ /dev/null
-helm_registry.cmo: helm_registry.cmi
-helm_registry.cmx: helm_registry.cmi
+++ /dev/null
-#use "topfind";;
-#require "helm-registry";;
-open Helm_registry;;
-load_from "tests/sample.xml";;
+++ /dev/null
-
-PACKAGE = registry
-INTERFACE_FILES = helm_registry.mli
-IMPLEMENTATION_FILES = helm_registry.ml
-
-include ../../Makefile.defs
-include ../Makefile.common
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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 ->
- (try
- [ Sys.getenv key ]
- with Not_found -> raise (Key_not_found key))
- | values, None -> values
- in
- List.map (interpolate (key :: stack)) values
- and interpolate stack value =
- Str.global_substitute interpolated_key_rex
- (fun s ->
- let matched = Str.matched_string s in
- (* "$(var)" -> "var" *)
- let key = String.sub matched 2 (String.length matched - 3) in
- singleton (aux stack key))
- value
- in
- List.map strip_blanks (aux [] key)
-
-let has registry key = Hashtbl.mem registry key
-
-let get_typed registry unmarshaller key =
- let value = singleton (get registry key) in
- unmarshaller value
-
-let set_typed registry marshaller ~key ~value =
- set' ~replace:true registry ~key ~value:(marshaller value)
-
-let get_opt registry unmarshaller key =
- try
- Some (unmarshaller (singleton (get registry key)))
- with Key_not_found _ -> None
-
-let get_opt_default registry unmarshaller ~default key =
- match get_opt registry unmarshaller key with
- | None -> default
- | Some v -> v
-
-let set_opt registry marshaller ~key ~value =
- match value with
- | None -> unset registry key
- | Some value -> set' ~replace:true registry ~key ~value:(marshaller value)
-
-let get_list registry unmarshaller key =
- try
- List.map unmarshaller (get registry key)
- with Key_not_found _ -> []
-
-let get_pair registry fst_unmarshaller snd_unmarshaller key =
- let v = singleton (get registry key) in
- match Str.split spaces_rex v with
- | [fst; snd] -> fst_unmarshaller fst, snd_unmarshaller snd
- | _ -> raise (Type_error "not a pair")
-
-let set_list registry marshaller ~key ~value =
- Hashtbl.remove registry key;
- List.iter
- (fun v -> set' ~replace:false registry ~key ~value:(marshaller v))
- value
-
-type xml_tree =
- | Cdata of string
- | Element of string * (string * string) list * xml_tree list
-
-let dot_RE = Str.regexp "\\."
-
-let xml_tree_of_registry registry =
- let has_child name elements =
- List.exists
- (function
- | Element (_, ["name", name'], _) when name = name' -> true
- | _ -> false)
- elements
- in
- let rec get_child name = function
- | [] -> assert false
- | (Element (_, ["name", name'], _) as child) :: tl when name = name' ->
- child, tl
- | hd :: tl ->
- let child, rest = get_child name tl in
- child, hd :: rest
- in
- let rec add_key path value tree =
- match path, tree with
- | [key], Element (name, attrs, children) ->
- Element (name, attrs,
- Element ("key", ["name", key],
- [Cdata (strip_blanks value)]) :: children)
- | dir :: path, Element (name, attrs, children) ->
- if has_child dir children then
- let child, rest = get_child dir children in
- Element (name, attrs, add_key path value child :: rest)
- else
- Element (name, attrs,
- ((add_key path value (Element ("section", ["name", dir], [])))
- :: children))
- | _ -> assert false
- in
- Hashtbl.fold
- (fun k v tree -> add_key ((Str.split dot_RE k)) v tree)
- registry
- (Element (root_tag, [], []))
-
-let rec stream_of_xml_tree = function
- | Cdata s -> Xml.xml_cdata s
- | Element (name, attrs, children) ->
- Xml.xml_nempty name
- (List.map (fun (n, v) -> (None, n, v)) attrs)
- (stream_of_xml_trees children)
-and stream_of_xml_trees = function
- | [] -> [< >]
- | hd :: tl -> [< stream_of_xml_tree hd; stream_of_xml_trees tl >]
-
-let save_to registry fname =
- let token_stream = stream_of_xml_tree (xml_tree_of_registry registry) in
- let oc = open_out fname in
- Xml.pp_to_outchan token_stream oc;
- close_out oc
-
-let rec load_from_absolute ?path registry fname =
- let _path = ref (match path with None -> [] | Some p -> p)in
- (* <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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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)
-
+++ /dev/null
-<?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="tests/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>
+++ /dev/null
-<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>
+++ /dev/null
-proofEngineHelpers.cmi: proofEngineTypes.cmi
-continuationals.cmi: proofEngineTypes.cmi
-tacticals.cmi: proofEngineTypes.cmi continuationals.cmi
-reductionTactics.cmi: proofEngineTypes.cmi
-proofEngineStructuralRules.cmi: proofEngineTypes.cmi
-primitiveTactics.cmi: proofEngineTypes.cmi
-metadataQuery.cmi: proofEngineTypes.cmi
-paramodulation/inference.cmi: paramodulation/utils.cmi proofEngineTypes.cmi
-paramodulation/equality_indexing.cmi: paramodulation/utils.cmi \
- paramodulation/inference.cmi
-paramodulation/indexing.cmi: paramodulation/utils.cmi \
- paramodulation/inference.cmi paramodulation/equality_indexing.cmi
-paramodulation/saturation.cmi: proofEngineTypes.cmi
-variousTactics.cmi: proofEngineTypes.cmi
-autoTactic.cmi: proofEngineTypes.cmi
-introductionTactics.cmi: proofEngineTypes.cmi
-eliminationTactics.cmi: proofEngineTypes.cmi
-negationTactics.cmi: proofEngineTypes.cmi
-equalityTactics.cmi: proofEngineTypes.cmi
-discriminationTactics.cmi: proofEngineTypes.cmi
-inversion.cmi: proofEngineTypes.cmi
-ring.cmi: proofEngineTypes.cmi
-fourierR.cmi: proofEngineTypes.cmi
-fwdSimplTactic.cmi: proofEngineTypes.cmi
-statefulProofEngine.cmi: proofEngineTypes.cmi
-tactics.cmi: proofEngineTypes.cmi
-proofEngineTypes.cmo: proofEngineTypes.cmi
-proofEngineTypes.cmx: proofEngineTypes.cmi
-proofEngineHelpers.cmo: proofEngineTypes.cmi proofEngineHelpers.cmi
-proofEngineHelpers.cmx: proofEngineTypes.cmx proofEngineHelpers.cmi
-proofEngineReduction.cmo: proofEngineTypes.cmi proofEngineHelpers.cmi \
- proofEngineReduction.cmi
-proofEngineReduction.cmx: proofEngineTypes.cmx proofEngineHelpers.cmx \
- proofEngineReduction.cmi
-continuationals.cmo: proofEngineTypes.cmi continuationals.cmi
-continuationals.cmx: proofEngineTypes.cmx continuationals.cmi
-tacticals.cmo: proofEngineTypes.cmi continuationals.cmi tacticals.cmi
-tacticals.cmx: proofEngineTypes.cmx continuationals.cmx tacticals.cmi
-reductionTactics.cmo: proofEngineTypes.cmi proofEngineReduction.cmi \
- proofEngineHelpers.cmi reductionTactics.cmi
-reductionTactics.cmx: proofEngineTypes.cmx proofEngineReduction.cmx \
- proofEngineHelpers.cmx reductionTactics.cmi
-proofEngineStructuralRules.cmo: proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi
-proofEngineStructuralRules.cmx: proofEngineTypes.cmx \
- proofEngineStructuralRules.cmi
-primitiveTactics.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
- proofEngineHelpers.cmi primitiveTactics.cmi
-primitiveTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
- proofEngineHelpers.cmx primitiveTactics.cmi
-hashtbl_equiv.cmo: hashtbl_equiv.cmi
-hashtbl_equiv.cmx: hashtbl_equiv.cmi
-metadataQuery.cmo: proofEngineTypes.cmi primitiveTactics.cmi \
- hashtbl_equiv.cmi metadataQuery.cmi
-metadataQuery.cmx: proofEngineTypes.cmx primitiveTactics.cmx \
- hashtbl_equiv.cmx metadataQuery.cmi
-paramodulation/utils.cmo: proofEngineReduction.cmi paramodulation/utils.cmi
-paramodulation/utils.cmx: proofEngineReduction.cmx paramodulation/utils.cmi
-paramodulation/inference.cmo: paramodulation/utils.cmi \
- proofEngineReduction.cmi proofEngineHelpers.cmi metadataQuery.cmi \
- paramodulation/inference.cmi
-paramodulation/inference.cmx: paramodulation/utils.cmx \
- proofEngineReduction.cmx proofEngineHelpers.cmx metadataQuery.cmx \
- paramodulation/inference.cmi
-paramodulation/equality_indexing.cmo: paramodulation/utils.cmi \
- paramodulation/inference.cmi paramodulation/equality_indexing.cmi
-paramodulation/equality_indexing.cmx: paramodulation/utils.cmx \
- paramodulation/inference.cmx paramodulation/equality_indexing.cmi
-paramodulation/indexing.cmo: paramodulation/utils.cmi \
- paramodulation/inference.cmi paramodulation/equality_indexing.cmi \
- paramodulation/indexing.cmi
-paramodulation/indexing.cmx: paramodulation/utils.cmx \
- paramodulation/inference.cmx paramodulation/equality_indexing.cmx \
- paramodulation/indexing.cmi
-paramodulation/saturation.cmo: paramodulation/utils.cmi reductionTactics.cmi \
- proofEngineTypes.cmi proofEngineReduction.cmi primitiveTactics.cmi \
- paramodulation/inference.cmi paramodulation/indexing.cmi \
- paramodulation/saturation.cmi
-paramodulation/saturation.cmx: paramodulation/utils.cmx reductionTactics.cmx \
- proofEngineTypes.cmx proofEngineReduction.cmx primitiveTactics.cmx \
- paramodulation/inference.cmx paramodulation/indexing.cmx \
- paramodulation/saturation.cmi
-variousTactics.cmo: tacticals.cmi proofEngineTypes.cmi \
- proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \
- variousTactics.cmi
-variousTactics.cmx: tacticals.cmx proofEngineTypes.cmx \
- proofEngineReduction.cmx proofEngineHelpers.cmx primitiveTactics.cmx \
- variousTactics.cmi
-autoTactic.cmo: paramodulation/saturation.cmi proofEngineTypes.cmi \
- proofEngineHelpers.cmi primitiveTactics.cmi metadataQuery.cmi \
- paramodulation/inference.cmi autoTactic.cmi
-autoTactic.cmx: paramodulation/saturation.cmx proofEngineTypes.cmx \
- proofEngineHelpers.cmx primitiveTactics.cmx metadataQuery.cmx \
- paramodulation/inference.cmx autoTactic.cmi
-introductionTactics.cmo: proofEngineTypes.cmi primitiveTactics.cmi \
- introductionTactics.cmi
-introductionTactics.cmx: proofEngineTypes.cmx primitiveTactics.cmx \
- introductionTactics.cmi
-eliminationTactics.cmo: tacticals.cmi proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi proofEngineHelpers.cmi \
- primitiveTactics.cmi eliminationTactics.cmi
-eliminationTactics.cmx: tacticals.cmx proofEngineTypes.cmx \
- proofEngineStructuralRules.cmx proofEngineHelpers.cmx \
- primitiveTactics.cmx eliminationTactics.cmi
-negationTactics.cmo: variousTactics.cmi tacticals.cmi proofEngineTypes.cmi \
- primitiveTactics.cmi eliminationTactics.cmi negationTactics.cmi
-negationTactics.cmx: variousTactics.cmx tacticals.cmx proofEngineTypes.cmx \
- primitiveTactics.cmx eliminationTactics.cmx negationTactics.cmi
-equalityTactics.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi proofEngineReduction.cmi \
- proofEngineHelpers.cmi primitiveTactics.cmi introductionTactics.cmi \
- equalityTactics.cmi
-equalityTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
- proofEngineStructuralRules.cmx proofEngineReduction.cmx \
- proofEngineHelpers.cmx primitiveTactics.cmx introductionTactics.cmx \
- equalityTactics.cmi
-discriminationTactics.cmo: tacticals.cmi reductionTactics.cmi \
- proofEngineTypes.cmi primitiveTactics.cmi introductionTactics.cmi \
- equalityTactics.cmi eliminationTactics.cmi discriminationTactics.cmi
-discriminationTactics.cmx: tacticals.cmx reductionTactics.cmx \
- proofEngineTypes.cmx primitiveTactics.cmx introductionTactics.cmx \
- equalityTactics.cmx eliminationTactics.cmx discriminationTactics.cmi
-inversion.cmo: tacticals.cmi proofEngineTypes.cmi proofEngineReduction.cmi \
- proofEngineHelpers.cmi primitiveTactics.cmi equalityTactics.cmi \
- inversion.cmi
-inversion.cmx: tacticals.cmx proofEngineTypes.cmx proofEngineReduction.cmx \
- proofEngineHelpers.cmx primitiveTactics.cmx equalityTactics.cmx \
- inversion.cmi
-ring.cmo: tacticals.cmi proofEngineTypes.cmi proofEngineStructuralRules.cmi \
- primitiveTactics.cmi equalityTactics.cmi eliminationTactics.cmi ring.cmi
-ring.cmx: tacticals.cmx proofEngineTypes.cmx proofEngineStructuralRules.cmx \
- primitiveTactics.cmx equalityTactics.cmx eliminationTactics.cmx ring.cmi
-fourier.cmo: fourier.cmi
-fourier.cmx: fourier.cmi
-fourierR.cmo: tacticals.cmi ring.cmi reductionTactics.cmi \
- proofEngineTypes.cmi proofEngineHelpers.cmi primitiveTactics.cmi \
- fourier.cmi equalityTactics.cmi fourierR.cmi
-fourierR.cmx: tacticals.cmx ring.cmx reductionTactics.cmx \
- proofEngineTypes.cmx proofEngineHelpers.cmx primitiveTactics.cmx \
- fourier.cmx equalityTactics.cmx fourierR.cmi
-fwdSimplTactic.cmo: tacticals.cmi proofEngineTypes.cmi \
- proofEngineStructuralRules.cmi proofEngineHelpers.cmi \
- primitiveTactics.cmi fwdSimplTactic.cmi
-fwdSimplTactic.cmx: tacticals.cmx proofEngineTypes.cmx \
- proofEngineStructuralRules.cmx proofEngineHelpers.cmx \
- primitiveTactics.cmx fwdSimplTactic.cmi
-history.cmo: history.cmi
-history.cmx: history.cmi
-statefulProofEngine.cmo: proofEngineTypes.cmi history.cmi \
- statefulProofEngine.cmi
-statefulProofEngine.cmx: proofEngineTypes.cmx history.cmx \
- statefulProofEngine.cmi
-tactics.cmo: variousTactics.cmi tacticals.cmi paramodulation/saturation.cmi \
- ring.cmi reductionTactics.cmi proofEngineStructuralRules.cmi \
- primitiveTactics.cmi negationTactics.cmi inversion.cmi \
- introductionTactics.cmi fwdSimplTactic.cmi fourierR.cmi \
- equalityTactics.cmi eliminationTactics.cmi discriminationTactics.cmi \
- autoTactic.cmi tactics.cmi
-tactics.cmx: variousTactics.cmx tacticals.cmx paramodulation/saturation.cmx \
- ring.cmx reductionTactics.cmx proofEngineStructuralRules.cmx \
- primitiveTactics.cmx negationTactics.cmx inversion.cmx \
- introductionTactics.cmx fwdSimplTactic.cmx fourierR.cmx \
- equalityTactics.cmx eliminationTactics.cmx discriminationTactics.cmx \
- autoTactic.cmx tactics.cmi
+++ /dev/null
-PACKAGE = tactics
-
-INTERFACE_FILES = \
- proofEngineTypes.mli \
- proofEngineHelpers.mli proofEngineReduction.mli \
- continuationals.mli \
- tacticals.mli reductionTactics.mli proofEngineStructuralRules.mli \
- primitiveTactics.mli hashtbl_equiv.mli metadataQuery.mli \
- paramodulation/utils.mli \
- paramodulation/inference.mli\
- paramodulation/equality_indexing.mli\
- paramodulation/indexing.mli \
- paramodulation/saturation.mli \
- variousTactics.mli autoTactic.mli \
- introductionTactics.mli eliminationTactics.mli negationTactics.mli \
- equalityTactics.mli discriminationTactics.mli inversion.mli ring.mli \
- fourier.mli fourierR.mli fwdSimplTactic.mli history.mli \
- statefulProofEngine.mli tactics.mli
-
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-
-
-all:
-
-tactics.mli: tactics.ml *Tactics.mli *Tactic.mli fourierR.mli ring.mli paramodulation/indexing.mli
- @echo " OCAMLC -i $< > $@"
- $(H)echo "(* GENERATED FILE, DO NOT EDIT *)" > $@
- $(H)$(OCAMLC) -I paramodulation -i $< >> $@
-
-STATS_EXCLUDE = tactics.mli
-
-include ../../Makefile.defs
-include ../Makefile.common
-
-OCAMLOPTIONS+= -I paramodulation
-OCAMLDEPOPTIONS+= -I paramodulation
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
- let debug = false
- let debug_print s = if debug then prerr_endline (Lazy.force s)
-
-(* let debug_print = fun _ -> () *)
-
-(* Profiling code
-let new_experimental_hint =
- let profile = CicUtil.profile "new_experimental_hint" in
- fun ~dbd ~facts ?signature ~universe status ->
- profile.profile (MetadataQuery.new_experimental_hint ~dbd ~facts ?signature ~universe) status
-*) let new_experimental_hint = MetadataQuery.new_experimental_hint
-
-(* In this versions of auto_tac we maintain an hash table of all inspected
- goals. We assume that the context is invariant for application.
- To this aim, it is essential to sall hint_verbose, that in turns calls
- apply_verbose. *)
-
-type exitus =
- No of int
- | Yes of Cic.term * int
- | NotYetInspected
-
-let inspected_goals = Hashtbl.create 503;;
-
-let search_theorems_in_context status =
- let (proof, goal) = status in
- let module C = Cic in
- let module R = CicReduction in
- let module S = CicSubstitution in
- let module PET = ProofEngineTypes in
- let module PT = PrimitiveTactics in
- let _,metasenv,_,_ = proof in
- let _,context,ty = CicUtil.lookup_meta goal metasenv in
- let rec find n = function
- | [] -> []
- | hd::tl ->
- let res =
- (* we should check that the hypothesys has not been cleared *)
- if List.nth context (n-1) = None then
- None
- else
- try
- let (subst,(proof, goal_list)) =
- PT.apply_tac_verbose ~term:(C.Rel n) status
- in
- (*
- let goal_list =
- List.stable_sort (compare_goal_list proof) goal_list in
- *)
- Some (subst,(proof, goal_list))
- with
- PET.Fail _ -> None
- in
- (match res with
- | Some res -> res::(find (n+1) tl)
- | None -> find (n+1) tl)
- in
- try
- find 1 context
- with Failure s -> []
-;;
-
-
-let compare_goals proof goal1 goal2 =
- let _,metasenv,_,_ = proof in
- let (_, ey1, ty1) = CicUtil.lookup_meta goal1 metasenv in
- let (_, ey2, ty2) = CicUtil.lookup_meta goal2 metasenv in
- let ty_sort1,_ = CicTypeChecker.type_of_aux' metasenv ey1 ty1
- CicUniv.empty_ugraph in
- let ty_sort2,_ = CicTypeChecker.type_of_aux' metasenv ey2 ty2
- CicUniv.empty_ugraph in
- let prop1 =
- let b,_ = CicReduction.are_convertible ey1 (Cic.Sort Cic.Prop) ty_sort1
- CicUniv.empty_ugraph in
- if b then 0 else 1
- in
- let prop2 =
- let b,_ = CicReduction.are_convertible ey2 (Cic.Sort Cic.Prop) ty_sort2
- CicUniv.empty_ugraph in
- if b then 0 else 1
- in
- prop1 - prop2
-
-
-let new_search_theorems f dbd proof goal depth sign =
- let choices = f (proof,goal)
- in
- List.map
- (function (subst,(proof, goallist)) ->
- (* let goallist = reorder_goals dbd sign proof goallist in *)
- let goallist = List.sort (compare_goals proof) goallist in
- (subst,(proof,(List.map (function g -> (g,depth)) goallist), sign)))
- choices
-;;
-
-exception NoOtherChoices;;
-
-let rec auto_single dbd proof goal ey ty depth width sign already_seen_goals
- universe
- =
- if depth = 0 then [] else
- if List.mem ty already_seen_goals then [] else
- let already_seen_goals = ty::already_seen_goals in
- let facts = (depth = 1) in
- let _,metasenv,p,_ = proof in
- (* first of all we check if the goal has been already
- inspected *)
- assert (CicUtil.exists_meta goal metasenv);
- let exitus =
- try Hashtbl.find inspected_goals ty
- with Not_found -> NotYetInspected in
- let is_meta_closed = CicUtil.is_meta_closed ty in
- begin
- match exitus with
- Yes (bo,_) ->
- (*
- debug_print (lazy "ALREADY PROVED!!!!!!!!!!!!!!!!!!!!!!!!!!!!");
- debug_print (lazy (CicPp.ppterm ty));
- *)
- let subst_in =
- (* if we just apply the subtitution, the type
- is irrelevant: we may use Implicit, since it will
- be dropped *)
- CicMetaSubst.apply_subst
- [(goal,(ey, bo, Cic.Implicit None))] in
- let (proof,_) =
- ProofEngineHelpers.subst_meta_and_metasenv_in_proof
- proof goal subst_in metasenv in
- [(subst_in,(proof,[],sign))]
- | No d when (d >= depth) ->
- (* debug_print (lazy "PRUNED!!!!!!!!!!!!!!!!!!!!!!!!!!!!"); *)
- [] (* the empty list means no choices, i.e. failure *)
- | No _
- | NotYetInspected ->
- debug_print (lazy ("CURRENT GOAL = " ^ CicPp.ppterm ty));
- debug_print (lazy ("CURRENT PROOF = " ^ CicPp.ppterm p));
- debug_print (lazy ("CURRENT HYP = " ^ CicPp.ppcontext ey));
- let sign, new_sign =
- if is_meta_closed then
- None, Some (MetadataConstraints.signature_of ty)
- else sign,sign in (* maybe the union ? *)
- let local_choices =
- new_search_theorems
- search_theorems_in_context dbd
- proof goal (depth-1) new_sign in
- let global_choices =
- new_search_theorems
- (fun status ->
- List.map snd
- (new_experimental_hint
- ~dbd ~facts:facts ?signature:sign ~universe status))
- dbd proof goal (depth-1) new_sign in
- let all_choices =
- local_choices@global_choices in
- let sorted_choices =
- List.stable_sort
- (fun (_, (_, goals1, _)) (_, (_, goals2, _)) ->
- Pervasives.compare
- (List.length goals1) (List.length goals2))
- all_choices in
- (match (auto_new dbd width already_seen_goals universe sorted_choices)
- with
- [] ->
- (* no proof has been found; we update the
- hastable *)
- (* if is_meta_closed then *)
- Hashtbl.add inspected_goals ty (No depth);
- []
- | (subst,(proof,[],sign))::tl1 ->
- (* a proof for goal has been found:
- in order to get the proof we apply subst to
- Meta[goal] *)
- if is_meta_closed then
- begin
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable ey in
- let meta_proof =
- subst (Cic.Meta(goal,irl)) in
- Hashtbl.add inspected_goals
- ty (Yes (meta_proof,depth));
-(*
- begin
- let cty,_ =
- CicTypeChecker.type_of_aux' metasenv ey meta_proof CicUniv.empty_ugraph
- in
- if not (cty = ty) then
- begin
- debug_print (lazy ("ty = "^CicPp.ppterm ty));
- debug_print (lazy ("cty = "^CicPp.ppterm cty));
- assert false
- end
- Hashtbl.add inspected_goals
- ty (Yes (meta_proof,depth));
- end;
-*)
- end;
- (subst,(proof,[],sign))::tl1
- | _ -> assert false)
- end
-
-and auto_new dbd width already_seen_goals universe = function
- | [] -> []
- | (subst,(proof, goals, sign))::tl ->
- let _,metasenv,_,_ = proof in
- let goals'=
- List.filter (fun (goal, _) -> CicUtil.exists_meta goal metasenv) goals
- in
- auto_new_aux dbd
- width already_seen_goals universe ((subst,(proof, goals', sign))::tl)
-
-and auto_new_aux dbd width already_seen_goals universe = function
- | [] -> []
- | (subst,(proof, [], sign))::tl -> (subst,(proof, [], sign))::tl
- | (subst,(proof, (goal,0)::_, _))::tl ->
- auto_new dbd width already_seen_goals universe tl
- | (subst,(proof, goals, _))::tl when
- (List.length goals) > width ->
- auto_new dbd width already_seen_goals universe tl
- | (subst,(proof, (goal,depth)::gtl, sign))::tl ->
- let _,metasenv,p,_ = proof in
- let (_, ey ,ty) = CicUtil.lookup_meta goal metasenv in
- match (auto_single dbd proof goal ey ty depth
- (width - (List.length gtl)) sign already_seen_goals) universe
- with
- [] -> auto_new dbd width already_seen_goals universe tl
- | (local_subst,(proof,[],sign))::tl1 ->
- let new_subst f t = f (subst t) in
- let is_meta_closed = CicUtil.is_meta_closed ty in
- let all_choices =
- if is_meta_closed then
- (new_subst local_subst,(proof,gtl,sign))::tl
- else
- let tl2 =
- (List.map
- (function (f,(p,l,s)) -> (new_subst f,(p,l@gtl,s))) tl1)
- in
- (new_subst local_subst,(proof,gtl,sign))::tl2@tl in
- auto_new dbd width already_seen_goals universe all_choices
- | _ -> assert false
- ;;
-
-let default_depth = 5
-let default_width = 3
-
-(*
-let auto_tac ?(depth=default_depth) ?(width=default_width) ~(dbd:HMysql.dbd)
- ()
-=
- let auto_tac dbd (proof,goal) =
- let universe = MetadataQuery.signature_of_goal ~dbd (proof,goal) in
- Hashtbl.clear inspected_goals;
- debug_print (lazy "Entro in Auto");
- let id t = t in
- let t1 = Unix.gettimeofday () in
- match auto_new dbd width [] universe [id,(proof, [(goal,depth)],None)] with
- [] -> debug_print (lazy "Auto failed");
- raise (ProofEngineTypes.Fail "No Applicable theorem")
- | (_,(proof,[],_))::_ ->
- let t2 = Unix.gettimeofday () in
- debug_print (lazy "AUTO_TAC HA FINITO");
- let _,_,p,_ = proof in
- debug_print (lazy (CicPp.ppterm p));
- Printf.printf "tempo: %.9f\n" (t2 -. t1);
- (proof,[])
- | _ -> assert false
- in
- ProofEngineTypes.mk_tactic (auto_tac dbd)
-;;
-*)
-
-(*
-let paramodulation_tactic = ref
- (fun dbd ?full ?depth ?width status ->
- raise (ProofEngineTypes.Fail (lazy "Not Ready yet...")));;
-
-let term_is_equality = ref
- (fun term -> debug_print (lazy "term_is_equality E` DUMMY!!!!"); false);;
-*)
-
-let auto_tac ?(depth=default_depth) ?(width=default_width) ?paramodulation
- ?full ~(dbd:HMysql.dbd) () =
- let auto_tac dbd (proof, goal) =
- let normal_auto () =
- let universe = MetadataQuery.signature_of_goal ~dbd (proof, goal) in
- Hashtbl.clear inspected_goals;
- debug_print (lazy "Entro in Auto");
- let id t = t in
- let t1 = Unix.gettimeofday () in
- match
- auto_new dbd width [] universe [id, (proof, [(goal, depth)], None)]
- with
- [] -> debug_print(lazy "Auto failed");
- raise (ProofEngineTypes.Fail (lazy "No Applicable theorem"))
- | (_,(proof,[],_))::_ ->
- let t2 = Unix.gettimeofday () in
- debug_print (lazy "AUTO_TAC HA FINITO");
- let _,_,p,_ = proof in
- debug_print (lazy (CicPp.ppterm p));
- debug_print (lazy (Printf.sprintf "tempo: %.9f\n" (t2 -. t1)));
- (proof,[])
- | _ -> assert false
- in
- let full = match full with None -> false | Some _ -> true in
- let paramodulation_ok =
- match paramodulation with
- | None -> false
- | Some _ ->
- let _, metasenv, _, _ = proof in
- let _, _, meta_goal = CicUtil.lookup_meta goal metasenv in
- full || (Inference.term_is_equality meta_goal)
- in
- if paramodulation_ok then (
- debug_print (lazy "USO PARAMODULATION...");
-(* try *)
- Saturation.saturate dbd ~depth ~width ~full (proof, goal)
-(* with ProofEngineTypes.Fail _ -> *)
-(* normal_auto () *)
- ) else
- normal_auto ()
- in
- ProofEngineTypes.mk_tactic (auto_tac dbd)
-;;
+++ /dev/null
-
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val auto_tac:
- ?depth:int -> ?width:int -> ?paramodulation:string -> ?full:string ->
- dbd:HMysql.dbd -> unit ->
- ProofEngineTypes.tactic
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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")
-;;
-
-*)
-
-
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val injection_tac: term:Cic.term -> ProofEngineTypes.tactic
-val discriminate_tac: term:Cic.term -> ProofEngineTypes.tactic
-val decide_equality_tac: ProofEngineTypes.tactic
-val compare_tac: term:Cic.term -> ProofEngineTypes.tactic
-
+++ /dev/null
-
-#
-# 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
-
-########################################################################
-
+++ /dev/null
-
-\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.
-
+++ /dev/null
-%%
-%% 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\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'.
+++ /dev/null
-%%
-%% 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'.
+++ /dev/null
-\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}
-
+++ /dev/null
-%%
-%% 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'.
+++ /dev/null
-%%
-%% 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'.
+++ /dev/null
-%%
-%% 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'.
+++ /dev/null
-%%
-%% 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'.
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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
-*)
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val elim_type_tac:
- ?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
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-let rec rewrite_tac ~direction ~(pattern: ProofEngineTypes.lazy_pattern) equality =
- let _rewrite_tac ~direction ~pattern:(wanted,hyps_pat,concl_pat) equality status
- =
- let module C = Cic in
- let module U = UriManager in
- let module PET = ProofEngineTypes in
- let module PER = ProofEngineReduction in
- let module PEH = ProofEngineHelpers in
- let module PT = PrimitiveTactics in
- assert (wanted = None); (* this should be checked syntactically *)
- let proof,goal = status in
- let curi, metasenv, pbo, pty = proof in
- let (metano,context,gty) = CicUtil.lookup_meta goal metasenv in
- match hyps_pat with
- he::(_::_ as tl) ->
- PET.apply_tactic
- (Tacticals.then_
- (rewrite_tac ~direction
- ~pattern:(None,[he],None) equality)
- (rewrite_tac ~direction ~pattern:(None,tl,concl_pat) equality)
- ) status
- | [_] as hyps_pat when concl_pat <> None ->
- PET.apply_tactic
- (Tacticals.then_
- (rewrite_tac ~direction
- ~pattern:(None,hyps_pat,None) equality)
- (rewrite_tac ~direction ~pattern:(None,[],concl_pat) equality)
- ) status
- | _ ->
- let arg,dir2,tac,concl_pat,gty =
- match hyps_pat with
- [] -> None,true,(fun ~term _ -> PT.exact_tac term),concl_pat,gty
- | [name,pat] ->
- let rec find_hyp n =
- function
- [] -> assert false
- | Some (Cic.Name s,Cic.Decl ty)::_ when name = s ->
- Cic.Rel n, CicSubstitution.lift n ty
- | Some (Cic.Name s,Cic.Def _)::_ -> assert false (*CSC: not implemented yet! But does this make any sense?*)
- | _::tl -> find_hyp (n+1) tl
- in
- let arg,gty = find_hyp 1 context in
- let dummy = "dummy" in
- Some arg,false,
- (fun ~term typ ->
- Tacticals.seq
- ~tactics:
- [ProofEngineStructuralRules.rename name dummy;
- PT.letin_tac
- ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name name) term;
- ProofEngineStructuralRules.clearbody name;
- ReductionTactics.change_tac
- ~pattern:
- (None,[name,Cic.Implicit (Some `Hole)], None)
- (ProofEngineTypes.const_lazy_term typ);
- ProofEngineStructuralRules.clear dummy
- ]),
- Some pat,gty
- | _::_ -> assert false
- in
- let if_right_to_left do_not_change a b =
- match direction with
- | `RightToLeft -> if do_not_change then a else b
- | `LeftToRight -> if do_not_change then b else a
- in
- let ty_eq,ugraph =
- CicTypeChecker.type_of_aux' metasenv context equality
- CicUniv.empty_ugraph in
- let (ty_eq,metasenv',arguments,fresh_meta) =
- ProofEngineHelpers.saturate_term
- (ProofEngineHelpers.new_meta_of_proof proof) metasenv context ty_eq 0 in
- let equality =
- if List.length arguments = 0 then
- equality
- else
- C.Appl (equality :: arguments) in
- (* t1x is t2 if we are rewriting in an hypothesis *)
- let eq_ind, ty, t1, t2, t1x =
- match ty_eq with
- | C.Appl [C.MutInd (uri, 0, []); ty; t1; t2]
- when LibraryObjects.is_eq_URI uri ->
- let ind_uri =
- if_right_to_left dir2
- LibraryObjects.eq_ind_URI LibraryObjects.eq_ind_r_URI
- in
- let eq_ind = C.Const (ind_uri uri,[]) in
- if dir2 then
- if_right_to_left true (eq_ind,ty,t2,t1,t2) (eq_ind,ty,t1,t2,t1)
- else
- if_right_to_left true (eq_ind,ty,t1,t2,t2) (eq_ind,ty,t2,t1,t1)
- | _ -> raise (PET.Fail (lazy "Rewrite: argument is not a proof of an equality")) in
- (* now we always do as if direction was `LeftToRight *)
- let fresh_name =
- FreshNamesGenerator.mk_fresh_name
- ~subst:[] metasenv' context C.Anonymous ~typ:ty in
- let lifted_t1 = CicSubstitution.lift 1 t1x in
- let lifted_gty = CicSubstitution.lift 1 gty in
- let lifted_conjecture =
- metano,(Some (fresh_name,Cic.Decl ty))::context,lifted_gty in
- let lifted_pattern =
- let lifted_concl_pat =
- match concl_pat with
- | None -> None
- | Some term -> Some (CicSubstitution.lift 1 term) in
- Some (fun _ m u -> lifted_t1, m, u),[],lifted_concl_pat
- in
- let subst,metasenv',ugraph,_,selected_terms_with_context =
- ProofEngineHelpers.select
- ~metasenv:metasenv' ~ugraph ~conjecture:lifted_conjecture
- ~pattern:lifted_pattern in
- let metasenv' = CicMetaSubst.apply_subst_metasenv subst metasenv' in
- let what,with_what =
- (* Note: Rel 1 does not live in the context context_of_t *)
- (* The replace_lifting_csc 0 function will take care of lifting it *)
- (* to context_of_t *)
- List.fold_right
- (fun (context_of_t,t) (l1,l2) -> t::l1, Cic.Rel 1::l2)
- selected_terms_with_context ([],[]) in
- let t1 = CicMetaSubst.apply_subst subst t1 in
- let t2 = CicMetaSubst.apply_subst subst t2 in
- let equality = CicMetaSubst.apply_subst subst equality in
- let abstr_gty =
- ProofEngineReduction.replace_lifting_csc 0
- ~equality:(==) ~what ~with_what:with_what ~where:lifted_gty in
- let abstr_gty = CicMetaSubst.apply_subst subst abstr_gty in
- let pred = C.Lambda (fresh_name, ty, abstr_gty) in
- (* The argument is either a meta if we are rewriting in the conclusion
- or the hypothesis if we are rewriting in an hypothesis *)
- let metasenv',arg,newtyp =
- match arg with
- None ->
- let gty' = CicSubstitution.subst t2 abstr_gty in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- let metasenv' = (fresh_meta,context,gty')::metasenv' in
- metasenv', C.Meta (fresh_meta,irl), Cic.Rel (-1) (* dummy term, never used *)
- | Some arg ->
- let gty' = CicSubstitution.subst t1 abstr_gty in
- metasenv',arg,gty'
- in
- let exact_proof =
- C.Appl [eq_ind ; ty ; t2 ; pred ; arg ; t1 ;equality]
- in
- let (proof',goals) =
- PET.apply_tactic
- (tac ~term:exact_proof newtyp) ((curi,metasenv',pbo,pty),goal)
- in
- let goals =
- goals@(ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv
- ~newmetasenv:metasenv')
- in
- (proof',goals)
- in
- ProofEngineTypes.mk_tactic (_rewrite_tac ~direction ~pattern equality)
-
-
-let rewrite_simpl_tac ~direction ~pattern equality =
- let rewrite_simpl_tac ~direction ~pattern equality status =
- ProofEngineTypes.apply_tactic
- (Tacticals.then_
- ~start:(rewrite_tac ~direction ~pattern equality)
- ~continuation:
- (ReductionTactics.simpl_tac
- ~pattern:(ProofEngineTypes.conclusion_pattern None)))
- status
- in
- ProofEngineTypes.mk_tactic (rewrite_simpl_tac ~direction ~pattern equality)
-;;
-
-let replace_tac ~(pattern: ProofEngineTypes.lazy_pattern) ~with_what =
- let replace_tac ~(pattern: ProofEngineTypes.lazy_pattern) ~with_what status =
- let _wanted, hyps_pat, concl_pat = pattern in
- let (proof, goal) = status in
- let module C = Cic in
- let module U = UriManager in
- let module P = PrimitiveTactics in
- let module T = Tacticals in
- let uri,metasenv,pbo,pty = proof in
- let (_,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in
- assert (hyps_pat = []); (*CSC: not implemented yet *)
- let context_len = List.length context in
- let subst,metasenv,u,_,selected_terms_with_context =
- ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph
- ~conjecture ~pattern in
- let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
- let with_what, metasenv, u = with_what context metasenv u in
- let with_what = CicMetaSubst.apply_subst subst with_what in
- let pbo = CicMetaSubst.apply_subst subst pbo in
- let pty = CicMetaSubst.apply_subst subst pty in
- let status = (uri,metasenv,pbo,pty),goal in
- let ty_of_with_what,u =
- CicTypeChecker.type_of_aux'
- metasenv context with_what CicUniv.empty_ugraph in
- let whats =
- match selected_terms_with_context with
- [] -> raise (ProofEngineTypes.Fail (lazy "Replace: no term selected"))
- | l ->
- List.map
- (fun (context_of_t,t) ->
- let t_in_context =
- try
- let context_of_t_len = List.length context_of_t in
- if context_of_t_len = context_len then t
- else
- (let t_in_context,subst,metasenv' =
- CicMetaSubst.delift_rels [] metasenv
- (context_of_t_len - context_len) t
- in
- assert (subst = []);
- assert (metasenv = metasenv');
- t_in_context)
- with
- CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
- (*CSC: we could implement something stronger by completely changing
- the semantics of the tactic *)
- raise (ProofEngineTypes.Fail
- (lazy "Replace: one of the selected terms is not closed")) in
- let ty_of_t_in_context,u = (* TASSI: FIXME *)
- CicTypeChecker.type_of_aux' metasenv context t_in_context
- CicUniv.empty_ugraph in
- let b,u = CicReduction.are_convertible ~metasenv context
- ty_of_with_what ty_of_t_in_context u in
- if b then
- let concl_pat_for_t = ProofEngineHelpers.pattern_of ~term:ty [t] in
- let pattern_for_t = None,[],Some concl_pat_for_t in
- t_in_context,pattern_for_t
- else
- raise
- (ProofEngineTypes.Fail
- (lazy "Replace: one of the selected terms and the term to be replaced with have not convertible types"))
- ) l in
- let rec aux n whats status =
- match whats with
- [] -> ProofEngineTypes.apply_tactic T.id_tac status
- | (what,lazy_pattern)::tl ->
- let what = CicSubstitution.lift n what in
- let with_what = CicSubstitution.lift n with_what in
- let ty_of_with_what = CicSubstitution.lift n ty_of_with_what in
- ProofEngineTypes.apply_tactic
- (T.thens
- ~start:(
- P.cut_tac
- (C.Appl [
- (C.MutInd (LibraryObjects.eq_URI (), 0, [])) ;
- ty_of_with_what ;
- what ;
- with_what]))
- ~continuations:[
- T.then_
- ~start:(
- rewrite_tac ~direction:`LeftToRight ~pattern:lazy_pattern (C.Rel 1))
- ~continuation:(
- T.then_
- ~start:(
- ProofEngineTypes.mk_tactic
- (function ((proof,goal) as status) ->
- let _,metasenv,_,_ = proof in
- let _,context,_ = CicUtil.lookup_meta goal metasenv in
- let hyp =
- try
- match List.hd context with
- Some (Cic.Name name,_) -> name
- | _ -> assert false
- with (Failure "hd") -> assert false
- in
- ProofEngineTypes.apply_tactic
- (ProofEngineStructuralRules.clear ~hyp) status))
- ~continuation:(aux_tac (n + 1) tl));
- T.id_tac])
- status
- and aux_tac n tl = ProofEngineTypes.mk_tactic (aux n tl) in
- aux 0 whats status
- in
- ProofEngineTypes.mk_tactic (replace_tac ~pattern ~with_what)
-;;
-
-
-(* All these tacs do is applying the right constructor/theorem *)
-
-let reflexivity_tac =
- IntroductionTactics.constructor_tac ~n:1
-;;
-
-let symmetry_tac =
- let symmetry_tac (proof, goal) =
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let (_,metasenv,_,_) = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- match (R.whd context ty) with
- (C.Appl [(C.MutInd (uri, 0, [])); _; _; _])
- when LibraryObjects.is_eq_URI uri ->
- ProofEngineTypes.apply_tactic
- (PrimitiveTactics.apply_tac
- ~term: (C.Const (LibraryObjects.sym_eq_URI uri, [])))
- (proof,goal)
-
- | _ -> raise (ProofEngineTypes.Fail (lazy "Symmetry failed"))
- in
- ProofEngineTypes.mk_tactic symmetry_tac
-;;
-
-let transitivity_tac ~term =
- let transitivity_tac ~term status =
- let (proof, goal) = status in
- let module C = Cic in
- let module R = CicReduction in
- let module U = UriManager in
- let module T = Tacticals in
- let (_,metasenv,_,_) = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- match (R.whd context ty) with
- (C.Appl [(C.MutInd (uri, 0, [])); _; _; _])
- when LibraryObjects.is_eq_URI uri ->
- ProofEngineTypes.apply_tactic
- (T.thens
- ~start:(PrimitiveTactics.apply_tac
- ~term: (C.Const (LibraryObjects.trans_eq_URI uri, [])))
- ~continuations:
- [PrimitiveTactics.exact_tac ~term ; T.id_tac ; T.id_tac])
- status
-
- | _ -> raise (ProofEngineTypes.Fail (lazy "Transitivity failed"))
- in
- ProofEngineTypes.mk_tactic (transitivity_tac ~term)
-;;
-
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val rewrite_tac:
- 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
-
+++ /dev/null
-(***********************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
-(* \VV/ *************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Méthode d'élimination de Fourier *)
-(* Référence:
-Auteur(s) : Fourier, Jean-Baptiste-Joseph
-
-Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
-
-Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
-
-Pages: 326-327
-
-http://gallica.bnf.fr/
-*)
-
-(** @author The Coq Development Team *)
-
-
-(* Un peu de calcul sur les rationnels...
-Les opérations rendent des rationnels normalisés,
-i.e. le numérateur et le dénominateur sont premiers entre eux.
-*)
-
-
-(** Type for coefficents *)
-type rational = {
-num:int; (** Numerator *)
-den:int; (** Denumerator *)
-};;
-
-(** Debug function.
- @param x the rational to print*)
-let print_rational x =
- print_int x.num;
- print_string "/";
- print_int x.den
-;;
-
-let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);;
-
-(** The constant 0*)
-let r0 = {num=0;den=1};;
-(** The constant 1*)
-let r1 = {num=1;den=1};;
-
-let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in
- if x.num=0 then r0
- else (let d=pgcd x.num x.den in
- let d= (if d<0 then -d else d) in
- {num=(x.num)/d;den=(x.den)/d});;
-
-(** Calculates the opposite of a rational.
- @param x The rational
- @return -x*)
-let rop x = rnorm {num=(-x.num);den=x.den};;
-
-(** Sums two rationals.
- @param x A rational
- @param y Another rational
- @return x+y*)
-let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};;
-(** Substracts two rationals.
- @param x A rational
- @param y Another rational
- @return x-y*)
-let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};;
-(** Multiplyes two rationals.
- @param x A rational
- @param y Another rational
- @return x*y*)
-let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};;
-(** Inverts arational.
- @param x A rational
- @return x{^ -1} *)
-let rinv x = rnorm {num=x.den;den=x.num};;
-(** Divides two rationals.
- @param x A rational
- @param y Another rational
- @return x/y*)
-let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};;
-
-let rinf x y = x.num*y.den < y.num*x.den;;
-let rinfeq x y = x.num*y.den <= y.num*x.den;;
-
-
-(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
-c1x1+...+cnxn < d si strict=true, <= sinon,
-hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
-*)
-
-type ineq = {coef:rational list;
- hist:rational list;
- strict:bool};;
-
-let pop x l = l:=x::(!l);;
-
-(* sépare la liste d'inéquations s selon que leur premier coefficient est
-négatif, nul ou positif. *)
-let partitionne s =
- let lpos=ref [] in
- let lneg=ref [] in
- let lnul=ref [] in
- List.iter (fun ie -> match ie.coef with
- [] -> raise (Failure "empty ineq")
- |(c::r) -> if rinf c r0
- then pop ie lneg
- else if rinf r0 c then pop ie lpos
- else pop ie lnul)
- s;
- [!lneg;!lnul;!lpos]
-;;
-(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
-(add_hist [(equation 1, s1);...;(équation n, sn)])
-=
-[{équation 1, [1;0;...;0], s1};
- {équation 2, [0;1;...;0], s2};
- ...
- {équation n, [0;0;...;1], sn}]
-*)
-let add_hist le =
- let n = List.length le in
- let i=ref 0 in
- List.map (fun (ie,s) ->
- let h =ref [] in
- for k=1 to (n-(!i)-1) do pop r0 h; done;
- pop r1 h;
- for k=1 to !i do pop r0 h; done;
- i:=!i+1;
- {coef=ie;hist=(!h);strict=s})
- le
-;;
-(* additionne deux inéquations *)
-let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef;
- hist=List.map2 rplus ie1.hist ie2.hist;
- strict=ie1.strict || ie2.strict}
-;;
-(* multiplication d'une inéquation par un rationnel (positif) *)
-let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef;
- hist=List.map (fun x -> rmult a x) ie.hist;
- strict= ie.strict}
-;;
-(* on enlève le premier coefficient *)
-let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict}
-;;
-(* le premier coefficient: "tête" de l'inéquation *)
-let hd_coef ie = List.hd ie.coef
-;;
-
-(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
-*)
-let deduce_add lneg lpos =
- let res=ref [] in
- List.iter (fun i1 ->
- List.iter (fun i2 ->
- let a = rop (hd_coef i1) in
- let b = hd_coef i2 in
- pop (ie_tl (ie_add (ie_emult b i1)
- (ie_emult a i2))) res)
- lpos)
- lneg;
- !res
-;;
-(* élimination de la première variable à partir d'une liste d'inéquations:
-opération qu'on itère dans l'algorithme de Fourier.
-*)
-let deduce1 s i=
- match (partitionne s) with
- [lneg;lnul;lpos] ->
- let lnew = deduce_add lneg lpos in
- (match lneg with [] -> print_string("non posso ridurre "^string_of_int i^"\n")|_->();
- match lpos with [] -> print_string("non posso ridurre "^string_of_int i^"\n")|_->());
- (List.map ie_tl lnul)@lnew
- |_->assert false
-;;
-(* algorithme de Fourier: on élimine successivement toutes les variables.
-*)
-let deduce lie =
- let n = List.length (fst (List.hd lie)) in
- let lie=ref (add_hist lie) in
- for i=1 to n-1 do
- lie:= deduce1 !lie i;
- done;
- !lie
-;;
-
-(* donne [] si le système a des find solutions,
-sinon donne [c,s,lc]
-où lc est la combinaison linéaire des inéquations de départ
-qui donne 0 < c si s=true
- ou 0 <= c sinon
-cette inéquation étant absurde.
-*)
-(** Tryes to find if the system admits solutions.
- @param lie the list of inequations
- @return a list that can be empty if the system has solutions. Otherwise it returns a
- one elements list [\[(c,s,lc)\]]. {b c} is the rational that can be obtained solving the system,
- {b s} is true if the inequation that proves that the system is absurd is of type [c < 0], false if
- [c <= 0], {b lc} is a list of rational that represents the liear combination to obtain the
- absurd inequation *)
-let unsolvable lie =
- let lr = deduce lie in
- let res = ref [] in
- (try (List.iter (fun e ->
- match e with
- {coef=[c];hist=lc;strict=s} ->
- if (rinf c r0 && (not s)) || (rinfeq c r0 && s)
- then (res := [c,s,lc];
- raise (Failure "contradiction found"))
- |_->assert false)
- lr)
- with _ -> ());
- !res
-;;
-
-(* Exemples:
-
-let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];;
-deduce test1;;
-unsolvable test1;;
-
-let test2=[
-[r1;r1;r0;r0;r0],false;
-[r0;r1;r1;r0;r0],false;
-[r0;r0;r1;r1;r0],false;
-[r0;r0;r0;r1;r1],false;
-[r1;r0;r0;r0;r1],false;
-[rop r1;rop r1;r0;r0;r0],false;
-[r0;rop r1;rop r1;r0;r0],false;
-[r0;r0;rop r1;rop r1;r0],false;
-[r0;r0;r0;rop r1;rop r1],false;
-[rop r1;r0;r0;r0;rop r1],false
-];;
-deduce test2;;
-unsolvable test2;;
-
-*)
+++ /dev/null
-type rational = { num : int; den : int; }
-val print_rational : rational -> unit
-val pgcd : int -> int -> int
-val r0 : rational
-val r1 : rational
-val rnorm : rational -> rational
-val rop : rational -> rational
-val rplus : rational -> rational -> rational
-val rminus : rational -> rational -> rational
-val rmult : rational -> rational -> rational
-val rinv : rational -> rational
-val rdiv : rational -> rational -> rational
-val rinf : rational -> rational -> bool
-val rinfeq : rational -> rational -> bool
-type ineq = { coef : rational list; hist : rational list; strict : bool; }
-val pop : 'a -> 'a list ref -> unit
-val partitionne : ineq list -> ineq list list
-val add_hist : (rational list * bool) list -> ineq list
-val ie_add : ineq -> ineq -> ineq
-val ie_emult : rational -> ineq -> ineq
-val ie_tl : ineq -> ineq
-val hd_coef : ineq -> rational
-val deduce_add : ineq list -> ineq list -> ineq list
-val deduce1 : ineq list -> int -> ineq list
-val deduce : (rational list * bool) list -> ineq list
-val unsolvable :
- (rational list * bool) list -> (rational * bool * rational list) list
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-
-(******************** THE FOURIER TACTIC ***********************)
-
-(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients
-des inéquations et équations sont entiers. En attendant la tactique Field.
-*)
-
-open Fourier
-open ProofEngineTypes
-
-
-let debug x = print_string ("____ "^x) ; flush stdout;;
-
-let debug_pcontext x =
- let str = ref "" in
- List.iter (fun y -> match y with Some(Cic.Name(a),_) -> str := !str ^
- a ^ " " | _ ->()) x ;
- debug ("contesto : "^ (!str) ^ "\n")
-;;
-
-(******************************************************************************
-Operations on linear combinations.
-
-Opérations sur les combinaisons linéaires affines.
-La partie homogène d'une combinaison linéaire est en fait une table de hash
-qui donne le coefficient d'un terme du calcul des constructions,
-qui est zéro si le terme n'y est pas.
-*)
-
-
-
-(**
- The type for linear combinations
-*)
-type flin = {fhom:(Cic.term , rational)Hashtbl.t;fcste:rational}
-;;
-
-(**
- @return an empty flin
-*)
-let flin_zero () = {fhom = Hashtbl.create 50;fcste=r0}
-;;
-
-(**
- @param f a flin
- @param x a Cic.term
- @return the rational associated with x (coefficient)
-*)
-let flin_coef f x =
- try
- (Hashtbl.find f.fhom x)
- with
- _ -> r0
-;;
-
-(**
- Adds c to the coefficient of x
- @param f a flin
- @param x a Cic.term
- @param c a rational
- @return the new flin
-*)
-let flin_add f x c =
- match x with
- Cic.Rel(n) ->(
- let cx = flin_coef f x in
- Hashtbl.remove f.fhom x;
- Hashtbl.add f.fhom x (rplus cx c);
- f)
- |_->debug ("Internal error in Fourier! this is not a Rel "^CicPp.ppterm x^"\n");
- let cx = flin_coef f x in
- Hashtbl.remove f.fhom x;
- Hashtbl.add f.fhom x (rplus cx c);
- f
-;;
-(**
- Adds c to f.fcste
- @param f a flin
- @param c a rational
- @return the new flin
-*)
-let flin_add_cste f c =
- {fhom=f.fhom;
- fcste=rplus f.fcste c}
-;;
-
-(**
- @return a empty flin with r1 in fcste
-*)
-let flin_one () = flin_add_cste (flin_zero()) r1;;
-
-(**
- Adds two flin
-*)
-let flin_plus f1 f2 =
- let f3 = flin_zero() in
- Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
- Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom;
- flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste;
-;;
-
-(**
- Substracts two flin
-*)
-let flin_minus f1 f2 =
- let f3 = flin_zero() in
- Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
- Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom;
- flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste);
-;;
-
-(**
- @return a times f
-*)
-let flin_emult a f =
- let f2 = flin_zero() in
- Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom;
- flin_add_cste f2 (rmult a f.fcste);
-;;
-
-
-(*****************************************************************************)
-
-
-(**
- @param t a term
- @raise Failure if conversion is impossible
- @return rational proiection of t
-*)
-let rec rational_of_term t =
- (* fun to apply f to the first and second rational-term of l *)
- let rat_of_binop f l =
- let a = List.hd l and
- b = List.hd(List.tl l) in
- f (rational_of_term a) (rational_of_term b)
- in
- (* as before, but f is unary *)
- let rat_of_unop f l =
- f (rational_of_term (List.hd l))
- in
- match t with
- | Cic.Cast (t1,t2) -> (rational_of_term t1)
- | Cic.Appl (t1::next) ->
- (match t1 with
- Cic.Const (u,boh) ->
- if UriManager.eq u HelmLibraryObjects.Reals.ropp_URI then
- rat_of_unop rop next
- else if UriManager.eq u HelmLibraryObjects.Reals.rinv_URI then
- rat_of_unop rinv next
- else if UriManager.eq u HelmLibraryObjects.Reals.rmult_URI then
- rat_of_binop rmult next
- else if UriManager.eq u HelmLibraryObjects.Reals.rdiv_URI then
- rat_of_binop rdiv next
- else if UriManager.eq u HelmLibraryObjects.Reals.rplus_URI then
- rat_of_binop rplus next
- else if UriManager.eq u HelmLibraryObjects.Reals.rminus_URI then
- rat_of_binop rminus next
- else failwith "not a rational"
- | _ -> failwith "not a rational")
- | Cic.Const (u,boh) ->
- if UriManager.eq u HelmLibraryObjects.Reals.r1_URI then r1
- else if UriManager.eq u HelmLibraryObjects.Reals.r0_URI then r0
- else failwith "not a rational"
- | _ -> failwith "not a rational"
-;;
-
-(* coq wrapper
-let rational_of_const = rational_of_term;;
-*)
-let fails f a =
- try
- ignore (f a);
- false
- with
- _-> true
- ;;
-
-let rec flin_of_term t =
- let fl_of_binop f l =
- let a = List.hd l and
- b = List.hd(List.tl l) in
- f (flin_of_term a) (flin_of_term b)
- in
- try(
- match t with
- | Cic.Cast (t1,t2) -> (flin_of_term t1)
- | Cic.Appl (t1::next) ->
- begin
- match t1 with
- Cic.Const (u,boh) ->
- begin
- if UriManager.eq u HelmLibraryObjects.Reals.ropp_URI then
- flin_emult (rop r1) (flin_of_term (List.hd next))
- else if UriManager.eq u HelmLibraryObjects.Reals.rplus_URI then
- fl_of_binop flin_plus next
- else if UriManager.eq u HelmLibraryObjects.Reals.rminus_URI then
- fl_of_binop flin_minus next
- else if UriManager.eq u HelmLibraryObjects.Reals.rmult_URI then
- begin
- let arg1 = (List.hd next) and
- arg2 = (List.hd(List.tl next))
- in
- if fails rational_of_term arg1
- then
- if fails rational_of_term arg2
- then
- ( (* prodotto tra 2 incognite ????? impossibile*)
- failwith "Sistemi lineari!!!!\n"
- )
- else
- (
- match arg1 with
- Cic.Rel(n) -> (*trasformo al volo*)
- (flin_add (flin_zero()) arg1 (rational_of_term arg2))
- |_-> (* test this *)
- let tmp = flin_of_term arg1 in
- flin_emult (rational_of_term arg2) (tmp)
- )
- else
- if fails rational_of_term arg2
- then
- (
- match arg2 with
- Cic.Rel(n) -> (*trasformo al volo*)
- (flin_add (flin_zero()) arg2 (rational_of_term arg1))
- |_-> (* test this *)
- let tmp = flin_of_term arg2 in
- flin_emult (rational_of_term arg1) (tmp)
-
- )
- else
- ( (*prodotto tra razionali*)
- (flin_add_cste (flin_zero()) (rmult (rational_of_term arg1) (rational_of_term arg2)))
- )
- (*try
- begin
- (*let a = rational_of_term arg1 in
- debug("ho fatto rational of term di "^CicPp.ppterm arg1^
- " e ho ottenuto "^string_of_int a.num^"/"^string_of_int a.den^"\n");*)
- let a = flin_of_term arg1
- try
- begin
- let b = (rational_of_term arg2) in
- debug("ho fatto rational of term di "^CicPp.ppterm arg2^
- " e ho ottenuto "^string_of_int b.num^"/"^string_of_int b.den^"\n");
- (flin_add_cste (flin_zero()) (rmult a b))
- end
- with
- _ -> debug ("ho fallito2 su "^CicPp.ppterm arg2^"\n");
- (flin_add (flin_zero()) arg2 a)
- end
- with
- _-> debug ("ho fallito1 su "^CicPp.ppterm arg1^"\n");
- (flin_add(flin_zero()) arg1 (rational_of_term arg2))
- *)
- end
- else if UriManager.eq u HelmLibraryObjects.Reals.rinv_URI then
- let a=(rational_of_term (List.hd next)) in
- flin_add_cste (flin_zero()) (rinv a)
- else if UriManager.eq u HelmLibraryObjects.Reals.rdiv_URI then
- begin
- let b=(rational_of_term (List.hd(List.tl next))) in
- try
- begin
- let a = (rational_of_term (List.hd next)) in
- (flin_add_cste (flin_zero()) (rdiv a b))
- end
- with
- _-> (flin_add (flin_zero()) (List.hd next) (rinv b))
- end
- else assert false
- end
- |_ -> assert false
- end
- | Cic.Const (u,boh) ->
- begin
- if UriManager.eq u HelmLibraryObjects.Reals.r1_URI then flin_one ()
- else if UriManager.eq u HelmLibraryObjects.Reals.r0_URI then flin_zero ()
- else assert false
- end
- |_-> assert false)
- with _ -> debug("eccezione = "^CicPp.ppterm t^"\n");flin_add (flin_zero()) t r1
-;;
-
-(* coq wrapper
-let flin_of_constr = flin_of_term;;
-*)
-
-(**
- Translates a flin to (c,x) list
- @param f a flin
- @return something like (c1,x1)::(c2,x2)::...::(cn,xn)
-*)
-let flin_to_alist f =
- let res=ref [] in
- Hashtbl.iter (fun x c -> res:=(c,x)::(!res)) f;
- !res
-;;
-
-(* Représentation des hypothèses qui sont des inéquations ou des équations.
-*)
-
-(**
- The structure for ineq
-*)
-type hineq={hname:Cic.term; (* le nom de l'hypothèse *)
- htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *)
- hleft:Cic.term;
- hright:Cic.term;
- hflin:flin;
- hstrict:bool}
-;;
-
-(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0
-*)
-
-let ineq1_of_term (h,t) =
- match t with (* match t *)
- Cic.Appl (t1::next) ->
- let arg1= List.hd next in
- let arg2= List.hd(List.tl next) in
- (match t1 with (* match t1 *)
- Cic.Const (u,boh) ->
- if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI then
- [{hname=h;
- htype="Rlt";
- hleft=arg1;
- hright=arg2;
- hflin= flin_minus (flin_of_term arg1)
- (flin_of_term arg2);
- hstrict=true}]
- else if UriManager.eq u HelmLibraryObjects.Reals.rgt_URI then
- [{hname=h;
- htype="Rgt";
- hleft=arg2;
- hright=arg1;
- hflin= flin_minus (flin_of_term arg2)
- (flin_of_term arg1);
- hstrict=true}]
- else if UriManager.eq u HelmLibraryObjects.Reals.rle_URI then
- [{hname=h;
- htype="Rle";
- hleft=arg1;
- hright=arg2;
- hflin= flin_minus (flin_of_term arg1)
- (flin_of_term arg2);
- hstrict=false}]
- else if UriManager.eq u HelmLibraryObjects.Reals.rge_URI then
- [{hname=h;
- htype="Rge";
- hleft=arg2;
- hright=arg1;
- hflin= flin_minus (flin_of_term arg2)
- (flin_of_term arg1);
- hstrict=false}]
- else assert false
- | Cic.MutInd (u,i,o) ->
- if UriManager.eq u HelmLibraryObjects.Logic.eq_URI then
- let t0= arg1 in
- let arg1= arg2 in
- let arg2= List.hd(List.tl (List.tl next)) in
- (match t0 with
- Cic.Const (u,boh) ->
- if UriManager.eq u HelmLibraryObjects.Reals.r_URI then
- [{hname=h;
- htype="eqTLR";
- hleft=arg1;
- hright=arg2;
- hflin= flin_minus (flin_of_term arg1)
- (flin_of_term arg2);
- hstrict=false};
- {hname=h;
- htype="eqTRL";
- hleft=arg2;
- hright=arg1;
- hflin= flin_minus (flin_of_term arg2)
- (flin_of_term arg1);
- hstrict=false}]
- else assert false
- |_-> assert false)
- else assert false
- |_-> assert false)(* match t1 *)
- |_-> assert false (* match t *)
-;;
-(* coq wrapper
-let ineq1_of_constr = ineq1_of_term;;
-*)
-
-(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq)
-*)
-
-let rec print_rl l =
- match l with
- []-> ()
- | a::next -> Fourier.print_rational a ; print_string " " ; print_rl next
-;;
-
-let rec print_sys l =
- match l with
- [] -> ()
- | (a,b)::next -> (print_rl a;
- print_string (if b=true then "strict\n"else"\n");
- print_sys next)
- ;;
-
-(*let print_hash h =
- Hashtbl.iter (fun x y -> print_string ("("^"-"^","^"-"^")")) h
-;;*)
-
-let fourier_lineq lineq1 =
- let nvar=ref (-1) in
- let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *)
- List.iter (fun f ->
- Hashtbl.iter (fun x c ->
- try (Hashtbl.find hvar x;())
- with _-> nvar:=(!nvar)+1;
- Hashtbl.add hvar x (!nvar);
- debug("aggiungo una var "^
- string_of_int !nvar^" per "^
- CicPp.ppterm x^"\n"))
- f.hflin.fhom)
- lineq1;
- (*print_hash hvar;*)
- debug("Il numero di incognite e' "^string_of_int (!nvar+1)^"\n");
- let sys= List.map (fun h->
- let v=Array.create ((!nvar)+1) r0 in
- Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x) <- c)
- h.hflin.fhom;
- ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict))
- lineq1 in
- debug ("chiamo unsolvable sul sistema di "^
- string_of_int (List.length sys) ^"\n");
- print_sys sys;
- unsolvable sys
-;;
-
-(*****************************************************************************
-Construction de la preuve en cas de succès de la méthode de Fourier,
-i.e. on obtient une contradiction.
-*)
-
-
-let _eqT = Cic.MutInd(HelmLibraryObjects.Logic.eq_URI, 0, []) ;;
-let _False = Cic.MutInd (HelmLibraryObjects.Logic.false_URI, 0, []) ;;
-let _not = Cic.Const (HelmLibraryObjects.Logic.not_URI,[]);;
-let _R0 = Cic.Const (HelmLibraryObjects.Reals.r0_URI,[]);;
-let _R1 = Cic.Const (HelmLibraryObjects.Reals.r1_URI,[]);;
-let _R = Cic.Const (HelmLibraryObjects.Reals.r_URI,[]);;
-let _Rfourier_eqLR_to_le=Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_eqLR_to_le.con"), []) ;;
-let _Rfourier_eqRL_to_le=Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_eqRL_to_le.con"), []) ;;
-let _Rfourier_ge_to_le =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_ge_to_le.con"), []) ;;
-let _Rfourier_gt_to_lt =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_gt_to_lt.con"), []) ;;
-let _Rfourier_le=Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_le.con"), []) ;;
-let _Rfourier_le_le =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_le_le.con"), []) ;;
-let _Rfourier_le_lt =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_le_lt.con"), []) ;;
-let _Rfourier_lt=Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_lt.con"), []) ;;
-let _Rfourier_lt_le =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_lt_le.con"), []) ;;
-let _Rfourier_lt_lt =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_lt_lt.con"), []) ;;
-let _Rfourier_not_ge_lt = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_not_ge_lt.con"), []) ;;
-let _Rfourier_not_gt_le = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_not_gt_le.con"), []) ;;
-let _Rfourier_not_le_gt = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_not_le_gt.con"), []) ;;
-let _Rfourier_not_lt_ge = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rfourier_not_lt_ge.con"), []) ;;
-let _Rinv = Cic.Const (HelmLibraryObjects.Reals.rinv_URI, []);;
-let _Rinv_R1 = Cic.Const(HelmLibraryObjects.Reals.rinv_r1_URI, []);;
-let _Rle = Cic.Const (HelmLibraryObjects.Reals.rle_URI, []);;
-let _Rle_mult_inv_pos = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rle_mult_inv_pos.con"), []) ;;
-let _Rle_not_lt = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rle_not_lt.con"), []) ;;
-let _Rle_zero_1 = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rle_zero_1.con"), []) ;;
-let _Rle_zero_pos_plus1 = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rle_zero_pos_plus1.con"), []) ;;
-let _Rlt = Cic.Const (HelmLibraryObjects.Reals.rlt_URI, []);;
-let _Rlt_mult_inv_pos = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rlt_mult_inv_pos.con"), []) ;;
-let _Rlt_not_le = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rlt_not_le.con"), []) ;;
-let _Rlt_zero_1 = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rlt_zero_1.con"), []) ;;
-let _Rlt_zero_pos_plus1 = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rlt_zero_pos_plus1.con"), []) ;;
-let _Rminus = Cic.Const (HelmLibraryObjects.Reals.rminus_URI, []);;
-let _Rmult = Cic.Const (HelmLibraryObjects.Reals.rmult_URI, []);;
-let _Rnot_le_le =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rnot_le_le.con"), []) ;;
-let _Rnot_lt0 = Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rnot_lt0.con"), []) ;;
-let _Rnot_lt_lt =Cic.Const ((UriManager.uri_of_string
- "cic:/Coq/fourier/Fourier_util/Rnot_lt_lt.con"), []) ;;
-let _Ropp = Cic.Const (HelmLibraryObjects.Reals.ropp_URI, []);;
-let _Rplus = Cic.Const (HelmLibraryObjects.Reals.rplus_URI, []);;
-
-(******************************************************************************)
-
-let is_int x = (x.den)=1
-;;
-
-(* fraction = couple (num,den) *)
-let rec rational_to_fraction x= (x.num,x.den)
-;;
-
-(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1)))
-*)
-
-let rec int_to_real_aux n =
- match n with
- 0 -> _R0 (* o forse R0 + R0 ????? *)
- | 1 -> _R1
- | _ -> Cic.Appl [ _Rplus ; _R1 ; int_to_real_aux (n-1) ]
-;;
-
-
-let int_to_real n =
- let x = int_to_real_aux (abs n) in
- if n < 0 then
- Cic.Appl [ _Ropp ; x ]
- else
- x
-;;
-
-
-(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1)))
-*)
-
-let rational_to_real x =
- let (n,d)=rational_to_fraction x in
- Cic.Appl [ _Rmult ; int_to_real n ; Cic.Appl [ _Rinv ; int_to_real d ] ]
-;;
-
-(* preuve que 0<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 (apply_tactic (PrimitiveTactics.apply_tac ~term:_Rle_not_lt)))
- ~continuation:(tac_zero_infeq_pos gl (-n,d)))
- status
- in
- mk_tactic (tac_zero_inf_false gl (n,d))
-;;
-
-(* preuve que 0<=n*(1/d) => False ; n est negatif
-*)
-
-let tac_zero_infeq_false gl (n,d) =
- let tac_zero_infeq_false gl (n,d) status =
- let (proof, goal) = status in
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
-
- debug("faccio fold di " ^ CicPp.ppterm
- (Cic.Appl
- [_Rle ; _R0 ;
- Cic.Appl
- [_Rmult ; int_to_real n ; Cic.Appl [_Rinv ; int_to_real d]]
- ]
- ) ^ "\n") ;
- debug("apply di _Rlt_not_le a "^ CicPp.ppterm ty ^"\n");
- (*CSC: Patch to undo the over-simplification of RewriteSimpl *)
- apply_tactic
- (Tacticals.then_
- ~start:
- (ReductionTactics.fold_tac
- ~reduction:(const_lazy_reduction CicReduction.whd)
- ~pattern:(ProofEngineTypes.conclusion_pattern None)
- ~term:
- (const_lazy_term
- (Cic.Appl
- [_Rle ; _R0 ;
- Cic.Appl
- [_Rmult ; int_to_real n ; Cic.Appl [_Rinv ; int_to_real d]]])))
- ~continuation:
- (Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:_Rlt_not_le)
- ~continuation:(tac_zero_inf_pos (-n,d))))
- status
- in
- mk_tactic (tac_zero_infeq_false gl (n,d))
-;;
-
-
-(* *********** ********** ******** ??????????????? *********** **************)
-
-let apply_type_tac ~cast:t ~applist:al =
- let apply_type_tac ~cast:t ~applist:al (proof,goal) =
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- let metasenv' = (fresh_meta,context,t)::metasenv in
- let proof' = curi,metasenv',pbo,pty in
- let proof'',goals =
- apply_tactic
- (PrimitiveTactics.apply_tac
- (*~term:(Cic.Appl ((Cic.Cast (Cic.Meta (fresh_meta,irl),t))::al)) *)
- ~term:(Cic.Appl ((Cic.Meta (fresh_meta,irl))::al))) (* ??? *)
- (proof',goal)
- in
- proof'',fresh_meta::goals
- in
- mk_tactic (apply_type_tac ~cast:t ~applist:al)
-;;
-
-let my_cut ~term:c =
- let my_cut ~term:c (proof,goal) =
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- let metasenv' = (fresh_meta,context,c)::metasenv in
- let proof' = curi,metasenv',pbo,pty in
- let proof'',goals =
- apply_tactic
- (apply_type_tac
- ~cast:(Cic.Prod(Cic.Name "Anonymous",c,CicSubstitution.lift 1 ty))
- ~applist:[Cic.Meta(fresh_meta,irl)])
- (proof',goal)
- in
- (* We permute the generated goals to be consistent with Coq *)
- match goals with
- [] -> assert false
- | he::tl -> proof'',he::fresh_meta::tl
- in
- mk_tactic (my_cut ~term:c)
-;;
-
-let exact = PrimitiveTactics.exact_tac;;
-
-let tac_use h =
- let tac_use h status =
- let (proof, goal) = status in
- debug("Inizio TC_USE\n");
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- debug ("hname = "^ CicPp.ppterm h.hname ^"\n");
- debug ("ty = "^ CicPp.ppterm ty^"\n");
- apply_tactic
- (match h.htype with
- "Rlt" -> exact ~term:h.hname
- | "Rle" -> exact ~term:h.hname
- | "Rgt" -> (Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_gt_to_lt)
- ~continuation:(exact ~term:h.hname))
- | "Rge" -> (Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_ge_to_le)
- ~continuation:(exact ~term:h.hname))
- | "eqTLR" -> (Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_eqLR_to_le)
- ~continuation:(exact ~term:h.hname))
- | "eqTRL" -> (Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_eqRL_to_le)
- ~continuation:(exact ~term:h.hname))
- | _->assert false)
- status
- in
- mk_tactic (tac_use h)
-;;
-
-let is_ineq (h,t) =
- match t with
- Cic.Appl ( Cic.Const(u,boh)::next) ->
- (if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI or
- UriManager.eq u HelmLibraryObjects.Reals.rgt_URI or
- UriManager.eq u HelmLibraryObjects.Reals.rle_URI or
- UriManager.eq u HelmLibraryObjects.Reals.rge_URI then true
- else if UriManager.eq u HelmLibraryObjects.Logic.eq_URI then
- (match (List.hd next) with
- Cic.Const (uri,_) when
- UriManager.eq uri HelmLibraryObjects.Reals.r_URI
- -> true
- | _ -> false)
- else false)
- |_->false
-;;
-
-let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;;
-
-let mkAppL a =
- Cic.Appl(Array.to_list a)
-;;
-
-(* Résolution d'inéquations linéaires dans R *)
-let rec strip_outer_cast c = match c with
- | Cic.Cast (c,_) -> strip_outer_cast c
- | _ -> c
-;;
-
-(*let find_in_context id context =
- let rec find_in_context_aux c n =
- match c with
- [] -> failwith (id^" not found in context")
- | a::next -> (match a with
- Some (Cic.Name(name),_) when name = id -> n
- (*? magari al posto di _ qualcosaltro?*)
- | _ -> find_in_context_aux next (n+1))
- in
- find_in_context_aux context 1
-;;
-
-(* mi sembra quadratico *)
-let rec filter_real_hyp context cont =
- match context with
- [] -> []
- | Some(Cic.Name(h),Cic.Decl(t))::next -> (
- let n = find_in_context h cont in
- debug("assegno "^string_of_int n^" a "^CicPp.ppterm t^"\n");
- [(Cic.Rel(n),t)] @ filter_real_hyp next cont)
- | a::next -> debug(" no\n"); filter_real_hyp next cont
-;;*)
-
-let filter_real_hyp context _ =
- let rec filter_aux context num =
- match context with
- [] -> []
- | Some(Cic.Name(h),Cic.Decl(t))::next ->
- [(Cic.Rel(num),t)] @ filter_aux next (num+1)
- | a::next -> filter_aux next (num+1)
- in
- filter_aux context 1
-;;
-
-
-(* lifts everithing at the conclusion level *)
-let rec superlift c n=
- match c with
- [] -> []
- | Some(name,Cic.Decl(a))::next ->
- [Some(name,Cic.Decl(CicSubstitution.lift n a))]@ superlift next (n+1)
- | Some(name,Cic.Def(a,None))::next ->
- [Some(name,Cic.Def((CicSubstitution.lift n a),None))]@ superlift next (n+1)
- | Some(name,Cic.Def(a,Some ty))::next ->
- [Some(name,
- Cic.Def((CicSubstitution.lift n a),Some (CicSubstitution.lift n ty)))
- ] @ superlift next (n+1)
- | _::next -> superlift next (n+1) (*?? ??*)
-
-;;
-
-let equality_replace a b =
- let equality_replace a b status =
- debug("inizio EQ\n");
- let module C = Cic in
- let proof,goal = status in
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let a_eq_b = C.Appl [ _eqT ; _R ; a ; b ] in
- let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- let metasenv' = (fresh_meta,context,a_eq_b)::metasenv in
- debug("chamo rewrite tac su"^CicPp.ppterm (C.Meta (fresh_meta,irl)));
- let (proof,goals) = apply_tactic
- (EqualityTactics.rewrite_simpl_tac
- ~direction:`LeftToRight
- ~pattern:(ProofEngineTypes.conclusion_pattern None)
- (C.Meta (fresh_meta,irl)))
- ((curi,metasenv',pbo,pty),goal)
- in
- let new_goals = fresh_meta::goals in
- debug("fine EQ -> goals : "^string_of_int( List.length new_goals) ^" = "
- ^string_of_int( List.length goals)^"+ meta\n");
- (proof,new_goals)
- in
- mk_tactic (equality_replace a b)
-;;
-
-let tcl_fail a (proof,goal) =
- match a with
- 1 -> raise (ProofEngineTypes.Fail (lazy "fail-tactical"))
- | _ -> (proof,[goal])
-;;
-
-(* Galla: moved in variousTactics.ml
-let assumption_tac (proof,goal)=
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let num = ref 0 in
- let tac_list = List.map
- ( fun x -> num := !num + 1;
- match x with
- Some(Cic.Name(nm),t) -> (nm,exact ~term:(Cic.Rel(!num)))
- | _ -> ("fake",tcl_fail 1)
- )
- context
- in
- Tacticals.first ~tactics:tac_list (proof,goal)
-;;
-*)
-(* Galla: moved in negationTactics.ml
-(* !!!!! fix !!!!!!!!!! *)
-let contradiction_tac (proof,goal)=
- Tacticals.then_
- (*inutile sia questo che quello prima della chiamata*)
- ~start:PrimitiveTactics.intros_tac
- ~continuation:(Tacticals.then_
- ~start:(VariousTactics.elim_type_tac ~term:_False)
- ~continuation:(assumption_tac))
- (proof,goal)
-;;
-*)
-
-(* ********************* TATTICA ******************************** *)
-
-let rec fourier (s_proof,s_goal)=
- let s_curi,s_metasenv,s_pbo,s_pty = s_proof in
- let s_metano,s_context,s_ty = CicUtil.lookup_meta s_goal s_metasenv in
- debug ("invoco fourier_tac sul goal "^string_of_int(s_goal)^" e contesto:\n");
- debug_pcontext s_context;
-
-(* here we need to negate the thesis, but to do this we need to apply the
- right theoreme,so let's parse our thesis *)
-
- let th_to_appl = ref _Rfourier_not_le_gt in
- (match s_ty with
- Cic.Appl ( Cic.Const(u,boh)::args) ->
- th_to_appl :=
- (if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI then
- _Rfourier_not_ge_lt
- else if UriManager.eq u HelmLibraryObjects.Reals.rle_URI then
- _Rfourier_not_gt_le
- else if UriManager.eq u HelmLibraryObjects.Reals.rgt_URI then
- _Rfourier_not_le_gt
- else if UriManager.eq u HelmLibraryObjects.Reals.rge_URI then
- _Rfourier_not_lt_ge
- else failwith "fourier can't be applyed")
- |_-> failwith "fourier can't be applyed");
- (* fix maybe strip_outer_cast goes here?? *)
-
- (* now let's change our thesis applying the th and put it with hp *)
-
- let proof,gl = apply_tactic
- (Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:!th_to_appl)
- ~continuation:(PrimitiveTactics.intros_tac ()))
- (s_proof,s_goal)
- in
- let goal = if List.length gl = 1 then List.hd gl
- else failwith "a new goal" in
-
- debug ("port la tesi sopra e la nego. contesto :\n");
- debug_pcontext s_context;
-
- (* now we have all the right environment *)
-
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
-
- (* now we want to convert hp to inequations, but first we must lift
- everyting to thesis level, so that a variable has the save Rel(n)
- in each hp ( needed by ineq1_of_term ) *)
-
- (* ? fix if None ?????*)
- (* fix change superlift with a real name *)
-
- let l_context = superlift context 1 in
- let hyps = filter_real_hyp l_context l_context in
-
- debug ("trasformo in diseq. "^ string_of_int (List.length hyps)^" ipotesi\n");
-
- let lineq =ref [] in
-
- (* transform hyps into inequations *)
-
- List.iter (fun h -> try (lineq:=(ineq1_of_term h)@(!lineq))
- with _-> ())
- hyps;
-
- debug ("applico fourier a "^ string_of_int (List.length !lineq)^
- " disequazioni\n");
-
- let res=fourier_lineq (!lineq) in
- let tac=ref Tacticals.id_tac in
- if res=[] then
- (print_string "Tactic Fourier fails.\n";flush stdout;
- failwith "fourier_tac fails")
- else
- (
- match res with (*match res*)
- [(cres,sres,lc)]->
-
- (* in lc we have the coefficient to "reduce" the system *)
-
- print_string "Fourier's method can prove the goal...\n";flush stdout;
-
- debug "I coeff di moltiplicazione rit sono: ";
-
- let lutil=ref [] in
- List.iter
- (fun (h,c) -> if c<>r0 then (lutil:=(h,c)::(!lutil);
- (* DBG *)Fourier.print_rational(c);print_string " "(* DBG *))
- )
- (List.combine (!lineq) lc);
-
- print_string (" quindi lutil e' lunga "^
- string_of_int (List.length (!lutil))^"\n");
-
- (* on construit la combinaison linéaire des inéquation *)
-
- (match (!lutil) with (*match (!lutil) *)
- (h1,c1)::lutil ->
- debug ("elem di lutil ");Fourier.print_rational c1;print_string "\n";
-
- let s=ref (h1.hstrict) in
-
-
- let t1 = ref (Cic.Appl [_Rmult;rational_to_real c1;h1.hleft] ) in
- let t2 = ref (Cic.Appl [_Rmult;rational_to_real c1;h1.hright]) in
-
- List.iter (fun (h,c) ->
- s:=(!s)||(h.hstrict);
- t1:=(Cic.Appl [_Rplus;!t1;Cic.Appl
- [_Rmult;rational_to_real c;h.hleft ] ]);
- t2:=(Cic.Appl [_Rplus;!t2;Cic.Appl
- [_Rmult;rational_to_real c;h.hright] ]))
- lutil;
-
- let ineq=Cic.Appl [(if (!s) then _Rlt else _Rle);!t1;!t2 ] in
- let tc=rational_to_real cres in
-
-
-(* ora ho i termini che descrivono i passi di fourier per risolvere il sistema *)
-
- debug "inizio a costruire tac1\n";
- Fourier.print_rational(c1);
-
- let tac1=ref ( mk_tactic (fun status ->
- apply_tactic
- (if h1.hstrict then
- (Tacticals.thens
- ~start:(mk_tactic (fun status ->
- debug ("inizio t1 strict\n");
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- debug ("th = "^ CicPp.ppterm _Rfourier_lt ^"\n");
- debug ("ty = "^ CicPp.ppterm ty^"\n");
- apply_tactic
- (PrimitiveTactics.apply_tac ~term:_Rfourier_lt) status))
- ~continuations:[tac_use h1;
- tac_zero_inf_pos (rational_to_fraction c1)])
- else
- (Tacticals.thens
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_le)
- ~continuations:[tac_use h1;tac_zero_inf_pos
- (rational_to_fraction c1)]))
- status))
-
- in
- s:=h1.hstrict;
- List.iter (fun (h,c) ->
- (if (!s) then
- (if h.hstrict then
- (debug("tac1 1\n");
- tac1:=(Tacticals.thens
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_lt_lt)
- ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
- (rational_to_fraction c)]))
- else
- (debug("tac1 2\n");
- Fourier.print_rational(c1);
- tac1:=(Tacticals.thens
- ~start:(mk_tactic (fun status ->
- debug("INIZIO TAC 1 2\n");
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- debug ("th = "^ CicPp.ppterm _Rfourier_lt_le ^"\n");
- debug ("ty = "^ CicPp.ppterm ty^"\n");
- apply_tactic
- (PrimitiveTactics.apply_tac ~term:_Rfourier_lt_le)
- status))
- ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
- (rational_to_fraction c)])))
- else
- (if h.hstrict then
- (debug("tac1 3\n");
- tac1:=(Tacticals.thens
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_le_lt)
- ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
- (rational_to_fraction c)]))
- else
- (debug("tac1 4\n");
- tac1:=(Tacticals.thens
- ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_le_le)
- ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
- (rational_to_fraction c)]))));
- s:=(!s)||(h.hstrict)) (* end fun -> *)
- lutil;(*end List.iter*)
-
- let tac2 =
- if sres then
- tac_zero_inf_false goal (rational_to_fraction cres)
- else
- tac_zero_infeq_false goal (rational_to_fraction cres)
- in
- tac:=(Tacticals.thens
- ~start:(my_cut ~term:ineq)
- ~continuations:[Tacticals.then_
- ~start:( mk_tactic (fun status ->
- let (proof, goal) = status in
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- apply_tactic
- (ReductionTactics.change_tac
- ~pattern:(ProofEngineTypes.conclusion_pattern (Some ty))
- (const_lazy_term (Cic.Appl [ _not; ineq])))
- status))
- ~continuation:(Tacticals.then_
- ~start:(PrimitiveTactics.apply_tac ~term:
- (if sres then _Rnot_lt_lt else _Rnot_le_le))
- ~continuation:(Tacticals.thens
- ~start:(mk_tactic (fun status ->
- debug("t1 ="^CicPp.ppterm !t1 ^"t2 ="^
- CicPp.ppterm !t2 ^"tc="^ CicPp.ppterm tc^"\n");
- let r = apply_tactic
- (equality_replace (Cic.Appl [_Rminus;!t2;!t1] ) tc)
- status
- in
- (match r with (p,gl) ->
- debug("eq1 ritorna "^string_of_int(List.length gl)^"\n" ));
- r))
- ~continuations:[(Tacticals.thens
- ~start:(mk_tactic (fun status ->
- let r = apply_tactic
- (equality_replace (Cic.Appl[_Rinv;_R1]) _R1)
- status
- in
- (match r with (p,gl) ->
- debug("eq2 ritorna "^string_of_int(List.length gl)^"\n" ));
- r))
- ~continuations:
- [PrimitiveTactics.apply_tac ~term:_Rinv_R1;
- Tacticals.first
- ~tactics:[ "ring",Ring.ring_tac; "id", Tacticals.id_tac]
- ])
- ;(*Tacticals.id_tac*)
- Tacticals.then_
- ~start:(mk_tactic (fun status ->
- let (proof, goal) = status in
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- (* check if ty is of type *)
- let w1 =
- debug("qui c'e' gia' l'or "^CicPp.ppterm ty^"\n");
- (match ty with
- Cic.Prod (Cic.Anonymous,a,b) -> (Cic.Appl [_not;a])
- |_ -> assert false)
- in
- let r = apply_tactic
- (ReductionTactics.change_tac
- ~pattern:(ProofEngineTypes.conclusion_pattern (Some ty))
- (const_lazy_term w1)) status
- in
- debug("fine MY_CHNGE\n");
- r))
- ~continuation:(*PORTINGTacticals.id_tac*)tac2]))
- ;(*Tacticals.id_tac*)!tac1]);(*end tac:=*)
-
- |_-> assert false)(*match (!lutil) *)
- |_-> assert false); (*match res*)
- debug ("finalmente applico tac\n");
- (
- let r = apply_tactic !tac (proof,goal) in
- debug("\n\n]]]]]]]]]]]]]]]]]) That's all folks ([[[[[[[[[[[[[[[[[[[\n\n");r
-
- )
-;;
-
-let fourier_tac = mk_tactic fourier
-
-
+++ /dev/null
-(*
-val rewrite_tac: term:Cic.term -> ProofEngineTypes.tactic
-val rewrite_simpl_tac: term:Cic.term -> ProofEngineTypes.tactic
-*)
-val fourier_tac: ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val 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
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*********************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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
-;;
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*********************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Andrea Asperti *)
-(* 8/09/2004 *)
-(* *)
-(* *)
-(*********************************************************************)
-
-
-val not_a_duplicate : UriManager.uri -> bool
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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) ;;
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val constructor_tac: n:int -> ProofEngineTypes.tactic
-
-val exists_tac: ProofEngineTypes.tactic
-val split_tac: ProofEngineTypes.tactic
-val left_tac: ProofEngineTypes.tactic
-val right_tac: ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
-*
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-exception TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple
-exception NotAnInductiveTypeToEliminate
-
-let debug = false;;
-let debug_print =
- fun msg -> if debug then prerr_endline (Lazy.force msg) else ()
-
-
-let inside_obj = function
- | Cic.InductiveDefinition (l,params, nleft, _) ->
- (l,params,nleft)
- | _ -> raise (Invalid_argument "Errore in inside_obj")
-
-let term_to_list = function
- | Cic.Appl l -> l
- | _ -> raise (Invalid_argument "Errore in term_to_list")
-
-
-let rec baseuri_of_term = function
- | Cic.Appl l -> baseuri_of_term (List.hd l)
- | Cic.MutInd (baseuri, tyno, []) -> baseuri
- | _ -> raise (Invalid_argument "baseuri_of_term")
-
-
-(* prende il numero dei parametri sinistri, la lista dei parametri, la lista
-dei tipi dei parametri, il tipo del GOAL e costruisce il termine per la cut
-ossia DX1 = DX1 -> ... DXn=DXn -> GOALTY *)
-
-let rec foo_cut nleft l param_ty_l body uri_of_eq =
- if nleft > 0 then foo_cut (nleft-1) (List.tl l) (List.tl param_ty_l) body
- uri_of_eq
- else match l with
- | hd::tl -> Cic.Prod (Cic.Anonymous, Cic.Appl[Cic.MutInd (uri_of_eq ,0,[]);
- (List.hd param_ty_l) ; hd; hd], foo_cut nleft
- (List.map (CicSubstitution.lift 1) tl) (List.tl param_ty_l)
- (CicSubstitution.lift 1 body) uri_of_eq )
- | [] -> body
- ;;
-
-(* da una catena di prod costruisce una lista dei termini che lo compongono.*)
-let rec list_of_prod term =
-match term with
- | Cic.Prod (Cic.Anonymous,src,tgt) -> [src] @ (list_of_prod tgt)
- | _ -> [term]
-;;
-
-
-let rec cut_first n l =
- if n>0 then
- match l with
- | hd::tl -> cut_first (n-1) tl
- | [] -> []
- else l
-;;
-
-
-let rec cut_last l =
-match l with
- | hd::tl when tl != [] -> hd:: (cut_last tl)
- | _ -> []
-;;
-
-
-let foo_appl nleft nright_consno term uri =
- let l = [] in
- let a = ref l in
- for n = 1 to nleft do
- a := !a @ [(Cic.Implicit None)]
- done;
- a:= !a @ [term];
- for n = 1 to nright_consno do
- a := !a @ [(Cic.Implicit None)]
- done;
- Cic.Appl ([Cic.Const(uri,[])] @ !a @ [Cic.Rel 1]) (*L'ipotesi e' sempre Rel 1. (?) *)
-;;
-
-
-let rec foo_prod nright param_ty_l l l2 base_rel body uri_of_eq nleft termty
- isSetType term =
- match param_ty_l with
- | hd::tl -> Cic.Prod (
- Cic.Anonymous,
- Cic.Appl[Cic.MutInd(uri_of_eq,0,[]); hd; (List.hd l); Cic.Rel base_rel],
- foo_prod (nright-1) tl (List.map (CicSubstitution.lift 1) (List.tl l))
- (List.map (CicSubstitution.lift 1) l2)
- base_rel (CicSubstitution.lift 1 body)
- uri_of_eq nleft (CicSubstitution.lift 1 termty)
- isSetType (CicSubstitution.lift 1 term))
- | [] -> ProofEngineReduction.replace_lifting
- ~equality:(ProofEngineReduction.alpha_equivalence)
- ~what: (if isSetType
- then ((cut_first (1+nleft) (term_to_list termty) ) @ [term] )
- else (cut_first (1+nleft) (term_to_list termty) ) )
- ~with_what: (List.map (CicSubstitution.lift (-1)) l2)
- ~where:body
-(*TODO lo stesso sottotermine di body puo' essere sia sx che dx!*)
-;;
-
-let rec foo_lambda nright param_ty_l nright_ param_ty_l_ l l2 base_rel body
- uri_of_eq nleft termty isSetType ty_indty term =
- (*assert nright >0 *)
- match param_ty_l with
- | hd::tl ->Cic.Lambda (
- (Cic.Name ("lambda" ^ (string_of_int nright))),
- hd, (* typ *)
- foo_lambda (nright-1) tl nright_ param_ty_l_
- (List.map (CicSubstitution.lift 1) l)
- (List.map (CicSubstitution.lift 1) (l2 @ [Cic.Rel 1]))
- base_rel (CicSubstitution.lift 1 body)
- uri_of_eq nleft
- (CicSubstitution.lift 1 termty)
- isSetType ty_indty
- (CicSubstitution.lift 1 term))
- | [] when isSetType -> Cic.Lambda (
- (Cic.Name ("lambda" ^ (string_of_int nright))),
- (ProofEngineReduction.replace_lifting
- ~equality:(ProofEngineReduction.alpha_equivalence)
- ~what: (cut_first (1+nleft) (term_to_list termty) )
- ~with_what: (List.map (CicSubstitution.lift (-1)) l2)
- ~where:termty), (* tipo di H con i parametri destri sostituiti *)
- foo_prod nright_ param_ty_l_ (List.map (CicSubstitution.lift 1) l)
- (List.map (CicSubstitution.lift 1) (l2 @ [Cic.Rel 1]))
- (base_rel+1) (CicSubstitution.lift 1 body)
- uri_of_eq nleft
- (CicSubstitution.lift 1 termty) isSetType
- (CicSubstitution.lift 1 term))
- | [] -> foo_prod nright_ param_ty_l_ l l2 base_rel body uri_of_eq nleft
- termty isSetType term
-;;
-
-let inversion_tac ~term =
- let module T = CicTypeChecker in
- let module R = CicReduction in
- let module C = Cic in
- let module P = PrimitiveTactics in
- let module PET = ProofEngineTypes in
- let module PEH = ProofEngineHelpers in
- let inversion_tac ~term (proof, goal) =
- let (_,metasenv,_,_) = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let uri_of_eq = HelmLibraryObjects.Logic.eq_URI in
-
- (* dall'indice che indentifica il goal nel metasenv, ritorna il suo tipo, che
- e' la terza componente della relativa congettura *)
- let (_,_,body) = CicUtil.lookup_meta goal metasenv in
- (* estrae il tipo del termine(ipotesi) oggetto di inversion,
- di solito un Cic.Appl *)
- let termty,_ = T.type_of_aux' metasenv context term CicUniv.empty_ugraph in
- let uri = baseuri_of_term termty in
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- let l,params,nleft = inside_obj o in
- let (_,_,typeno,_) =
- match termty with
- C.MutInd (uri,typeno,exp_named_subst) -> (uri,exp_named_subst,typeno,[])
- | C.Appl ((C.MutInd (uri,typeno,exp_named_subst))::args) ->
- (uri,exp_named_subst,typeno,args)
- | _ -> raise NotAnInductiveTypeToEliminate
- in
- let eliminator_uri =
- let buri = UriManager.buri_of_uri uri in
- let name =
- match o with
- C.InductiveDefinition (tys,_,_,_) ->
- let (name,_,_,_) = List.nth tys typeno in
- name
- |_ -> assert false
- in
- let ext = "_ind" in
- UriManager.uri_of_string (buri ^ "/" ^ name ^ ext ^ ".con")
- in
- (* il tipo del tipo induttivo da cui viene l'ipotesi oggetto di inversione *)
- let (_,_,ty_indty,cons_list) = (List.hd l) in
- (*la lista di Cic.term ricavata dal tipo del tipo induttivo. *)
- let param_ty_l = list_of_prod ty_indty in
- let consno = List.length cons_list in
- let nright= (List.length param_ty_l)- (nleft+1) in
- let isSetType = ((Pervasives.compare
- (List.nth param_ty_l ((List.length param_ty_l)-1))
- (Cic.Sort Cic.Prop)) != 0)
- in
- (* eliminiamo la testa di termty, in quanto e' il nome del predicato e non un parametro.*)
- let cut_term = foo_cut nleft (List.tl (term_to_list termty))
- (list_of_prod ty_indty) body uri_of_eq in
- (* cut DXn=DXn \to GOAL *)
- let proof1,gl1 = PET.apply_tactic (P.cut_tac cut_term) (proof,goal) in
- (* apply Hcut ; reflexivity (su tutti i goals aperti da apply_tac) *)
- let proof2, gl2 = PET.apply_tactic
- (Tacticals.then_
- ~start: (P.apply_tac (C.Rel 1)) (* apply Hcut *)
- ~continuation: (EqualityTactics.reflexivity_tac)
- ) (proof1, (List.hd gl1))
- in
- (* apply (ledx_ind( lambda x. lambda y, ...)) *)
- let (t1,metasenv,t3,t4) = proof2 in
- let goal2 = List.hd (List.tl gl1) in
- let (metano,context,_) = CicUtil.lookup_meta goal2 metasenv in
- let cut_param_ty_l = (cut_first nleft (cut_last param_ty_l)) in
- (* la lista dei soli parametri destri *)
- let l= cut_first (1+nleft) (term_to_list termty) in
- let lambda_t = foo_lambda nright cut_param_ty_l nright cut_param_ty_l l []
- nright body uri_of_eq nleft termty isSetType ty_indty term in
- let t = foo_appl nleft (nright+consno) lambda_t eliminator_uri in
- debug_print (lazy ("Lambda_t: " ^ (CicPp.ppterm t)));
- debug_print (lazy ("Term: " ^ (CicPp.ppterm termty)));
- debug_print (lazy ("Body: " ^ (CicPp.ppterm body)));
- debug_print (lazy ("Right param: " ^ (CicPp.ppterm (Cic.Appl l))));
-
- let (ref_t,_,metasenv'',_) = CicRefine.type_of_aux' metasenv context t
- CicUniv.empty_ugraph
- in
- let proof2 = (t1,metasenv'',t3,t4) in
- let proof3,gl3 = PET.apply_tactic (P.apply_tac ref_t) (proof2, goal2) in
- let new_goals = ProofEngineHelpers.compare_metasenvs
- ~oldmetasenv:metasenv ~newmetasenv:metasenv''
- in
- let patched_new_goals =
- let (_,metasenv''',_,_) = proof3 in
- List.filter (function i -> List.exists (function (j,_,_) -> j=i) metasenv''')
- new_goals @ gl3
- in
- (*prerr_endline ("METASENV: " ^ CicMetaSubst.ppmetasenv metasenv []); DEBUG*)
- (proof3, patched_new_goals)
-in
-ProofEngineTypes.mk_tactic (inversion_tac ~term)
-;;
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val inversion_tac: term: Cic.term -> ProofEngineTypes.tactic
+++ /dev/null
-(* 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)
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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)
-;;
-*)
-
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val absurd_tac: term:Cic.term -> ProofEngineTypes.tactic
-val contradiction_tac: ProofEngineTypes.tactic
-
+++ /dev/null
-PACKAGE = dummy
-
-LOCALLINKOPTS = -package helm-cic_disambiguation,helm-content_pres,helm-grafite,helm-grafite_parser,helm-tactics
-
-include ../../../Makefile.defs
-include ../../Makefile.common
-
-all $(PACKAGE).cma :saturate
- @echo -n
-opt $(PACKAGE).cmxa:saturate.opt
- @echo -n
-
-saturate: saturate_main.ml $(LIBRARIES)
- @echo " OCAMLC $<"
- @$(OCAMLC) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $<
-saturate.opt: saturate_main.ml $(LIBRARIES)
- @echo " OCAMLOPT $<"
- @$(OCAMLOPT) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $<
-
-clean:
- rm -f saturate saturate.opt
-
-
+++ /dev/null
-make saturate per compilare l'eseguibile da riga di comando (make saturate.opt per la versione ottimizzata)
-
-./saturate -h per vedere una lista di parametri:
-
-./saturate: unknown option `-h'.
-Usage:
- -full Enable full mode
- -f Enable/disable full-reduction strategy (default: enabled)
- -r Weight-Age equality selection ratio (default: 4)
- -s symbols-based selection ratio (relative to the weight ratio, default: 0)
- -c Configuration file (for the db connection)
- -o Term ordering. Possible values are:
- kbo: Knuth-Bendix ordering
- nr-kbo: Non-recursive variant of kbo (default)
- lpo: Lexicographic path ordering
- -l Time limit in seconds (default: no limit)
- -w Maximal width (default: 3)
- -d Maximal depth (default: 3)
- -retrieve retrieve only
- -help Display this list of options
- --help Display this list of options
-
-
-./saturate -l 10 -demod-equalities
-
-dove -l 10 e` il timeout in secondi.
-
-Il programma legge da standard input il teorema, per esempio
-
-\forall n:nat.n + n = 2 * n
-\forall n:R.n + n = 2 * n
-\forall n:R.n+n=n+n
-
-l'input termina con una riga vuota (quindi basta un doppio invio alla fine)
-
-In output, oltre ai vari messaggi di debug, vengono stampati gli insiemi
-active e passive alla fine dell'esecuzione. Consiglio di redirigere l'output
-su file, per esempio usando tee:
-
-./saturate -l 10 -demod-equalities | tee output.txt
-
-Il formato di stampa e` quello per gli oggetti di tipo equality (usa la
-funzione Inference.string_of_equality)
-
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-module Index = Equality_indexing.DT (* discrimination tree based indexing *)
-(*
-module Index = Equality_indexing.DT (* path tree based indexing *)
-*)
-
-let debug_print = Utils.debug_print;;
-
-(*
-for debugging
-let check_equation env equation msg =
- let w, proof, (eq_ty, left, right, order), metas, args = equation in
- let metasenv, context, ugraph = env in
- let metasenv' = metasenv @ metas in
- try
- CicTypeChecker.type_of_aux' metasenv' context left ugraph;
- CicTypeChecker.type_of_aux' metasenv' context right ugraph;
- ()
- with
- CicUtil.Meta_not_found _ as exn ->
- begin
- prerr_endline msg;
- prerr_endline (CicPp.ppterm left);
- prerr_endline (CicPp.ppterm right);
- raise exn
- end
-*)
-
-type retrieval_mode = Matching | Unification;;
-
-let print_candidates mode term res =
- let _ =
- match mode with
- | Matching ->
- Printf.printf "| candidates Matching %s\n" (CicPp.ppterm term)
- | Unification ->
- Printf.printf "| candidates Unification %s\n" (CicPp.ppterm term)
- in
- print_endline
- (String.concat "\n"
- (List.map
- (fun (p, e) ->
- Printf.sprintf "| (%s, %s)" (Utils.string_of_pos p)
- (Inference.string_of_equality e))
- res));
- print_endline "|";
-;;
-
-
-let indexing_retrieval_time = ref 0.;;
-
-
-let apply_subst = CicMetaSubst.apply_subst
-
-let index = Index.index
-let remove_index = Index.remove_index
-let in_index = Index.in_index
-let empty = Index.empty
-let init_index = Index.init_index
-
-(* returns a list of all the equalities in the tree that are in relation
- "mode" with the given term, where mode can be either Matching or
- Unification.
-
- Format of the return value: list of tuples in the form:
- (position - Left or Right - of the term that matched the given one in this
- equality,
- equality found)
-
- Note that if equality is "left = right", if the ordering is left > right,
- the position will always be Left, and if the ordering is left < right,
- position will be Right.
-*)
-let get_candidates mode tree term =
- let t1 = Unix.gettimeofday () in
- let res =
- let s =
- match mode with
- | Matching -> Index.retrieve_generalizations tree term
- | Unification -> Index.retrieve_unifiables tree term
- in
- Index.PosEqSet.elements s
- in
- (* print_candidates mode term res; *)
-(* print_endline (Discrimination_tree.string_of_discrimination_tree tree); *)
-(* print_newline (); *)
- let t2 = Unix.gettimeofday () in
- indexing_retrieval_time := !indexing_retrieval_time +. (t2 -. t1);
- res
-;;
-
-
-let match_unif_time_ok = ref 0.;;
-let match_unif_time_no = ref 0.;;
-
-
-(*
- finds the first equality in the index that matches "term", of type "termty"
- termty can be Implicit if it is not needed. The result (one of the sides of
- the equality, actually) should be not greater (wrt the term ordering) than
- term
-
- Format of the return value:
-
- (term to substitute, [Cic.Rel 1 properly lifted - see the various
- build_newtarget functions inside the various
- demodulation_* functions]
- substitution used for the matching,
- metasenv,
- ugraph, [substitution, metasenv and ugraph have the same meaning as those
- returned by CicUnification.fo_unif]
- (equality where the matching term was found, [i.e. the equality to use as
- rewrite rule]
- uri [either eq_ind_URI or eq_ind_r_URI, depending on the direction of
- the equality: this is used to build the proof term, again see one of
- the build_newtarget functions]
- ))
-*)
-let rec find_matches metasenv context ugraph lift_amount term termty =
- let module C = Cic in
- let module U = Utils in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let cmp = !Utils.compare_terms in
- let check = match termty with C.Implicit None -> false | _ -> true in
- function
- | [] -> None
- | candidate::tl ->
- let pos, (_, proof, (ty, left, right, o), metas, args) = candidate in
- if check && not (fst (CicReduction.are_convertible
- ~metasenv context termty ty ugraph)) then (
- find_matches metasenv context ugraph lift_amount term termty tl
- ) else
- let do_match c eq_URI =
- let subst', metasenv', ugraph' =
- let t1 = Unix.gettimeofday () in
- try
- let r =
- Inference.matching (metasenv @ metas) context
- term (S.lift lift_amount c) ugraph
- in
- let t2 = Unix.gettimeofday () in
- match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1);
- r
- with
- | Inference.MatchingFailure as e ->
- let t2 = Unix.gettimeofday () in
- match_unif_time_no := !match_unif_time_no +. (t2 -. t1);
- raise e
- | CicUtil.Meta_not_found _ as exn ->
- prerr_endline "zurg";
- raise exn
- in
- Some (C.Rel (1 + lift_amount), subst', metasenv', ugraph',
- (candidate, eq_URI))
- in
- let c, other, eq_URI =
- if pos = Utils.Left then left, right, Utils.eq_ind_URI ()
- else right, left, Utils.eq_ind_r_URI ()
- in
- if o <> U.Incomparable then
- try
- do_match c eq_URI
- with Inference.MatchingFailure ->
- find_matches metasenv context ugraph lift_amount term termty tl
- else
- let res =
- try do_match c eq_URI
- with Inference.MatchingFailure -> None
- in
- match res with
- | Some (_, s, _, _, _) ->
- let c' = apply_subst s c in
- (*
- let other' = U.guarded_simpl context (apply_subst s other) in *)
- let other' = apply_subst s other in
- let order = cmp c' other' in
- if order = U.Gt then
- res
- else
- find_matches
- metasenv context ugraph lift_amount term termty tl
- | None ->
- find_matches metasenv context ugraph lift_amount term termty tl
-;;
-
-
-(*
- as above, but finds all the matching equalities, and the matching condition
- can be either Inference.matching or Inference.unification
-*)
-let rec find_all_matches ?(unif_fun=Inference.unification)
- metasenv context ugraph lift_amount term termty =
- let module C = Cic in
- let module U = Utils in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let cmp = !Utils.compare_terms in
- function
- | [] -> []
- | candidate::tl ->
- let pos, (_, _, (ty, left, right, o), metas, args) = candidate in
- let do_match c eq_URI =
- let subst', metasenv', ugraph' =
- let t1 = Unix.gettimeofday () in
- try
- let r =
- unif_fun (metasenv @ metas) context
- term (S.lift lift_amount c) ugraph in
- let t2 = Unix.gettimeofday () in
- match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1);
- r
- with
- | Inference.MatchingFailure
- | CicUnification.UnificationFailure _
- | CicUnification.Uncertain _ as e ->
- let t2 = Unix.gettimeofday () in
- match_unif_time_no := !match_unif_time_no +. (t2 -. t1);
- raise e
- in
- (C.Rel (1 + lift_amount), subst', metasenv', ugraph',
- (candidate, eq_URI))
- in
- let c, other, eq_URI =
- if pos = Utils.Left then left, right, Utils.eq_ind_URI ()
- else right, left, Utils.eq_ind_r_URI ()
- in
- if o <> U.Incomparable then
- try
- let res = do_match c eq_URI in
- res::(find_all_matches ~unif_fun metasenv context ugraph
- lift_amount term termty tl)
- with
- | Inference.MatchingFailure
- | CicUnification.UnificationFailure _
- | CicUnification.Uncertain _ ->
- find_all_matches ~unif_fun metasenv context ugraph
- lift_amount term termty tl
- else
- try
- let res = do_match c eq_URI in
- match res with
- | _, s, _, _, _ ->
- let c' = apply_subst s c
- and other' = apply_subst s other in
- let order = cmp c' other' in
- if order <> U.Lt && order <> U.Le then
- res::(find_all_matches ~unif_fun metasenv context ugraph
- lift_amount term termty tl)
- else
- find_all_matches ~unif_fun metasenv context ugraph
- lift_amount term termty tl
- with
- | Inference.MatchingFailure
- | CicUnification.UnificationFailure _
- | CicUnification.Uncertain _ ->
- find_all_matches ~unif_fun metasenv context ugraph
- lift_amount term termty tl
-;;
-
-
-(*
- returns true if target is subsumed by some equality in table
-*)
-let subsumption env table target =
- let _, _, (ty, left, right, _), tmetas, _ = target in
- let metasenv, context, ugraph = env in
- let metasenv = metasenv @ tmetas in
- let samesubst subst subst' =
- let tbl = Hashtbl.create (List.length subst) in
- List.iter (fun (m, (c, t1, t2)) -> Hashtbl.add tbl m (c, t1, t2)) subst;
- List.for_all
- (fun (m, (c, t1, t2)) ->
- try
- let c', t1', t2' = Hashtbl.find tbl m in
- if (c = c') && (t1 = t1') && (t2 = t2') then true
- else false
- with Not_found ->
- true)
- subst'
- in
- let leftr =
- match left with
- | Cic.Meta _ -> []
- | _ ->
- let leftc = get_candidates Matching table left in
- find_all_matches ~unif_fun:Inference.matching
- metasenv context ugraph 0 left ty leftc
- in
- let rec ok what = function
- | [] -> false, []
- | (_, subst, menv, ug, ((pos, (_, _, (_, l, r, o), m, _)), _))::tl ->
- try
- let other = if pos = Utils.Left then r else l in
- let subst', menv', ug' =
- let t1 = Unix.gettimeofday () in
- try
- let r =
- Inference.matching (metasenv @ menv @ m) context what other ugraph
- in
- let t2 = Unix.gettimeofday () in
- match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1);
- r
- with Inference.MatchingFailure as e ->
- let t2 = Unix.gettimeofday () in
- match_unif_time_no := !match_unif_time_no +. (t2 -. t1);
- raise e
- in
- if samesubst subst subst' then
- true, subst
- else
- ok what tl
- with Inference.MatchingFailure ->
- ok what tl
- in
- let r, subst = ok right leftr in
- let r, s =
- if r then
- true, subst
- else
- let rightr =
- match right with
- | Cic.Meta _ -> []
- | _ ->
- let rightc = get_candidates Matching table right in
- find_all_matches ~unif_fun:Inference.matching
- metasenv context ugraph 0 right ty rightc
- in
- ok left rightr
- in
-(* (if r then *)
-(* debug_print *)
-(* (lazy *)
-(* (Printf.sprintf "SUBSUMPTION! %s\n%s\n" *)
-(* (Inference.string_of_equality target) (Utils.print_subst s)))); *)
- r, s
-;;
-
-
-let rec demodulation_aux ?(typecheck=false)
- metasenv context ugraph table lift_amount term =
- (* Printf.eprintf "term = %s\n" (CicPp.ppterm term); *)
-
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let candidates = get_candidates Matching table term in
- match term with
- | C.Meta _ -> None
- | term ->
- let termty, ugraph =
- if typecheck then
- CicTypeChecker.type_of_aux' metasenv context term ugraph
- else
- C.Implicit None, ugraph
- in
- let res =
- find_matches metasenv context ugraph lift_amount term termty candidates
- in
- if res <> None then
- res
- else
- match term with
- | C.Appl l ->
- let res, ll =
- List.fold_left
- (fun (res, tl) t ->
- if res <> None then
- (res, tl @ [S.lift 1 t])
- else
- let r =
- demodulation_aux metasenv context ugraph table
- lift_amount t
- in
- match r with
- | None -> (None, tl @ [S.lift 1 t])
- | Some (rel, _, _, _, _) -> (r, tl @ [rel]))
- (None, []) l
- in (
- match res with
- | None -> None
- | Some (_, subst, menv, ug, eq_found) ->
- Some (C.Appl ll, subst, menv, ug, eq_found)
- )
- | C.Prod (nn, s, t) ->
- let r1 =
- demodulation_aux metasenv context ugraph table lift_amount s in (
- match r1 with
- | None ->
- let r2 =
- demodulation_aux metasenv
- ((Some (nn, C.Decl s))::context) ugraph
- table (lift_amount+1) t
- in (
- match r2 with
- | None -> None
- | Some (t', subst, menv, ug, eq_found) ->
- Some (C.Prod (nn, (S.lift 1 s), t'),
- subst, menv, ug, eq_found)
- )
- | Some (s', subst, menv, ug, eq_found) ->
- Some (C.Prod (nn, s', (S.lift 1 t)),
- subst, menv, ug, eq_found)
- )
- | C.Lambda (nn, s, t) ->
- let r1 =
- demodulation_aux metasenv context ugraph table lift_amount s in (
- match r1 with
- | None ->
- let r2 =
- demodulation_aux metasenv
- ((Some (nn, C.Decl s))::context) ugraph
- table (lift_amount+1) t
- in (
- match r2 with
- | None -> None
- | Some (t', subst, menv, ug, eq_found) ->
- Some (C.Lambda (nn, (S.lift 1 s), t'),
- subst, menv, ug, eq_found)
- )
- | Some (s', subst, menv, ug, eq_found) ->
- Some (C.Lambda (nn, s', (S.lift 1 t)),
- subst, menv, ug, eq_found)
- )
- | t ->
- None
-;;
-
-
-let build_newtarget_time = ref 0.;;
-
-
-let demod_counter = ref 1;;
-
-(** demodulation, when target is an equality *)
-let rec demodulation_equality newmeta env table sign target =
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let module U = Utils in
- let metasenv, context, ugraph = env in
- let w, proof, (eq_ty, left, right, order), metas, args = target in
- (* first, we simplify *)
- let right = U.guarded_simpl context right in
- let left = U.guarded_simpl context left in
- let w = Utils.compute_equality_weight eq_ty left right in
- let order = !Utils.compare_terms left right in
- let target = w, proof, (eq_ty, left, right, order), metas, args in
-
- let metasenv' = metasenv @ metas in
-
- let maxmeta = ref newmeta in
-
- let build_newtarget is_left (t, subst, menv, ug, (eq_found, eq_URI)) =
- let time1 = Unix.gettimeofday () in
-
- let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in
- let ty =
- try fst (CicTypeChecker.type_of_aux' metasenv context what ugraph)
- with CicUtil.Meta_not_found _ -> ty
- in
- let what, other = if pos = Utils.Left then what, other else other, what in
- let newterm, newproof =
- let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in
- let name = C.Name ("x_Demod_" ^ (string_of_int !demod_counter)) in
- incr demod_counter;
- let bo' =
- let l, r = if is_left then t, S.lift 1 right else S.lift 1 left, t in
- C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []);
- S.lift 1 eq_ty; l; r]
- in
- if sign = Utils.Positive then
- (bo,
- Inference.ProofBlock (
- subst, eq_URI, (name, ty), bo'(* t' *), eq_found, proof))
- else
- let metaproof =
- incr maxmeta;
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
-(* debug_print (lazy (Printf.sprintf "\nADDING META: %d\n" !maxmeta)); *)
-(* print_newline (); *)
- C.Meta (!maxmeta, irl)
- in
- let eq_found =
- let proof' =
- let termlist =
- if pos = Utils.Left then [ty; what; other]
- else [ty; other; what]
- in
- Inference.ProofSymBlock (termlist, proof')
- in
- let what, other =
- if pos = Utils.Left then what, other else other, what
- in
- pos, (0, proof', (ty, other, what, Utils.Incomparable),
- menv', args')
- in
- let target_proof =
- let pb =
- Inference.ProofBlock (subst, eq_URI, (name, ty), bo',
- eq_found, Inference.BasicProof metaproof)
- in
- match proof with
- | Inference.BasicProof _ ->
- print_endline "replacing a BasicProof";
- pb
- | Inference.ProofGoalBlock (_, parent_proof) ->
- print_endline "replacing another ProofGoalBlock";
- Inference.ProofGoalBlock (pb, parent_proof)
- | _ -> assert false
- in
- let refl =
- C.Appl [C.MutConstruct (* reflexivity *)
- (LibraryObjects.eq_URI (), 0, 1, []);
- eq_ty; if is_left then right else left]
- in
- (bo,
- Inference.ProofGoalBlock (Inference.BasicProof refl, target_proof))
- in
- let left, right = if is_left then newterm, right else left, newterm in
- let m =
- (Inference.metas_of_term left)
- @ (Inference.metas_of_term right)
- @ (Inference.metas_of_term eq_ty) in
- (* let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metas @ menv') *)
- let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metasenv' @ menv')
- and newargs = args
- in
- let ordering = !Utils.compare_terms left right in
-
- let time2 = Unix.gettimeofday () in
- build_newtarget_time := !build_newtarget_time +. (time2 -. time1);
-
- let res =
- let w = Utils.compute_equality_weight eq_ty left right in
- (w, newproof, (eq_ty, left, right, ordering), newmetasenv, newargs)
- in
- !maxmeta, res
- in
- let _ =
- try
- CicTypeChecker.type_of_aux' metasenv' context left ugraph;
- CicTypeChecker.type_of_aux' metasenv' context right ugraph;
- with
- CicUtil.Meta_not_found _ as exn ->
- begin
- prerr_endline "siamo in demodulation_equality 1";
- prerr_endline (CicPp.ppterm left);
- prerr_endline (CicPp.ppterm right);
- raise exn
- end
- in
- let res = demodulation_aux metasenv' context ugraph table 0 left in
- let newmeta, newtarget =
- match res with
- | Some t ->
- let newmeta, newtarget = build_newtarget true t in
- if (Inference.is_weak_identity (metasenv', context, ugraph) newtarget) ||
- (Inference.meta_convertibility_eq target newtarget) then
- newmeta, newtarget
- else
- demodulation_equality newmeta env table sign newtarget
- | None ->
- let res = demodulation_aux metasenv' context ugraph table 0 right in
- match res with
- | Some t ->
- let newmeta, newtarget = build_newtarget false t in
- if (Inference.is_weak_identity (metasenv', context, ugraph) newtarget) ||
- (Inference.meta_convertibility_eq target newtarget) then
- newmeta, newtarget
- else
- demodulation_equality newmeta env table sign newtarget
- | None ->
- newmeta, target
- in
- (* newmeta, newtarget *)
- newmeta,newtarget
-;;
-
-
-(**
- Performs the beta expansion of the term "term" w.r.t. "table",
- i.e. returns the list of all the terms t s.t. "(t term) = t2", for some t2
- in table.
-*)
-let rec betaexpand_term metasenv context ugraph table lift_amount term =
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let candidates = get_candidates Unification table term in
- let res, lifted_term =
- match term with
- | C.Meta (i, l) ->
- let l', lifted_l =
- List.fold_right
- (fun arg (res, lifted_tl) ->
- match arg with
- | Some arg ->
- let arg_res, lifted_arg =
- betaexpand_term metasenv context ugraph table
- lift_amount arg in
- let l1 =
- List.map
- (fun (t, s, m, ug, eq_found) ->
- (Some t)::lifted_tl, s, m, ug, eq_found)
- arg_res
- in
- (l1 @
- (List.map
- (fun (l, s, m, ug, eq_found) ->
- (Some lifted_arg)::l, s, m, ug, eq_found)
- res),
- (Some lifted_arg)::lifted_tl)
- | None ->
- (List.map
- (fun (r, s, m, ug, eq_found) ->
- None::r, s, m, ug, eq_found) res,
- None::lifted_tl)
- ) l ([], [])
- in
- let e =
- List.map
- (fun (l, s, m, ug, eq_found) ->
- (C.Meta (i, l), s, m, ug, eq_found)) l'
- in
- e, C.Meta (i, lifted_l)
-
- | C.Rel m ->
- [], if m <= lift_amount then C.Rel m else C.Rel (m+1)
-
- | C.Prod (nn, s, t) ->
- let l1, lifted_s =
- betaexpand_term metasenv context ugraph table lift_amount s in
- let l2, lifted_t =
- betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph
- table (lift_amount+1) t in
- let l1' =
- List.map
- (fun (t, s, m, ug, eq_found) ->
- C.Prod (nn, t, lifted_t), s, m, ug, eq_found) l1
- and l2' =
- List.map
- (fun (t, s, m, ug, eq_found) ->
- C.Prod (nn, lifted_s, t), s, m, ug, eq_found) l2 in
- l1' @ l2', C.Prod (nn, lifted_s, lifted_t)
-
- | C.Lambda (nn, s, t) ->
- let l1, lifted_s =
- betaexpand_term metasenv context ugraph table lift_amount s in
- let l2, lifted_t =
- betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph
- table (lift_amount+1) t in
- let l1' =
- List.map
- (fun (t, s, m, ug, eq_found) ->
- C.Lambda (nn, t, lifted_t), s, m, ug, eq_found) l1
- and l2' =
- List.map
- (fun (t, s, m, ug, eq_found) ->
- C.Lambda (nn, lifted_s, t), s, m, ug, eq_found) l2 in
- l1' @ l2', C.Lambda (nn, lifted_s, lifted_t)
-
- | C.Appl l ->
- let l', lifted_l =
- List.fold_right
- (fun arg (res, lifted_tl) ->
- let arg_res, lifted_arg =
- betaexpand_term metasenv context ugraph table lift_amount arg
- in
- let l1 =
- List.map
- (fun (a, s, m, ug, eq_found) ->
- a::lifted_tl, s, m, ug, eq_found)
- arg_res
- in
- (l1 @
- (List.map
- (fun (r, s, m, ug, eq_found) ->
- lifted_arg::r, s, m, ug, eq_found)
- res),
- lifted_arg::lifted_tl)
- ) l ([], [])
- in
- (List.map
- (fun (l, s, m, ug, eq_found) -> (C.Appl l, s, m, ug, eq_found)) l',
- C.Appl lifted_l)
-
- | t -> [], (S.lift lift_amount t)
- in
- match term with
- | C.Meta (i, l) -> res, lifted_term
- | term ->
- let termty, ugraph =
- C.Implicit None, ugraph
-(* CicTypeChecker.type_of_aux' metasenv context term ugraph *)
- in
- let r =
- find_all_matches
- metasenv context ugraph lift_amount term termty candidates
- in
- r @ res, lifted_term
-;;
-
-
-let sup_l_counter = ref 1;;
-
-(**
- superposition_left
- returns a list of new clauses inferred with a left superposition step
- the negative equation "target" and one of the positive equations in "table"
-*)
-let superposition_left newmeta (metasenv, context, ugraph) table target =
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let module CR = CicReduction in
- let module U = Utils in
- let weight, proof, (eq_ty, left, right, ordering), menv, _ = target in
- let expansions, _ =
- let term = if ordering = U.Gt then left else right in
- betaexpand_term metasenv context ugraph table 0 term
- in
- let maxmeta = ref newmeta in
- let build_new (bo, s, m, ug, (eq_found, eq_URI)) =
-
-(* debug_print (lazy "\nSUPERPOSITION LEFT\n"); *)
-
- let time1 = Unix.gettimeofday () in
-
- let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in
- let what, other = if pos = Utils.Left then what, other else other, what in
- let newgoal, newproof =
- let bo' = U.guarded_simpl context (apply_subst s (S.subst other bo)) in
- let name = C.Name ("x_SupL_" ^ (string_of_int !sup_l_counter)) in
- incr sup_l_counter;
- let bo'' =
- let l, r =
- if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in
- C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []);
- S.lift 1 eq_ty; l; r]
- in
- incr maxmeta;
- let metaproof =
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- C.Meta (!maxmeta, irl)
- in
- let eq_found =
- let proof' =
- let termlist =
- if pos = Utils.Left then [ty; what; other]
- else [ty; other; what]
- in
- Inference.ProofSymBlock (termlist, proof')
- in
- let what, other =
- if pos = Utils.Left then what, other else other, what
- in
- pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args')
- in
- let target_proof =
- let pb =
- Inference.ProofBlock (s, eq_URI, (name, ty), bo'', eq_found,
- Inference.BasicProof metaproof)
- in
- match proof with
- | Inference.BasicProof _ ->
-(* debug_print (lazy "replacing a BasicProof"); *)
- pb
- | Inference.ProofGoalBlock (_, parent_proof) ->
-(* debug_print (lazy "replacing another ProofGoalBlock"); *)
- Inference.ProofGoalBlock (pb, parent_proof)
- | _ -> assert false
- in
- let refl =
- C.Appl [C.MutConstruct (* reflexivity *)
- (LibraryObjects.eq_URI (), 0, 1, []);
- eq_ty; if ordering = U.Gt then right else left]
- in
- (bo',
- Inference.ProofGoalBlock (Inference.BasicProof refl, target_proof))
- in
- let left, right =
- if ordering = U.Gt then newgoal, right else left, newgoal in
- let neworder = !Utils.compare_terms left right in
-
- let time2 = Unix.gettimeofday () in
- build_newtarget_time := !build_newtarget_time +. (time2 -. time1);
-
- let res =
- let w = Utils.compute_equality_weight eq_ty left right in
- (w, newproof, (eq_ty, left, right, neworder), menv @ menv', [])
- in
- res
- in
- !maxmeta, List.map build_new expansions
-;;
-
-
-let sup_r_counter = ref 1;;
-
-(**
- superposition_right
- returns a list of new clauses inferred with a right superposition step
- between the positive equation "target" and one in the "table" "newmeta" is
- the first free meta index, i.e. the first number above the highest meta
- index: its updated value is also returned
-*)
-let superposition_right newmeta (metasenv, context, ugraph) table target =
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let module CR = CicReduction in
- let module U = Utils in
- let _, eqproof, (eq_ty, left, right, ordering), newmetas, args = target in
- let metasenv' = metasenv @ newmetas in
- let maxmeta = ref newmeta in
- let res1, res2 =
- match ordering with
- | U.Gt -> fst (betaexpand_term metasenv' context ugraph table 0 left), []
- | U.Lt -> [], fst (betaexpand_term metasenv' context ugraph table 0 right)
- | _ ->
- let res l r =
- List.filter
- (fun (_, subst, _, _, _) ->
- let subst = apply_subst subst in
- let o = !Utils.compare_terms (subst l) (subst r) in
- o <> U.Lt && o <> U.Le)
- (fst (betaexpand_term metasenv' context ugraph table 0 l))
- in
- (res left right), (res right left)
- in
- let build_new ordering (bo, s, m, ug, (eq_found, eq_URI)) =
-
- let time1 = Unix.gettimeofday () in
-
- let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in
- let what, other = if pos = Utils.Left then what, other else other, what in
- let newgoal, newproof =
- (* qua *)
- let bo' = Utils.guarded_simpl context (apply_subst s (S.subst other bo)) in
- let name = C.Name ("x_SupR_" ^ (string_of_int !sup_r_counter)) in
- incr sup_r_counter;
- let bo'' =
- let l, r =
- if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in
- C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []);
- S.lift 1 eq_ty; l; r]
- in
- bo',
- Inference.ProofBlock (s, eq_URI, (name, ty), bo'', eq_found, eqproof)
- in
- let newmeta, newequality =
- let left, right =
- if ordering = U.Gt then newgoal, apply_subst s right
- else apply_subst s left, newgoal in
- let neworder = !Utils.compare_terms left right
- and newmenv = newmetas @ menv'
- and newargs = args @ args' in
- let eq' =
- let w = Utils.compute_equality_weight eq_ty left right in
- (w, newproof, (eq_ty, left, right, neworder), newmenv, newargs) in
- let newm, eq' = Inference.fix_metas !maxmeta eq' in
- newm, eq'
- in
- maxmeta := newmeta;
-
- let time2 = Unix.gettimeofday () in
- build_newtarget_time := !build_newtarget_time +. (time2 -. time1);
-
- newequality
- in
- let new1 = List.map (build_new U.Gt) res1
- and new2 = List.map (build_new U.Lt) res2 in
-(*
- let ok e = not (Inference.is_identity (metasenv, context, ugraph) e) in
-*)
- let ok e = not (Inference.is_identity (metasenv', context, ugraph) e) in
- (!maxmeta,
- (List.filter ok (new1 @ new2)))
-;;
-
-
-(** demodulation, when the target is a goal *)
-let rec demodulation_goal newmeta env table goal =
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let metasenv, context, ugraph = env in
- let maxmeta = ref newmeta in
- let proof, metas, term = goal in
- let term = Utils.guarded_simpl (~debug:true) context term in
- let goal = proof, metas, term in
- let metasenv' = metasenv @ metas in
-
- let build_newgoal (t, subst, menv, ug, (eq_found, eq_URI)) =
- let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in
- let what, other = if pos = Utils.Left then what, other else other, what in
- let ty =
- try fst (CicTypeChecker.type_of_aux' metasenv context what ugraph)
- with CicUtil.Meta_not_found _ -> ty
- in
- let newterm, newproof =
- (* qua *)
- let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in
- let bo' = apply_subst subst t in
- let name = C.Name ("x_DemodGoal_" ^ (string_of_int !demod_counter)) in
- incr demod_counter;
- let metaproof =
- incr maxmeta;
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
-(* debug_print (lazy (Printf.sprintf "\nADDING META: %d\n" !maxmeta)); *)
- C.Meta (!maxmeta, irl)
- in
- let eq_found =
- let proof' =
- let termlist =
- if pos = Utils.Left then [ty; what; other]
- else [ty; other; what]
- in
- Inference.ProofSymBlock (termlist, proof')
- in
- let what, other =
- if pos = Utils.Left then what, other else other, what
- in
- pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args')
- in
- let goal_proof =
- let pb =
- Inference.ProofBlock (subst, eq_URI, (name, ty), bo',
- eq_found, Inference.BasicProof metaproof)
- in
- let rec repl = function
- | Inference.NoProof ->
-(* debug_print (lazy "replacing a NoProof"); *)
- pb
- | Inference.BasicProof _ ->
-(* debug_print (lazy "replacing a BasicProof"); *)
- pb
- | Inference.ProofGoalBlock (_, parent_proof) ->
-(* debug_print (lazy "replacing another ProofGoalBlock"); *)
- Inference.ProofGoalBlock (pb, parent_proof)
- | Inference.SubProof (term, meta_index, p) ->
- Inference.SubProof (term, meta_index, repl p)
- | _ -> assert false
- in repl proof
- in
- bo, Inference.ProofGoalBlock (Inference.NoProof, goal_proof)
- in
- let m = Inference.metas_of_term newterm in
- (* QUA *)
- let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (menv @ menv')in
- !maxmeta, (newproof, newmetasenv, newterm)
- in
- let res =
- demodulation_aux ~typecheck:true metasenv' context ugraph table 0 term
- in
- match res with
- | Some t ->
- let newmeta, newgoal = build_newgoal t in
- let _, _, newg = newgoal in
- if Inference.meta_convertibility term newg then
- newmeta, newgoal
- else
- demodulation_goal newmeta env table newgoal
- | None ->
- newmeta, goal
-;;
-
-
-(** demodulation, when the target is a theorem *)
-let rec demodulation_theorem newmeta env table theorem =
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let metasenv, context, ugraph = env in
- let maxmeta = ref newmeta in
- let term, termty, metas = theorem in
- let metasenv' = metasenv @ metas in
-
- let build_newtheorem (t, subst, menv, ug, (eq_found, eq_URI)) =
- let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in
- let what, other = if pos = Utils.Left then what, other else other, what in
- let newterm, newty =
- (* qua *)
- let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in
- let bo' = apply_subst subst t in
- let name = C.Name ("x_DemodThm_" ^ (string_of_int !demod_counter)) in
- incr demod_counter;
- let newproof =
- Inference.ProofBlock (subst, eq_URI, (name, ty), bo', eq_found,
- Inference.BasicProof term)
- in
- (Inference.build_proof_term newproof, bo)
- in
-
- let m = Inference.metas_of_term newterm in
- let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metas @ menv') in
- !maxmeta, (newterm, newty, newmetasenv)
- in
- let res =
- demodulation_aux ~typecheck:true metasenv' context ugraph table 0 termty
- in
- match res with
- | Some t ->
- let newmeta, newthm = build_newtheorem t in
- let newt, newty, _ = newthm in
- if Inference.meta_convertibility termty newty then
- newmeta, newthm
- else
- demodulation_theorem newmeta env table newthm
- | None ->
- newmeta, theorem
-;;
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-module Index :
- sig
- module PosEqSet : Set.S
- with type elt = Utils.pos * Inference.equality
- and type t = Equality_indexing.DT.PosEqSet.t
- type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t
- type key = Cic.term
- end
-
-val index : Index.t -> Inference.equality -> Index.t
-val remove_index : Index.t -> Inference.equality -> Index.t
-val in_index : Index.t -> Inference.equality -> bool
-val empty : Index.t
-val match_unif_time_ok : float ref
-val match_unif_time_no : float ref
-val indexing_retrieval_time : float ref
-val init_index : unit -> unit
-val build_newtarget_time : float ref
-val subsumption :
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- 'a * 'b * ('c * Index.key * Index.key * 'd) * Cic.metasenv * 'e ->
- bool * Cic.substitution
-val superposition_left :
- int ->
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- 'a * Inference.proof *
- (Index.key * Index.key * Index.key * Utils.comparison) * Cic.metasenv * 'c ->
- int *
- (int * Inference.proof *
- (Index.key * Index.key * Index.key * Utils.comparison) * Cic.metasenv *
- 'e list)
- list
-val superposition_right :
- int ->
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- 'a * Inference.proof *
- (Cic.term * Index.key * Index.key * Utils.comparison) *
- Cic.metasenv * Cic.term list -> int * Inference.equality list
-val demodulation_equality :
- int ->
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Utils.equality_sign -> Inference.equality -> int * Inference.equality
-val demodulation_goal :
- int ->
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Inference.proof * Cic.metasenv * Index.key ->
- int * (Inference.proof * Cic.metasenv * Index.key)
-val demodulation_theorem :
- 'a ->
- Cic.metasenv * Cic.context * CicUniv.universe_graph ->
- Index.t ->
- Cic.term * Index.key * Cic.metasenv ->
- 'a * (Cic.term * Index.key * Cic.metasenv)
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-open Utils;;
-
-
-type equality =
- int * (* weight *)
- proof *
- (Cic.term * (* type *)
- Cic.term * (* left side *)
- Cic.term * (* right side *)
- Utils.comparison) * (* ordering *)
- Cic.metasenv * (* environment for metas *)
- Cic.term list (* arguments *)
-
-and proof =
- | NoProof (* term is the goal missing a proof *)
- | BasicProof of Cic.term
- | ProofBlock of
- Cic.substitution * UriManager.uri *
- (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof
- | ProofGoalBlock of proof * proof
- | ProofSymBlock of Cic.term list * proof
- | SubProof of Cic.term * int * proof
-;;
-
-
-let string_of_equality ?env =
- match env with
- | None -> (
- function
- | w, _, (ty, left, right, o), _, _ ->
- Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.ppterm ty)
- (CicPp.ppterm left) (string_of_comparison o) (CicPp.ppterm right)
- )
- | Some (_, context, _) -> (
- let names = names_of_context context in
- function
- | w, _, (ty, left, right, o), _, _ ->
- Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.pp ty names)
- (CicPp.pp left names) (string_of_comparison o)
- (CicPp.pp right names)
- )
-;;
-
-
-let rec string_of_proof = function
- | NoProof -> "NoProof "
- | BasicProof t -> "BasicProof " ^ (CicPp.ppterm t)
- | SubProof (t, i, p) ->
- Printf.sprintf "SubProof(%s, %s, %s)"
- (CicPp.ppterm t) (string_of_int i) (string_of_proof p)
- | ProofSymBlock _ -> "ProofSymBlock"
- | ProofBlock _ -> "ProofBlock"
- | ProofGoalBlock (p1, p2) ->
- Printf.sprintf "ProofGoalBlock(%s, %s)"
- (string_of_proof p1) (string_of_proof p2)
-;;
-
-
-(* returns an explicit named subst and a list of arguments for sym_eq_URI *)
-let build_ens_for_sym_eq sym_eq_URI termlist =
- let obj, _ = CicEnvironment.get_obj CicUniv.empty_ugraph sym_eq_URI in
- match obj with
- | Cic.Constant (_, _, _, uris, _) ->
- assert (List.length uris <= List.length termlist);
- let rec aux = function
- | [], tl -> [], tl
- | (uri::uris), (term::tl) ->
- let ens, args = aux (uris, tl) in
- (uri, term)::ens, args
- | _, _ -> assert false
- in
- aux (uris, termlist)
- | _ -> assert false
-;;
-
-
-let build_proof_term ?(noproof=Cic.Implicit None) proof =
- let rec do_build_proof proof =
- match proof with
- | NoProof ->
- Printf.fprintf stderr "WARNING: no proof!\n";
- noproof
- | BasicProof term -> term
- | ProofGoalBlock (proofbit, proof) ->
- print_endline "found ProofGoalBlock, going up...";
- do_build_goal_proof proofbit proof
- | ProofSymBlock (termlist, proof) ->
- let proof = do_build_proof proof in
- let ens, args = build_ens_for_sym_eq (Utils.sym_eq_URI ()) termlist in
- Cic.Appl ([Cic.Const (Utils.sym_eq_URI (), ens)] @ args @ [proof])
- | ProofBlock (subst, eq_URI, (name, ty), bo, (pos, eq), eqproof) ->
- let t' = Cic.Lambda (name, ty, bo) in
- let proof' =
- let _, proof', _, _, _ = eq in
- do_build_proof proof'
- in
- let eqproof = do_build_proof eqproof in
- let _, _, (ty, what, other, _), menv', args' = eq in
- let what, other =
- if pos = Utils.Left then what, other else other, what
- in
- CicMetaSubst.apply_subst subst
- (Cic.Appl [Cic.Const (eq_URI, []); ty;
- what; t'; eqproof; other; proof'])
- | SubProof (term, meta_index, proof) ->
- let proof = do_build_proof proof in
- let eq i = function
- | Cic.Meta (j, _) -> i = j
- | _ -> false
- in
- ProofEngineReduction.replace
- ~equality:eq ~what:[meta_index] ~with_what:[proof] ~where:term
-
- and do_build_goal_proof proofbit proof =
- match proof with
- | ProofGoalBlock (pb, p) ->
- do_build_proof (ProofGoalBlock (replace_proof proofbit pb, p))
- | _ -> do_build_proof (replace_proof proofbit proof)
-
- and replace_proof newproof = function
- | ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof) ->
- let eqproof' = replace_proof newproof eqproof in
- ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof')
- | ProofGoalBlock (pb, p) ->
- let pb' = replace_proof newproof pb in
- ProofGoalBlock (pb', p)
- | BasicProof _ -> newproof
- | SubProof (term, meta_index, p) ->
- SubProof (term, meta_index, replace_proof newproof p)
- | p -> p
- in
- do_build_proof proof
-;;
-
-
-let rec metas_of_term = function
- | Cic.Meta (i, c) -> [i]
- | Cic.Var (_, ens)
- | Cic.Const (_, ens)
- | Cic.MutInd (_, _, ens)
- | Cic.MutConstruct (_, _, _, ens) ->
- List.flatten (List.map (fun (u, t) -> metas_of_term t) ens)
- | Cic.Cast (s, t)
- | Cic.Prod (_, s, t)
- | Cic.Lambda (_, s, t)
- | Cic.LetIn (_, s, t) -> (metas_of_term s) @ (metas_of_term t)
- | Cic.Appl l -> List.flatten (List.map metas_of_term l)
- | Cic.MutCase (uri, i, s, t, l) ->
- (metas_of_term s) @ (metas_of_term t) @
- (List.flatten (List.map metas_of_term l))
- | Cic.Fix (i, il) ->
- List.flatten
- (List.map (fun (s, i, t1, t2) ->
- (metas_of_term t1) @ (metas_of_term t2)) il)
- | Cic.CoFix (i, il) ->
- List.flatten
- (List.map (fun (s, t1, t2) ->
- (metas_of_term t1) @ (metas_of_term t2)) il)
- | _ -> []
-;;
-
-
-exception NotMetaConvertible;;
-
-let meta_convertibility_aux table t1 t2 =
- let module C = Cic in
- let rec aux ((table_l, table_r) as table) t1 t2 =
- match t1, t2 with
- | C.Meta (m1, tl1), C.Meta (m2, tl2) ->
- let m1_binding, table_l =
- try List.assoc m1 table_l, table_l
- with Not_found -> m2, (m1, m2)::table_l
- and m2_binding, table_r =
- try List.assoc m2 table_r, table_r
- with Not_found -> m1, (m2, m1)::table_r
- in
- if (m1_binding <> m2) || (m2_binding <> m1) then
- raise NotMetaConvertible
- else (
- try
- List.fold_left2
- (fun res t1 t2 ->
- match t1, t2 with
- | None, Some _ | Some _, None -> raise NotMetaConvertible
- | None, None -> res
- | Some t1, Some t2 -> (aux res t1 t2))
- (table_l, table_r) tl1 tl2
- with Invalid_argument _ ->
- raise NotMetaConvertible
- )
- | C.Var (u1, ens1), C.Var (u2, ens2)
- | C.Const (u1, ens1), C.Const (u2, ens2) when (UriManager.eq u1 u2) ->
- aux_ens table ens1 ens2
- | C.Cast (s1, t1), C.Cast (s2, t2)
- | C.Prod (_, s1, t1), C.Prod (_, s2, t2)
- | C.Lambda (_, s1, t1), C.Lambda (_, s2, t2)
- | C.LetIn (_, s1, t1), C.LetIn (_, s2, t2) ->
- let table = aux table s1 s2 in
- aux table t1 t2
- | C.Appl l1, C.Appl l2 -> (
- try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2
- with Invalid_argument _ -> raise NotMetaConvertible
- )
- | C.MutInd (u1, i1, ens1), C.MutInd (u2, i2, ens2)
- when (UriManager.eq u1 u2) && i1 = i2 -> aux_ens table ens1 ens2
- | C.MutConstruct (u1, i1, j1, ens1), C.MutConstruct (u2, i2, j2, ens2)
- when (UriManager.eq u1 u2) && i1 = i2 && j1 = j2 ->
- aux_ens table ens1 ens2
- | C.MutCase (u1, i1, s1, t1, l1), C.MutCase (u2, i2, s2, t2, l2)
- when (UriManager.eq u1 u2) && i1 = i2 ->
- let table = aux table s1 s2 in
- let table = aux table t1 t2 in (
- try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2
- with Invalid_argument _ -> raise NotMetaConvertible
- )
- | C.Fix (i1, il1), C.Fix (i2, il2) when i1 = i2 -> (
- try
- List.fold_left2
- (fun res (n1, i1, s1, t1) (n2, i2, s2, t2) ->
- if i1 <> i2 then raise NotMetaConvertible
- else
- let res = (aux res s1 s2) in aux res t1 t2)
- table il1 il2
- with Invalid_argument _ -> raise NotMetaConvertible
- )
- | C.CoFix (i1, il1), C.CoFix (i2, il2) when i1 = i2 -> (
- try
- List.fold_left2
- (fun res (n1, s1, t1) (n2, s2, t2) ->
- let res = aux res s1 s2 in aux res t1 t2)
- table il1 il2
- with Invalid_argument _ -> raise NotMetaConvertible
- )
- | t1, t2 when t1 = t2 -> table
- | _, _ -> raise NotMetaConvertible
-
- and aux_ens table ens1 ens2 =
- let cmp (u1, t1) (u2, t2) =
- compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2)
- in
- let ens1 = List.sort cmp ens1
- and ens2 = List.sort cmp ens2 in
- try
- List.fold_left2
- (fun res (u1, t1) (u2, t2) ->
- if not (UriManager.eq u1 u2) then raise NotMetaConvertible
- else aux res t1 t2)
- table ens1 ens2
- with Invalid_argument _ -> raise NotMetaConvertible
- in
- aux table t1 t2
-;;
-
-
-let meta_convertibility_eq eq1 eq2 =
- let _, _, (ty, left, right, _), _, _ = eq1
- and _, _, (ty', left', right', _), _, _ = eq2 in
- if ty <> ty' then
- false
- else if (left = left') && (right = right') then
- true
- else if (left = right') && (right = left') then
- true
- else
- try
- let table = meta_convertibility_aux ([], []) left left' in
- let _ = meta_convertibility_aux table right right' in
- true
- with NotMetaConvertible ->
- try
- let table = meta_convertibility_aux ([], []) left right' in
- let _ = meta_convertibility_aux table right left' in
- true
- with NotMetaConvertible ->
- false
-;;
-
-
-let meta_convertibility t1 t2 =
- if t1 = t2 then
- true
- else
- try
- ignore(meta_convertibility_aux ([], []) t1 t2);
- true
- with NotMetaConvertible ->
- false
-;;
-
-
-let rec check_irl start = function
- | [] -> true
- | None::tl -> check_irl (start+1) tl
- | (Some (Cic.Rel x))::tl ->
- if x = start then check_irl (start+1) tl else false
- | _ -> false
-;;
-
-
-let rec is_simple_term = function
- | Cic.Appl ((Cic.Meta _)::_) -> false
- | Cic.Appl l -> List.for_all is_simple_term l
- | Cic.Meta (i, l) -> check_irl 1 l
- | Cic.Rel _ -> true
- | Cic.Const _ -> true
- | Cic.MutInd (_, _, []) -> true
- | Cic.MutConstruct (_, _, _, []) -> true
- | _ -> false
-;;
-
-
-let lookup_subst meta subst =
- match meta with
- | Cic.Meta (i, _) -> (
- try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t
- with Not_found -> meta
- )
- | _ -> assert false
-;;
-
-
-let unification_simple metasenv context t1 t2 ugraph =
- let module C = Cic in
- let module M = CicMetaSubst in
- let module U = CicUnification in
- let lookup = lookup_subst in
- let rec occurs_check subst what where =
- match where with
- | t when what = t -> true
- | C.Appl l -> List.exists (occurs_check subst what) l
- | C.Meta _ ->
- let t = lookup where subst in
- if t <> where then occurs_check subst what t else false
- | _ -> false
- in
- let rec unif subst menv s t =
- let s = match s with C.Meta _ -> lookup s subst | _ -> s
- and t = match t with C.Meta _ -> lookup t subst | _ -> t
- in
- match s, t with
- | s, t when s = t -> subst, menv
- | C.Meta (i, _), C.Meta (j, _) when i > j ->
- unif subst menv t s
- | C.Meta _, t when occurs_check subst s t ->
- raise
- (U.UnificationFailure (lazy "Inference.unification.unif"))
- | C.Meta (i, l), t -> (
- try
- let _, _, ty = CicUtil.lookup_meta i menv in
- let subst =
- if not (List.mem_assoc i subst) then (i, (context, t, ty))::subst
- else subst
- in
- let menv = menv in (* List.filter (fun (m, _, _) -> i <> m) menv in *)
- subst, menv
- with CicUtil.Meta_not_found m ->
- let names = names_of_context context in
- debug_print
- (lazy
- (Printf.sprintf "Meta_not_found %d!: %s %s\n%s\n\n%s" m
- (CicPp.pp t1 names) (CicPp.pp t2 names)
- (print_metasenv menv) (print_metasenv metasenv)));
- assert false
- )
- | _, C.Meta _ -> unif subst menv t s
- | C.Appl (hds::_), C.Appl (hdt::_) when hds <> hdt ->
- raise (U.UnificationFailure (lazy "Inference.unification.unif"))
- | C.Appl (hds::tls), C.Appl (hdt::tlt) -> (
- try
- List.fold_left2
- (fun (subst', menv) s t -> unif subst' menv s t)
- (subst, menv) tls tlt
- with Invalid_argument _ ->
- raise (U.UnificationFailure (lazy "Inference.unification.unif"))
- )
- | _, _ ->
- raise (U.UnificationFailure (lazy "Inference.unification.unif"))
- in
- let subst, menv = unif [] metasenv t1 t2 in
- let menv =
- List.filter
- (fun (m, _, _) ->
- try let _ = List.find (fun (i, _) -> m = i) subst in false
- with Not_found -> true)
- menv
- in
- List.rev subst, menv, ugraph
-;;
-
-
-let unification metasenv context t1 t2 ugraph =
- let subst, menv, ug =
- if not (is_simple_term t1) || not (is_simple_term t2) then (
- debug_print
- (lazy
- (Printf.sprintf "NOT SIMPLE TERMS: %s %s"
- (CicPp.ppterm t1) (CicPp.ppterm t2)));
- CicUnification.fo_unif metasenv context t1 t2 ugraph
- ) else
- unification_simple metasenv context t1 t2 ugraph
- in
- let rec fix_term = function
- | (Cic.Meta (i, l) as t) ->
- let t' = lookup_subst t subst in
- if t <> t' then fix_term t' else t
- | Cic.Appl l -> Cic.Appl (List.map fix_term l)
- | t -> t
- in
- let rec fix_subst = function
- | [] -> []
- | (i, (c, t, ty))::tl -> (i, (c, fix_term t, fix_term ty))::(fix_subst tl)
- in
- fix_subst subst, menv, ug
-;;
-
-
-let unification = CicUnification.fo_unif;;
-
-exception MatchingFailure;;
-
-
-(*
-let matching_simple metasenv context t1 t2 ugraph =
- let module C = Cic in
- let module M = CicMetaSubst in
- let module U = CicUnification in
- let lookup meta subst =
- match meta with
- | C.Meta (i, _) -> (
- try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t
- with Not_found -> meta
- )
- | _ -> assert false
- in
- let rec do_match subst menv s t =
- match s, t with
- | s, t when s = t -> subst, menv
- | s, C.Meta (i, l) ->
- let filter_menv i menv =
- List.filter (fun (m, _, _) -> i <> m) menv
- in
- let subst, menv =
- let value = lookup t subst in
- match value with
- | value when value = t ->
- let _, _, ty = CicUtil.lookup_meta i menv in
- (i, (context, s, ty))::subst, filter_menv i menv
- | value when value <> s ->
- raise MatchingFailure
- | value -> do_match subst menv s value
- in
- subst, menv
- | C.Appl ls, C.Appl lt -> (
- try
- List.fold_left2
- (fun (subst, menv) s t -> do_match subst menv s t)
- (subst, menv) ls lt
- with Invalid_argument _ ->
- raise MatchingFailure
- )
- | _, _ ->
- raise MatchingFailure
- in
- let subst, menv = do_match [] metasenv t1 t2 in
- subst, menv, ugraph
-;;
-*)
-
-
-let matching metasenv context t1 t2 ugraph =
- try
- let subst, metasenv, ugraph =
-try
- unification metasenv context t1 t2 ugraph
-with CicUtil.Meta_not_found _ as exn ->
- Printf.eprintf "t1 == %s\nt2 = %s\nmetasenv == %s\n%!"
- (CicPp.ppterm t1) (CicPp.ppterm t2) (CicMetaSubst.ppmetasenv [] metasenv);
- raise exn
- in
- let t' = CicMetaSubst.apply_subst subst t1 in
- if not (meta_convertibility t1 t') then
- raise MatchingFailure
- else
- let metas = metas_of_term t1 in
- let fix_subst = function
- | (i, (c, Cic.Meta (j, lc), ty)) when List.mem i metas ->
- (j, (c, Cic.Meta (i, lc), ty))
- | s -> s
- in
- let subst = List.map fix_subst subst in
- subst, metasenv, ugraph
- with
- | CicUnification.UnificationFailure _
- | CicUnification.Uncertain _ ->
- raise MatchingFailure
-;;
-
-
-let find_equalities context proof =
- let module C = Cic in
- let module S = CicSubstitution in
- let module T = CicTypeChecker in
- let eq_uri = LibraryObjects.eq_URI () in
- let newmeta = ProofEngineHelpers.new_meta_of_proof ~proof in
- let ok_types ty menv =
- List.for_all (fun (_, _, mt) -> mt = ty) menv
- in
- let rec aux index newmeta = function
- | [] -> [], newmeta
- | (Some (_, C.Decl (term)))::tl ->
- let do_find context term =
- match term with
- | C.Prod (name, s, t) ->
- let (head, newmetas, args, newmeta) =
- ProofEngineHelpers.saturate_term newmeta []
- context (S.lift index term) 0
- in
- let p =
- if List.length args = 0 then
- C.Rel index
- else
- C.Appl ((C.Rel index)::args)
- in (
- match head with
- | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
- when (UriManager.eq uri eq_uri) && (ok_types ty newmetas) ->
- debug_print
- (lazy
- (Printf.sprintf "OK: %s" (CicPp.ppterm term)));
- let o = !Utils.compare_terms t1 t2 in
- let w = compute_equality_weight ty t1 t2 in
- let proof = BasicProof p in
- let e = (w, proof, (ty, t1, t2, o), newmetas, args) in
- Some e, (newmeta+1)
- | _ -> None, newmeta
- )
- | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
- when UriManager.eq uri eq_uri ->
- let t1 = S.lift index t1
- and t2 = S.lift index t2 in
- let o = !Utils.compare_terms t1 t2 in
- let w = compute_equality_weight ty t1 t2 in
- let e = (w, BasicProof (C.Rel index), (ty, t1, t2, o), [], []) in
- Some e, (newmeta+1)
- | _ -> None, newmeta
- in (
- match do_find context term with
- | Some p, newmeta ->
- let tl, newmeta' = (aux (index+1) newmeta tl) in
- if newmeta' < newmeta then
- prerr_endline "big trouble";
- (index, p)::tl, newmeta' (* max???? *)
- | None, _ ->
- aux (index+1) newmeta tl
- )
- | _::tl ->
- aux (index+1) newmeta tl
- in
- let il, maxm = aux 1 newmeta context in
- let indexes, equalities = List.split il in
- indexes, equalities, maxm
-;;
-
-
-(*
-let equations_blacklist =
- List.fold_left
- (fun s u -> UriManager.UriSet.add (UriManager.uri_of_string u) s)
- UriManager.UriSet.empty [
- "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)";
- "cic:/Coq/Init/Logic/trans_eq.con";
- "cic:/Coq/Init/Logic/f_equal.con";
- "cic:/Coq/Init/Logic/f_equal2.con";
- "cic:/Coq/Init/Logic/f_equal3.con";
- "cic:/Coq/Init/Logic/f_equal4.con";
- "cic:/Coq/Init/Logic/f_equal5.con";
- "cic:/Coq/Init/Logic/sym_eq.con";
- "cic:/Coq/Init/Logic/eq_ind.con";
- "cic:/Coq/Init/Logic/eq_ind_r.con";
- "cic:/Coq/Init/Logic/eq_rec.con";
- "cic:/Coq/Init/Logic/eq_rec_r.con";
- "cic:/Coq/Init/Logic/eq_rect.con";
- "cic:/Coq/Init/Logic/eq_rect_r.con";
- "cic:/Coq/Logic/Eqdep/UIP.con";
- "cic:/Coq/Logic/Eqdep/UIP_refl.con";
- "cic:/Coq/Logic/Eqdep_dec/eq2eqT.con";
- "cic:/Coq/ZArith/Zcompare/rename.con";
- (* ALB !!!! questo e` imbrogliare, ma x ora lo lasciamo cosi`...
- perche' questo cacchio di teorema rompe le scatole :'( *)
- "cic:/Rocq/SUBST/comparith/mult_n_2.con";
-
- "cic:/matita/logic/equality/eq_f.con";
- "cic:/matita/logic/equality/eq_f2.con";
- "cic:/matita/logic/equality/eq_rec.con";
- "cic:/matita/logic/equality/eq_rect.con";
- ]
-;;
-*)
-let equations_blacklist = UriManager.UriSet.empty;;
-
-
-let find_library_equalities dbd context status maxmeta =
- let module C = Cic in
- let module S = CicSubstitution in
- let module T = CicTypeChecker in
- let blacklist =
- List.fold_left
- (fun s u -> UriManager.UriSet.add u s)
- equations_blacklist
- [eq_XURI (); sym_eq_URI (); trans_eq_URI (); eq_ind_URI ();
- eq_ind_r_URI ()]
- in
- let candidates =
- List.fold_left
- (fun l uri ->
- if UriManager.UriSet.mem uri blacklist then
- l
- else
- let t = CicUtil.term_of_uri uri in
- let ty, _ =
- CicTypeChecker.type_of_aux' [] context t CicUniv.empty_ugraph
- in
- (uri, t, ty)::l)
- []
- (let t1 = Unix.gettimeofday () in
- let eqs = (MetadataQuery.equations_for_goal ~dbd status) in
- let t2 = Unix.gettimeofday () in
- (debug_print
- (lazy
- (Printf.sprintf "Tempo di MetadataQuery.equations_for_goal: %.9f\n"
- (t2 -. t1))));
- eqs)
- in
- let eq_uri1 = eq_XURI ()
- and eq_uri2 = LibraryObjects.eq_URI () in
- let iseq uri =
- (UriManager.eq uri eq_uri1) || (UriManager.eq uri eq_uri2)
- in
- let ok_types ty menv =
- List.for_all (fun (_, _, mt) -> mt = ty) menv
- in
- let rec has_vars = function
- | C.Meta _ | C.Rel _ | C.Const _ -> false
- | C.Var _ -> true
- | C.Appl l -> List.exists has_vars l
- | C.Prod (_, s, t) | C.Lambda (_, s, t)
- | C.LetIn (_, s, t) | C.Cast (s, t) ->
- (has_vars s) || (has_vars t)
- | _ -> false
- in
- let rec aux newmeta = function
- | [] -> [], newmeta
- | (uri, term, termty)::tl ->
- debug_print
- (lazy
- (Printf.sprintf "Examining: %s (%s)"
- (CicPp.ppterm term) (CicPp.ppterm termty)));
- let res, newmeta =
- match termty with
- | C.Prod (name, s, t) when not (has_vars termty) ->
- let head, newmetas, args, newmeta =
- ProofEngineHelpers.saturate_term newmeta [] context termty 0
- in
- let p =
- if List.length args = 0 then
- term
- else
- C.Appl (term::args)
- in (
- match head with
- | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
- when (iseq uri) && (ok_types ty newmetas) ->
- debug_print
- (lazy
- (Printf.sprintf "OK: %s" (CicPp.ppterm term)));
- let o = !Utils.compare_terms t1 t2 in
- let w = compute_equality_weight ty t1 t2 in
- let proof = BasicProof p in
- let e = (w, proof, (ty, t1, t2, o), newmetas, args) in
- Some e, (newmeta+1)
- | _ -> None, newmeta
- )
- | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
- when iseq uri && not (has_vars termty) ->
- let o = !Utils.compare_terms t1 t2 in
- let w = compute_equality_weight ty t1 t2 in
- let e = (w, BasicProof term, (ty, t1, t2, o), [], []) in
- Some e, (newmeta+1)
- | _ -> None, newmeta
- in
- match res with
- | Some e ->
- let tl, newmeta' = aux newmeta tl in
- if newmeta' < newmeta then
- prerr_endline "big trouble";
- (uri, e)::tl, newmeta' (* max???? *)
- | None ->
- aux newmeta tl
- in
- let found, maxm = aux maxmeta candidates in
- let uriset, eqlist =
- (List.fold_left
- (fun (s, l) (u, e) ->
- if List.exists (meta_convertibility_eq e) (List.map snd l) then (
- debug_print
- (lazy
- (Printf.sprintf "NO!! %s already there!"
- (string_of_equality e)));
- (UriManager.UriSet.add u s, l)
- ) else (UriManager.UriSet.add u s, (u, e)::l))
- (UriManager.UriSet.empty, []) found)
- in
- uriset, eqlist, maxm
-;;
-
-
-let find_library_theorems dbd env status equalities_uris =
- let module C = Cic in
- let module S = CicSubstitution in
- let module T = CicTypeChecker in
- let blacklist =
- let refl_equal =
- UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)" in
- let s =
- UriManager.UriSet.remove refl_equal
- (UriManager.UriSet.union equalities_uris equations_blacklist)
- in
- List.fold_left
- (fun s u -> UriManager.UriSet.add u s)
- s [eq_XURI () ;sym_eq_URI (); trans_eq_URI (); eq_ind_URI ();
- eq_ind_r_URI ()]
- in
- let metasenv, context, ugraph = env in
- let candidates =
- List.fold_left
- (fun l uri ->
- if UriManager.UriSet.mem uri blacklist then l
- else
- let t = CicUtil.term_of_uri uri in
- let ty, _ = CicTypeChecker.type_of_aux' metasenv context t ugraph in
- (t, ty, [])::l)
- [] (MetadataQuery.signature_of_goal ~dbd status)
- in
- let refl_equal =
- let u = eq_XURI () in
- let t = CicUtil.term_of_uri u in
- let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in
- (t, ty, [])
- in
- refl_equal::candidates
-;;
-
-
-let find_context_hypotheses env equalities_indexes =
- let metasenv, context, ugraph = env in
- let _, res =
- List.fold_left
- (fun (n, l) entry ->
- match entry with
- | None -> (n+1, l)
- | Some _ ->
- if List.mem n equalities_indexes then
- (n+1, l)
- else
- let t = Cic.Rel n in
- let ty, _ =
- CicTypeChecker.type_of_aux' metasenv context t ugraph in
- (n+1, (t, ty, [])::l))
- (1, []) context
- in
- res
-;;
-
-
-let fix_metas_old newmeta (w, p, (ty, left, right, o), menv, args) =
- let table = Hashtbl.create (List.length args) in
-
- let newargs, newmeta =
- List.fold_right
- (fun t (newargs, index) ->
- match t with
- | Cic.Meta (i, l) ->
- if Hashtbl.mem table i then
- let idx = Hashtbl.find table i in
- ((Cic.Meta (idx, l))::newargs, index+1)
- else
- let _ = Hashtbl.add table i index in
- ((Cic.Meta (index, l))::newargs, index+1)
- | _ -> assert false)
- args ([], newmeta+1)
- in
-
- let repl where =
- ProofEngineReduction.replace ~equality:(=) ~what:args ~with_what:newargs
- ~where
- in
- let menv' =
- List.fold_right
- (fun (i, context, term) menv ->
- try
- let index = Hashtbl.find table i in
- (index, context, term)::menv
- with Not_found ->
- (i, context, term)::menv)
- menv []
- in
- let ty = repl ty
- and left = repl left
- and right = repl right in
- let metas = (metas_of_term left) @ (metas_of_term right) @ (metas_of_term ty) in
- let menv' = List.filter (fun (i, _, _) -> List.mem i metas) menv' in
- let newargs =
- List.filter
- (function Cic.Meta (i, _) -> List.mem i metas | _ -> assert false) newargs
- in
- let _ =
- if List.length metas > 0 then
- let first = List.hd metas in
- (* this new equality might have less variables than its parents: here
- we fill the gap with a dummy arg. Example:
- with (f X Y) = X we can simplify
- (g X) = (f X Y) in
- (g X) = X.
- So the new equation has only one variable, but it still has type like
- \lambda X,Y:..., so we need to pass a dummy arg for Y
- (I hope this makes some sense...)
- *)
- Hashtbl.iter
- (fun k v ->
- if not (List.exists
- (function Cic.Meta (i, _) -> i = v | _ -> assert false)
- newargs) then
- Hashtbl.replace table k first)
- (Hashtbl.copy table)
- in
- let rec fix_proof = function
- | NoProof -> NoProof
- | BasicProof term -> BasicProof (repl term)
- | ProofBlock (subst, eq_URI, namety, bo, (pos, eq), p) ->
- let subst' =
- List.fold_left
- (fun s arg ->
- match arg with
- | Cic.Meta (i, l) -> (
- try
- let j = Hashtbl.find table i in
- if List.mem_assoc i subst then
- s
- else
- let _, context, ty = CicUtil.lookup_meta i menv in
- (i, (context, Cic.Meta (j, l), ty))::s
- with Not_found | CicUtil.Meta_not_found _ ->
- s
- )
- | _ -> assert false)
- [] args
- in
- ProofBlock (subst' @ subst, eq_URI, namety, bo(* t' *), (pos, eq), p)
- | p -> assert false
- in
- let neweq = (w, fix_proof p, (ty, left, right, o), menv', newargs) in
- (newmeta +1, neweq)
-;;
-
-
-let relocate newmeta menv =
- let subst, metasenv, newmeta =
- List.fold_right
- (fun (i, context, ty) (subst, menv, maxmeta) ->
- let irl=CicMkImplicit.identity_relocation_list_for_metavariable context in
- let newsubst = (i, (context, (Cic.Meta (maxmeta, irl)), ty)) in
- let newmeta = maxmeta, context, ty in
- newsubst::subst, newmeta::menv, maxmeta+1)
- menv ([], [], newmeta+1)
- in
- let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
- let subst =
- List.map
- (fun (i, (context, term, ty)) ->
- let context = CicMetaSubst.apply_subst_context subst context in
- let term = CicMetaSubst.apply_subst subst term in
- let ty = CicMetaSubst.apply_subst subst ty in
- (i, (context, term, ty))) subst in
- subst, metasenv, newmeta
-
-
-let fix_metas newmeta (w, p, (ty, left, right, o), menv, args) =
- (* debug
- let _ , eq =
- fix_metas_old newmeta (w, p, (ty, left, right, o), menv, args) in
- prerr_endline (string_of_equality eq); *)
- let subst, metasenv, newmeta = relocate newmeta menv in
- let ty = CicMetaSubst.apply_subst subst ty in
- let left = CicMetaSubst.apply_subst subst left in
- let right = CicMetaSubst.apply_subst subst right in
- let args = List.map (CicMetaSubst.apply_subst subst) args in
- let rec fix_proof = function
- | NoProof -> NoProof
- | BasicProof term -> BasicProof (CicMetaSubst.apply_subst subst term)
- | ProofBlock (subst', eq_URI, namety, bo, (pos, eq), p) ->
- ProofBlock (subst' @ subst, eq_URI, namety, bo, (pos, eq), p)
- | p -> assert false
- in
- let metas = (metas_of_term left)@(metas_of_term right)@(metas_of_term ty) in
- let metasenv = List.filter (fun (i, _, _) -> List.mem i metas) metasenv in
- let eq = (w, fix_proof p, (ty, left, right, o), metasenv, args) in
- (* debug prerr_endline (string_of_equality eq); *)
- newmeta, eq
-
-let term_is_equality term =
- let iseq uri = UriManager.eq uri (LibraryObjects.eq_URI ()) in
- match term with
- | Cic.Appl [Cic.MutInd (uri, _, _); _; _; _] when iseq uri -> true
- | _ -> false
-;;
-
-
-exception TermIsNotAnEquality;;
-
-let equality_of_term proof term =
- let eq_uri = LibraryObjects.eq_URI () in
- let iseq uri = UriManager.eq uri eq_uri in
- match term with
- | Cic.Appl [Cic.MutInd (uri, _, _); ty; t1; t2] when iseq uri ->
- let o = !Utils.compare_terms t1 t2 in
- let w = compute_equality_weight ty t1 t2 in
- let e = (w, BasicProof proof, (ty, t1, t2, o), [], []) in
- e
- | _ ->
- raise TermIsNotAnEquality
-;;
-
-
-type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph;;
-
-let is_weak_identity (metasenv, context, ugraph) = function
- | (_, _, (ty, left, right, _), menv, _) ->
- (left = right ||
- (meta_convertibility left right))
- (* the test below is not a good idea since it stops
- demodulation too early *)
- (* (fst (CicReduction.are_convertible
- ~metasenv:(metasenv @ menv) context left right ugraph)))*)
-;;
-
-let is_identity (metasenv, context, ugraph) = function
- | (_, _, (ty, left, right, _), menv, _) ->
- (left = right ||
- (* (meta_convertibility left right)) *)
- (fst (CicReduction.are_convertible
- ~metasenv:(metasenv @ menv) context left right ugraph)))
-;;
-
-
-let term_of_equality equality =
- let _, _, (ty, left, right, _), menv, args = equality in
- let eq i = function Cic.Meta (j, _) -> i = j | _ -> false in
- let argsno = List.length args in
- let t =
- CicSubstitution.lift argsno
- (Cic.Appl [Cic.MutInd (LibraryObjects.eq_URI (), 0, []); ty; left; right])
- in
- snd (
- List.fold_right
- (fun a (n, t) ->
- match a with
- | Cic.Meta (i, _) ->
- let name = Cic.Name ("X" ^ (string_of_int n)) in
- let _, _, ty = CicUtil.lookup_meta i menv in
- let t =
- ProofEngineReduction.replace
- ~equality:eq ~what:[i]
- ~with_what:[Cic.Rel (argsno - (n - 1))] ~where:t
- in
- (n-1, Cic.Prod (name, ty, t))
- | _ -> assert false)
- args (argsno, t))
-;;
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-type equality =
- int * (* weight *)
- proof * (* proof *)
- (Cic.term * (* type *)
- Cic.term * (* left side *)
- Cic.term * (* right side *)
- Utils.comparison) * (* ordering *)
- Cic.metasenv * (* environment for metas *)
- Cic.term list (* arguments *)
-
-and proof =
- | NoProof (* no proof *)
- | BasicProof of Cic.term (* already a proof of a goal *)
- | ProofBlock of (* proof of a rewrite step *)
- Cic.substitution * UriManager.uri * (* eq_ind or eq_ind_r *)
- (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof
- | ProofGoalBlock of proof * proof
- (* proof of the new meta, proof of the goal from which this comes *)
- | ProofSymBlock of Cic.term list * proof (* expl.named subst, proof *)
- | SubProof of Cic.term * int * proof
- (* parent proof, subgoal, proof of the subgoal *)
-
-type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph
-
-(** builds the Cic.term encoded by proof *)
-val build_proof_term: ?noproof:Cic.term -> proof -> Cic.term
-
-val string_of_proof: proof -> string
-
-exception MatchingFailure
-
-(** matching between two terms. Can raise MatchingFailure *)
-val matching:
- Cic.metasenv -> Cic.context -> Cic.term -> Cic.term ->
- CicUniv.universe_graph ->
- Cic.substitution * Cic.metasenv * CicUniv.universe_graph
-
-(**
- special unification that checks if the two terms are "simple", and in
- such case should be significantly faster than CicUnification.fo_unif
-*)
-val unification:
- Cic.metasenv -> Cic.context -> Cic.term -> Cic.term ->
- CicUniv.universe_graph ->
- Cic.substitution * Cic.metasenv * CicUniv.universe_graph
-
-
-(**
- scans the context to find all Declarations "left = right"; returns a
- list of tuples (proof, (type, left, right), newmetas). Uses
- PrimitiveTactics.new_metasenv_for_apply to replace bound variables with
- fresh metas...
-*)
-val find_equalities:
- Cic.context -> ProofEngineTypes.proof -> int list * equality list * int
-
-(**
- searches the library for equalities that can be applied to the current goal
-*)
-val find_library_equalities:
- HMysql.dbd -> Cic.context -> ProofEngineTypes.status -> int ->
- UriManager.UriSet.t * (UriManager.uri * equality) list * int
-
-(**
- searches the library for theorems that are not equalities (returned by the
- function above)
-*)
-val find_library_theorems:
- HMysql.dbd -> environment -> ProofEngineTypes.status -> UriManager.UriSet.t ->
- (Cic.term * Cic.term * Cic.metasenv) list
-
-(**
- searches the context for hypotheses that are not equalities
-*)
-val find_context_hypotheses:
- environment -> int list -> (Cic.term * Cic.term * Cic.metasenv) list
-
-
-exception TermIsNotAnEquality;;
-
-(**
- raises TermIsNotAnEquality if term is not an equation.
- The first Cic.term is a proof of the equation
-*)
-val equality_of_term: Cic.term -> Cic.term -> equality
-
-(**
- Re-builds the term corresponding to this equality
-*)
-val term_of_equality: equality -> Cic.term
-
-val term_is_equality: Cic.term -> bool
-
-(** tests a sort of alpha-convertibility between the two terms, but on the
- metavariables *)
-val meta_convertibility: Cic.term -> Cic.term -> bool
-
-(** meta convertibility between two equations *)
-val meta_convertibility_eq: equality -> equality -> bool
-
-val is_weak_identity: environment -> equality -> bool
-val is_identity: environment -> equality -> bool
-
-val string_of_equality: ?env:environment -> equality -> string
-
-val metas_of_term: Cic.term -> int list
-
-(** ensures that metavariables in equality are unique *)
-val fix_metas: int -> equality -> int * equality
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-module Trivial_disambiguate:
-sig
- exception Ambiguous_term of string Lazy.t
- (** disambiguate an _unanmbiguous_ term using dummy callbacks which fail if a
- * choice from the user is needed to disambiguate the term
- * @raise Ambiguous_term for ambiguous term *)
- val disambiguate_string:
- dbd:HMysql.dbd ->
- ?context:Cic.context ->
- ?metasenv:Cic.metasenv ->
- ?initial_ugraph:CicUniv.universe_graph ->
- ?aliases:DisambiguateTypes.environment ->(* previous interpretation status*)
- string ->
- ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list *
- Cic.metasenv * (* new metasenv *)
- Cic.term *
- CicUniv.universe_graph) list (* disambiguated term *)
-end
-=
-struct
- exception Ambiguous_term of string Lazy.t
- exception Exit
- module Callbacks =
- struct
- let non p x = not (p x)
- let interactive_user_uri_choice ~selection_mode ?ok
- ?(enable_button_for_non_vars = true) ~title ~msg ~id uris =
- List.filter (non UriManager.uri_is_var) uris
- let interactive_interpretation_choice interp = raise Exit
- let input_or_locate_uri ~(title:string) ?id = raise Exit
- end
- module Disambiguator = Disambiguate.Make (Callbacks)
- let disambiguate_string ~dbd ?(context = []) ?(metasenv = []) ?initial_ugraph
- ?(aliases = DisambiguateTypes.Environment.empty) term
- =
- let ast =
- CicNotationParser.parse_level2_ast (Ulexing.from_utf8_string term)
- in
- try
- fst (Disambiguator.disambiguate_term ~dbd ~context ~metasenv ast
- ?initial_ugraph ~aliases ~universe:None)
- with Exit -> raise (Ambiguous_term (lazy term))
-end
-
-let configuration_file = ref "../../../matita/matita.conf.xml";;
-
-let core_notation_script = "../../../matita/core_notation.moo";;
-
-let get_from_user ~(dbd:HMysql.dbd) =
- let rec get () =
- match read_line () with
- | "" -> []
- | t -> t::(get ())
- in
- let term_string = String.concat "\n" (get ()) in
- let env, metasenv, term, ugraph =
- List.nth (Trivial_disambiguate.disambiguate_string dbd term_string) 0
- in
- term, metasenv, ugraph
-;;
-
-let full = ref false;;
-
-let retrieve_only = ref false;;
-
-let demod_equalities = ref false;;
-
-let main () =
- let module S = Saturation in
- let set_ratio v = S.weight_age_ratio := v; S.weight_age_counter := v
- and set_sel v = S.symbols_ratio := v; S.symbols_counter := v;
- and set_conf f = configuration_file := f
- and set_ordering o =
- match o with
- | "lpo" -> Utils.compare_terms := Utils.lpo
- | "kbo" -> Utils.compare_terms := Utils.kbo
- | "nr-kbo" -> Utils.compare_terms := Utils.nonrec_kbo
- | "ao" -> Utils.compare_terms := Utils.ao
- | o -> raise (Arg.Bad ("Unknown term ordering: " ^ o))
- and set_fullred b = S.use_fullred := b
- and set_time_limit v = S.time_limit := float_of_int v
- and set_width w = S.maxwidth := w
- and set_depth d = S.maxdepth := d
- and set_full () = full := true
- and set_retrieve () = retrieve_only := true
- and set_demod_equalities () = demod_equalities := true
- in
- Arg.parse [
- "-full", Arg.Unit set_full, "Enable full mode";
- "-f", Arg.Bool set_fullred,
- "Enable/disable full-reduction strategy (default: enabled)";
-
- "-r", Arg.Int set_ratio, "Weight-Age equality selection ratio (default: 4)";
-
- "-s", Arg.Int set_sel,
- "symbols-based selection ratio (relative to the weight ratio, default: 0)";
-
- "-c", Arg.String set_conf, "Configuration file (for the db connection)";
-
- "-o", Arg.String set_ordering,
- "Term ordering. Possible values are:\n" ^
- "\tkbo: Knuth-Bendix ordering\n" ^
- "\tnr-kbo: Non-recursive variant of kbo (default)\n" ^
- "\tlpo: Lexicographic path ordering";
-
- "-l", Arg.Int set_time_limit, "Time limit in seconds (default: no limit)";
-
- "-w", Arg.Int set_width,
- Printf.sprintf "Maximal width (default: %d)" !Saturation.maxwidth;
-
- "-d", Arg.Int set_depth,
- Printf.sprintf "Maximal depth (default: %d)" !Saturation.maxdepth;
-
- "-retrieve", Arg.Unit set_retrieve, "retrieve only";
- "-demod-equalities", Arg.Unit set_demod_equalities, "demod equalities";
- ] (fun a -> ()) "Usage:";
- Helm_registry.load_from !configuration_file;
- ignore (CicNotation2.load_notation [] core_notation_script);
- ignore (CicNotation2.load_notation [] "../../../matita/library/legacy/coq.ma");
- let dbd = HMysql.quick_connect
- ~host:(Helm_registry.get "db.host")
- ~user:(Helm_registry.get "db.user")
- ~database:(Helm_registry.get "db.database")
- ()
- in
- let term, metasenv, ugraph = get_from_user ~dbd in
- if !retrieve_only then
- Saturation.retrieve_and_print dbd term metasenv ugraph
- else if !demod_equalities then
- Saturation.main_demod_equalities dbd term metasenv ugraph
- else
- Saturation.main dbd !full term metasenv ugraph
-;;
-
-let _ =
- (*try*)
- main ()
- (*with exn -> prerr_endline (Printexc.to_string exn)*)
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-open Inference;;
-open Utils;;
-
-(*
-for debugging
-let check_equation env equation msg =
- let w, proof, (eq_ty, left, right, order), metas, args = equation in
- let metasenv, context, ugraph = env in
- let metasenv' = metasenv @ metas in
- try
- CicTypeChecker.type_of_aux' metasenv' context left ugraph;
- CicTypeChecker.type_of_aux' metasenv' context right ugraph;
- ()
- with
- CicUtil.Meta_not_found _ as exn ->
- begin
- prerr_endline msg;
- prerr_endline (CicPp.ppterm left);
- prerr_endline (CicPp.ppterm right);
- raise exn
- end
-*)
-
-(* set to false to disable paramodulation inside auto_tac *)
-let connect_to_auto = true;;
-
-
-(* profiling statistics... *)
-let infer_time = ref 0.;;
-let forward_simpl_time = ref 0.;;
-let forward_simpl_new_time = ref 0.;;
-let backward_simpl_time = ref 0.;;
-let passive_maintainance_time = ref 0.;;
-
-(* limited-resource-strategy related globals *)
-let processed_clauses = ref 0;; (* number of equalities selected so far... *)
-let time_limit = ref 0.;; (* in seconds, settable by the user... *)
-let start_time = ref 0.;; (* time at which the execution started *)
-let elapsed_time = ref 0.;;
-(* let maximal_weight = ref None;; *)
-let maximal_retained_equality = ref None;;
-
-(* equality-selection related globals *)
-let use_fullred = ref true;;
-let weight_age_ratio = ref (* 5 *) 4;; (* settable by the user *)
-let weight_age_counter = ref !weight_age_ratio;;
-let symbols_ratio = ref (* 0 *) 3;;
-let symbols_counter = ref 0;;
-
-(* non-recursive Knuth-Bendix term ordering by default *)
-(* Utils.compare_terms := Utils.rpo;; *)
-(* Utils.compare_terms := Utils.nonrec_kbo;; *)
-(* Utils.compare_terms := Utils.ao;; *)
-
-(* statistics... *)
-let derived_clauses = ref 0;;
-let kept_clauses = ref 0;;
-
-(* index of the greatest Cic.Meta created - TODO: find a better way! *)
-let maxmeta = ref 0;;
-
-(* varbiables controlling the search-space *)
-let maxdepth = ref 3;;
-let maxwidth = ref 3;;
-
-
-type result =
- | ParamodulationFailure
- | ParamodulationSuccess of Inference.proof option * environment
-;;
-
-type goal = proof * Cic.metasenv * Cic.term;;
-
-type theorem = Cic.term * Cic.term * Cic.metasenv;;
-
-let symbols_of_equality (_, _, (_, left, right, _), _, _) =
- let m1 = symbols_of_term left in
- let m =
- TermMap.fold
- (fun k v res ->
- try
- let c = TermMap.find k res in
- TermMap.add k (c+v) res
- with Not_found ->
- TermMap.add k v res)
- (symbols_of_term right) m1
- in
- m
-;;
-
-module OrderedEquality = struct
- type t = Inference.equality
-
- let compare eq1 eq2 =
- match meta_convertibility_eq eq1 eq2 with
- | true -> 0
- | false ->
- let w1, _, (ty, left, right, _), _, a = eq1
- and w2, _, (ty', left', right', _), _, a' = eq2 in
- match Pervasives.compare w1 w2 with
- | 0 ->
- let res = (List.length a) - (List.length a') in
- if res <> 0 then res else (
- try
- let res = Pervasives.compare (List.hd a) (List.hd a') in
- if res <> 0 then res else Pervasives.compare eq1 eq2
- with Failure "hd" -> Pervasives.compare eq1 eq2
- )
- | res -> res
-end
-
-module EqualitySet = Set.Make(OrderedEquality);;
-
-
-(**
- selects one equality from passive. The selection strategy is a combination
- of weight, age and goal-similarity
-*)
-let select env goals passive (active, _) =
- processed_clauses := !processed_clauses + 1;
- let goal =
- match (List.rev goals) with (_, goal::_)::_ -> goal | _ -> assert false
- in
- let (neg_list, neg_set), (pos_list, pos_set), passive_table = passive in
- let remove eq l =
- List.filter (fun e -> e <> eq) l
- in
- if !weight_age_ratio > 0 then
- weight_age_counter := !weight_age_counter - 1;
- match !weight_age_counter with
- | 0 -> (
- weight_age_counter := !weight_age_ratio;
- match neg_list, pos_list with
- | hd::tl, pos ->
- (* Negatives aren't indexed, no need to remove them... *)
- (Negative, hd),
- ((tl, EqualitySet.remove hd neg_set), (pos, pos_set), passive_table)
- | [], (hd:EqualitySet.elt)::tl ->
- let passive_table =
- Indexing.remove_index passive_table hd
- in
- (Positive, hd),
- (([], neg_set), (tl, EqualitySet.remove hd pos_set), passive_table)
- | _, _ -> assert false
- )
- | _ when (!symbols_counter > 0) && (EqualitySet.is_empty neg_set) -> (
- symbols_counter := !symbols_counter - 1;
- let cardinality map =
- TermMap.fold (fun k v res -> res + v) map 0
- in
- let symbols =
- let _, _, term = goal in
- symbols_of_term term
- in
- let card = cardinality symbols in
- let foldfun k v (r1, r2) =
- if TermMap.mem k symbols then
- let c = TermMap.find k symbols in
- let c1 = abs (c - v) in
- let c2 = v - c1 in
- r1 + c2, r2 + c1
- else
- r1, r2 + v
- in
- let f equality (i, e) =
- let common, others =
- TermMap.fold foldfun (symbols_of_equality equality) (0, 0)
- in
- let c = others + (abs (common - card)) in
- if c < i then (c, equality)
- else (i, e)
- in
- let e1 = EqualitySet.min_elt pos_set in
- let initial =
- let common, others =
- TermMap.fold foldfun (symbols_of_equality e1) (0, 0)
- in
- (others + (abs (common - card))), e1
- in
- let _, current = EqualitySet.fold f pos_set initial in
- let passive_table =
- Indexing.remove_index passive_table current
- in
- (Positive, current),
- (([], neg_set),
- (remove current pos_list, EqualitySet.remove current pos_set),
- passive_table)
- )
- | _ ->
- symbols_counter := !symbols_ratio;
- let set_selection set = EqualitySet.min_elt set in
- if EqualitySet.is_empty neg_set then
- let current = set_selection pos_set in
- let passive =
- (neg_list, neg_set),
- (remove current pos_list, EqualitySet.remove current pos_set),
- Indexing.remove_index passive_table current
- in
- (Positive, current), passive
- else
- let current = set_selection neg_set in
- let passive =
- (remove current neg_list, EqualitySet.remove current neg_set),
- (pos_list, pos_set),
- passive_table
- in
- (Negative, current), passive
-;;
-
-
-(* initializes the passive set of equalities *)
-let make_passive neg pos =
- let set_of equalities =
- List.fold_left (fun s e -> EqualitySet.add e s) EqualitySet.empty equalities
- in
- let table =
- List.fold_left (fun tbl e -> Indexing.index tbl e) Indexing.empty pos
- in
- (neg, set_of neg),
- (pos, set_of pos),
- table
-;;
-
-
-let make_active () =
- [], Indexing.empty
-;;
-
-
-(* adds to passive a list of equalities: new_neg is a list of negative
- equalities, new_pos a list of positive equalities *)
-let add_to_passive passive (new_neg, new_pos) =
- let (neg_list, neg_set), (pos_list, pos_set), table = passive in
- let ok set equality = not (EqualitySet.mem equality set) in
- let neg = List.filter (ok neg_set) new_neg
- and pos = List.filter (ok pos_set) new_pos in
- let table =
- List.fold_left (fun tbl e -> Indexing.index tbl e) table pos
- in
- let add set equalities =
- List.fold_left (fun s e -> EqualitySet.add e s) set equalities
- in
- (neg @ neg_list, add neg_set neg),
- (pos_list @ pos, add pos_set pos),
- table
-;;
-
-
-let passive_is_empty = function
- | ([], _), ([], _), _ -> true
- | _ -> false
-;;
-
-
-let size_of_passive ((_, ns), (_, ps), _) =
- (EqualitySet.cardinal ns) + (EqualitySet.cardinal ps)
-;;
-
-
-let size_of_active (active_list, _) =
- List.length active_list
-;;
-
-
-(* removes from passive equalities that are estimated impossible to activate
- within the current time limit *)
-let prune_passive howmany (active, _) passive =
- let (nl, ns), (pl, ps), tbl = passive in
- let howmany = float_of_int howmany
- and ratio = float_of_int !weight_age_ratio in
- let round v =
- let t = ceil v in
- int_of_float (if t -. v < 0.5 then t else v)
- in
- let in_weight = round (howmany *. ratio /. (ratio +. 1.))
- and in_age = round (howmany /. (ratio +. 1.)) in
- debug_print
- (lazy (Printf.sprintf "in_weight: %d, in_age: %d\n" in_weight in_age));
- let symbols, card =
- match active with
- | (Negative, e)::_ ->
- let symbols = symbols_of_equality e in
- let card = TermMap.fold (fun k v res -> res + v) symbols 0 in
- Some symbols, card
- | _ -> None, 0
- in
- let counter = ref !symbols_ratio in
- let rec pickw w ns ps =
- if w > 0 then
- if not (EqualitySet.is_empty ns) then
- let e = EqualitySet.min_elt ns in
- let ns', ps = pickw (w-1) (EqualitySet.remove e ns) ps in
- EqualitySet.add e ns', ps
- else if !counter > 0 then
- let _ =
- counter := !counter - 1;
- if !counter = 0 then counter := !symbols_ratio
- in
- match symbols with
- | None ->
- let e = EqualitySet.min_elt ps in
- let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in
- ns, EqualitySet.add e ps'
- | Some symbols ->
- let foldfun k v (r1, r2) =
- if TermMap.mem k symbols then
- let c = TermMap.find k symbols in
- let c1 = abs (c - v) in
- let c2 = v - c1 in
- r1 + c2, r2 + c1
- else
- r1, r2 + v
- in
- let f equality (i, e) =
- let common, others =
- TermMap.fold foldfun (symbols_of_equality equality) (0, 0)
- in
- let c = others + (abs (common - card)) in
- if c < i then (c, equality)
- else (i, e)
- in
- let e1 = EqualitySet.min_elt ps in
- let initial =
- let common, others =
- TermMap.fold foldfun (symbols_of_equality e1) (0, 0)
- in
- (others + (abs (common - card))), e1
- in
- let _, e = EqualitySet.fold f ps initial in
- let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in
- ns, EqualitySet.add e ps'
- else
- let e = EqualitySet.min_elt ps in
- let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in
- ns, EqualitySet.add e ps'
- else
- EqualitySet.empty, EqualitySet.empty
- in
- let ns, ps = pickw in_weight ns ps in
- let rec picka w s l =
- if w > 0 then
- match l with
- | [] -> w, s, []
- | hd::tl when not (EqualitySet.mem hd s) ->
- let w, s, l = picka (w-1) s tl in
- w, EqualitySet.add hd s, hd::l
- | hd::tl ->
- let w, s, l = picka w s tl in
- w, s, hd::l
- else
- 0, s, l
- in
- let in_age, ns, nl = picka in_age ns nl in
- let _, ps, pl = picka in_age ps pl in
- if not (EqualitySet.is_empty ps) then
- maximal_retained_equality := Some (EqualitySet.max_elt ps);
- let tbl =
- EqualitySet.fold
- (fun e tbl -> Indexing.index tbl e) ps Indexing.empty
- in
- (nl, ns), (pl, ps), tbl
-;;
-
-
-(** inference of new equalities between current and some in active *)
-let infer env sign current (active_list, active_table) =
- let new_neg, new_pos =
- match sign with
- | Negative ->
- let maxm, res =
- Indexing.superposition_left !maxmeta env active_table current in
- maxmeta := maxm;
- res, []
- | Positive ->
- let maxm, res =
- Indexing.superposition_right !maxmeta env active_table current in
- maxmeta := maxm;
- let rec infer_positive table = function
- | [] -> [], []
- | (Negative, equality)::tl ->
- let maxm, res =
- Indexing.superposition_left !maxmeta env table equality in
- maxmeta := maxm;
- let neg, pos = infer_positive table tl in
- res @ neg, pos
- | (Positive, equality)::tl ->
- let maxm, res =
- Indexing.superposition_right !maxmeta env table equality in
- maxmeta := maxm;
- let neg, pos = infer_positive table tl in
- neg, res @ pos
- in
- let curr_table = Indexing.index Indexing.empty current in
- let neg, pos = infer_positive curr_table active_list in
- neg, res @ pos
- in
- derived_clauses := !derived_clauses + (List.length new_neg) +
- (List.length new_pos);
- match !maximal_retained_equality with
- | None -> new_neg, new_pos
- | Some eq ->
- (* if we have a maximal_retained_equality, we can discard all equalities
- "greater" than it, as they will never be reached... An equality is
- greater than maximal_retained_equality if it is bigger
- wrt. OrderedEquality.compare and it is less similar than
- maximal_retained_equality to the current goal *)
- let symbols, card =
- match active_list with
- | (Negative, e)::_ ->
- let symbols = symbols_of_equality e in
- let card = TermMap.fold (fun k v res -> res + v) symbols 0 in
- Some symbols, card
- | _ -> None, 0
- in
- let new_pos =
- match symbols with
- | None ->
- List.filter (fun e -> OrderedEquality.compare e eq <= 0) new_pos
- | Some symbols ->
- let filterfun e =
- if OrderedEquality.compare e eq <= 0 then
- true
- else
- let foldfun k v (r1, r2) =
- if TermMap.mem k symbols then
- let c = TermMap.find k symbols in
- let c1 = abs (c - v) in
- let c2 = v - c1 in
- r1 + c2, r2 + c1
- else
- r1, r2 + v
- in
- let initial =
- let common, others =
- TermMap.fold foldfun (symbols_of_equality eq) (0, 0) in
- others + (abs (common - card))
- in
- let common, others =
- TermMap.fold foldfun (symbols_of_equality e) (0, 0) in
- let c = others + (abs (common - card)) in
- if c < initial then true else false
- in
- List.filter filterfun new_pos
- in
- new_neg, new_pos
-;;
-
-
-let contains_empty env (negative, positive) =
- let metasenv, context, ugraph = env in
- try
- let found =
- List.find
- (fun (w, proof, (ty, left, right, ordering), m, a) ->
- fst (CicReduction.are_convertible context left right ugraph))
- negative
- in
- true, Some found
- with Not_found ->
- false, None
-;;
-
-
-(** simplifies current using active and passive *)
-let forward_simplify env (sign, current) ?passive (active_list, active_table) =
- let pl, passive_table =
- match passive with
- | None -> [], None
- | Some ((pn, _), (pp, _), pt) ->
- let pn = List.map (fun e -> (Negative, e)) pn
- and pp = List.map (fun e -> (Positive, e)) pp in
- pn @ pp, Some pt
- in
- let all = if pl = [] then active_list else active_list @ pl in
-
- let demodulate table current =
- let newmeta, newcurrent =
- Indexing.demodulation_equality !maxmeta env table sign current in
- maxmeta := newmeta;
- if is_identity env newcurrent then
- if sign = Negative then Some (sign, newcurrent)
- else (
-(* debug_print *)
-(* (lazy *)
-(* (Printf.sprintf "\ncurrent was: %s\nnewcurrent is: %s\n" *)
-(* (string_of_equality current) *)
-(* (string_of_equality newcurrent))); *)
-(* debug_print *)
-(* (lazy *)
-(* (Printf.sprintf "active is: %s" *)
-(* (String.concat "\n" *)
-(* (List.map (fun (_, e) -> (string_of_equality e)) active_list)))); *)
- None
- )
- else
- Some (sign, newcurrent)
- in
- let res =
- let res = demodulate active_table current in
- match res with
- | None -> None
- | Some (sign, newcurrent) ->
- match passive_table with
- | None -> res
- | Some passive_table -> demodulate passive_table newcurrent
- in
- match res with
- | None -> None
- | Some (Negative, c) ->
- let ok = not (
- List.exists
- (fun (s, eq) -> s = Negative && meta_convertibility_eq eq c)
- all)
- in
- if ok then res else None
- | Some (Positive, c) ->
- if Indexing.in_index active_table c then
- None
- else
- match passive_table with
- | None ->
- if fst (Indexing.subsumption env active_table c) then
- None
- else
- res
- | Some passive_table ->
- if Indexing.in_index passive_table c then None
- else
- let r1, _ = Indexing.subsumption env active_table c in
- if r1 then None else
- let r2, _ = Indexing.subsumption env passive_table c in
- if r2 then None else res
-;;
-
-type fs_time_info_t = {
- mutable build_all: float;
- mutable demodulate: float;
- mutable subsumption: float;
-};;
-
-let fs_time_info = { build_all = 0.; demodulate = 0.; subsumption = 0. };;
-
-
-(** simplifies new using active and passive *)
-let forward_simplify_new env (new_neg, new_pos) ?passive active =
- let t1 = Unix.gettimeofday () in
-
- let active_list, active_table = active in
- let pl, passive_table =
- match passive with
- | None -> [], None
- | Some ((pn, _), (pp, _), pt) ->
- let pn = List.map (fun e -> (Negative, e)) pn
- and pp = List.map (fun e -> (Positive, e)) pp in
- pn @ pp, Some pt
- in
-
- let t2 = Unix.gettimeofday () in
- fs_time_info.build_all <- fs_time_info.build_all +. (t2 -. t1);
-
- let demodulate sign table target =
- let newmeta, newtarget =
- Indexing.demodulation_equality !maxmeta env table sign target in
- maxmeta := newmeta;
- newtarget
- in
- let t1 = Unix.gettimeofday () in
-
- let new_neg, new_pos =
- let new_neg = List.map (demodulate Negative active_table) new_neg
- and new_pos = List.map (demodulate Positive active_table) new_pos in
- new_neg,new_pos
-
-(* PROVA
- match passive_table with
- | None -> new_neg, new_pos
- | Some passive_table ->
- List.map (demodulate Negative passive_table) new_neg,
- List.map (demodulate Positive passive_table) new_pos *)
- in
-
- let t2 = Unix.gettimeofday () in
- fs_time_info.demodulate <- fs_time_info.demodulate +. (t2 -. t1);
-
- let new_pos_set =
- List.fold_left
- (fun s e ->
- if not (Inference.is_identity env e) then
- if EqualitySet.mem e s then s
- else EqualitySet.add e s
- else s)
- EqualitySet.empty new_pos
- in
- let new_pos = EqualitySet.elements new_pos_set in
-
- let subs =
- match passive_table with
- | None ->
- (fun e -> not (fst (Indexing.subsumption env active_table e)))
- | Some passive_table ->
- (fun e -> not ((fst (Indexing.subsumption env active_table e)) ||
- (fst (Indexing.subsumption env passive_table e))))
- in
-(* let t1 = Unix.gettimeofday () in *)
-(* let t2 = Unix.gettimeofday () in *)
-(* fs_time_info.subsumption <- fs_time_info.subsumption +. (t2 -. t1); *)
- let is_duplicate =
- match passive_table with
- | None ->
- (fun e -> not (Indexing.in_index active_table e))
- | Some passive_table ->
- (fun e ->
- not ((Indexing.in_index active_table e) ||
- (Indexing.in_index passive_table e)))
- in
- new_neg, List.filter subs (List.filter is_duplicate new_pos)
-;;
-
-
-(** simplifies active usign new *)
-let backward_simplify_active env new_pos new_table min_weight active =
- let active_list, active_table = active in
- let active_list, newa =
- List.fold_right
- (fun (s, equality) (res, newn) ->
- let ew, _, _, _, _ = equality in
- if ew < min_weight then
- (s, equality)::res, newn
- else
- match forward_simplify env (s, equality) (new_pos, new_table) with
- | None -> res, newn
- | Some (s, e) ->
- if equality = e then
- (s, e)::res, newn
- else
- res, (s, e)::newn)
- active_list ([], [])
- in
- let find eq1 where =
- List.exists (fun (s, e) -> meta_convertibility_eq eq1 e) where
- in
- let active, newa =
- List.fold_right
- (fun (s, eq) (res, tbl) ->
- if List.mem (s, eq) res then
- res, tbl
- else if (is_identity env eq) || (find eq res) then (
- res, tbl
- )
- else
- (s, eq)::res, if s = Negative then tbl else Indexing.index tbl eq)
- active_list ([], Indexing.empty),
- List.fold_right
- (fun (s, eq) (n, p) ->
- if (s <> Negative) && (is_identity env eq) then (
- (n, p)
- ) else
- if s = Negative then eq::n, p
- else n, eq::p)
- newa ([], [])
- in
- match newa with
- | [], [] -> active, None
- | _ -> active, Some newa
-;;
-
-
-(** simplifies passive using new *)
-let backward_simplify_passive env new_pos new_table min_weight passive =
- let (nl, ns), (pl, ps), passive_table = passive in
- let f sign equality (resl, ress, newn) =
- let ew, _, _, _, _ = equality in
- if ew < min_weight then
- equality::resl, ress, newn
- else
- match forward_simplify env (sign, equality) (new_pos, new_table) with
- | None -> resl, EqualitySet.remove equality ress, newn
- | Some (s, e) ->
- if equality = e then
- equality::resl, ress, newn
- else
- let ress = EqualitySet.remove equality ress in
- resl, ress, e::newn
- in
- let nl, ns, newn = List.fold_right (f Negative) nl ([], ns, [])
- and pl, ps, newp = List.fold_right (f Positive) pl ([], ps, []) in
- let passive_table =
- List.fold_left
- (fun tbl e -> Indexing.index tbl e) Indexing.empty pl
- in
- match newn, newp with
- | [], [] -> ((nl, ns), (pl, ps), passive_table), None
- | _, _ -> ((nl, ns), (pl, ps), passive_table), Some (newn, newp)
-;;
-
-
-let backward_simplify env new' ?passive active =
- let new_pos, new_table, min_weight =
- List.fold_left
- (fun (l, t, w) e ->
- let ew, _, _, _, _ = e in
- (Positive, e)::l, Indexing.index t e, min ew w)
- ([], Indexing.empty, 1000000) (snd new')
- in
- let active, newa =
- backward_simplify_active env new_pos new_table min_weight active in
- match passive with
- | None ->
- active, (make_passive [] []), newa, None
- | Some passive ->
- let passive, newp =
- backward_simplify_passive env new_pos new_table min_weight passive in
- active, passive, newa, newp
-;;
-
-
-(* returns an estimation of how many equalities in passive can be activated
- within the current time limit *)
-let get_selection_estimate () =
- elapsed_time := (Unix.gettimeofday ()) -. !start_time;
- (* !processed_clauses * (int_of_float (!time_limit /. !elapsed_time)) *)
- int_of_float (
- ceil ((float_of_int !processed_clauses) *.
- ((!time_limit (* *. 2. *)) /. !elapsed_time -. 1.)))
-;;
-
-
-(** initializes the set of goals *)
-let make_goals goal =
- let active = []
- and passive = [0, [goal]] in
- active, passive
-;;
-
-
-(** initializes the set of theorems *)
-let make_theorems theorems =
- theorems, []
-;;
-
-
-let activate_goal (active, passive) =
- match passive with
- | goal_conj::tl -> true, (goal_conj::active, tl)
- | [] -> false, (active, passive)
-;;
-
-
-let activate_theorem (active, passive) =
- match passive with
- | theorem::tl -> true, (theorem::active, tl)
- | [] -> false, (active, passive)
-;;
-
-
-(** simplifies a goal with equalities in active and passive *)
-let simplify_goal env goal ?passive (active_list, active_table) =
- let pl, passive_table =
- match passive with
- | None -> [], None
- | Some ((pn, _), (pp, _), pt) ->
- let pn = List.map (fun e -> (Negative, e)) pn
- and pp = List.map (fun e -> (Positive, e)) pp in
- pn @ pp, Some pt
- in
-
- let demodulate table goal =
- let newmeta, newgoal =
- Indexing.demodulation_goal !maxmeta env table goal in
- maxmeta := newmeta;
- goal != newgoal, newgoal
- in
- let changed, goal =
- match passive_table with
- | None -> demodulate active_table goal
- | Some passive_table ->
- let changed, goal = demodulate active_table goal in
- let changed', goal = demodulate passive_table goal in
- (changed || changed'), goal
- in
- changed, goal
-;;
-
-
-let simplify_goals env goals ?passive active =
- let a_goals, p_goals = goals in
- let p_goals =
- List.map
- (fun (d, gl) ->
- let gl =
- List.map (fun g -> snd (simplify_goal env g ?passive active)) gl in
- d, gl)
- p_goals
- in
- let goals =
- List.fold_left
- (fun (a, p) (d, gl) ->
- let changed = ref false in
- let gl =
- List.map
- (fun g ->
- let c, g = simplify_goal env g ?passive active in
- changed := !changed || c; g) gl in
- if !changed then (a, (d, gl)::p) else ((d, gl)::a, p))
- ([], p_goals) a_goals
- in
- goals
-;;
-
-
-let simplify_theorems env theorems ?passive (active_list, active_table) =
- let pl, passive_table =
- match passive with
- | None -> [], None
- | Some ((pn, _), (pp, _), pt) ->
- let pn = List.map (fun e -> (Negative, e)) pn
- and pp = List.map (fun e -> (Positive, e)) pp in
- pn @ pp, Some pt
- in
- let a_theorems, p_theorems = theorems in
- let demodulate table theorem =
- let newmeta, newthm =
- Indexing.demodulation_theorem !maxmeta env table theorem in
- maxmeta := newmeta;
- theorem != newthm, newthm
- in
- let foldfun table (a, p) theorem =
- let changed, theorem = demodulate table theorem in
- if changed then (a, theorem::p) else (theorem::a, p)
- in
- let mapfun table theorem = snd (demodulate table theorem) in
- match passive_table with
- | None ->
- let p_theorems = List.map (mapfun active_table) p_theorems in
- List.fold_left (foldfun active_table) ([], p_theorems) a_theorems
- | Some passive_table ->
- let p_theorems = List.map (mapfun active_table) p_theorems in
- let p_theorems, a_theorems =
- List.fold_left (foldfun active_table) ([], p_theorems) a_theorems in
- let p_theorems = List.map (mapfun passive_table) p_theorems in
- List.fold_left (foldfun passive_table) ([], p_theorems) a_theorems
-;;
-
-
-let rec simpl env e others others_simpl =
- let active = others @ others_simpl in
- let tbl =
- List.fold_left
- (fun t (_, e) -> Indexing.index t e)
- Indexing.empty active
- in
- let res = forward_simplify env e (active, tbl) in
- match others with
- | hd::tl -> (
- match res with
- | None -> simpl env hd tl others_simpl
- | Some e -> simpl env hd tl (e::others_simpl)
- )
- | [] -> (
- match res with
- | None -> others_simpl
- | Some e -> e::others_simpl
- )
-;;
-
-let simplify_equalities env equalities =
- debug_print
- (lazy
- (Printf.sprintf "equalities:\n%s\n"
- (String.concat "\n"
- (List.map string_of_equality equalities))));
- debug_print (lazy "SIMPLYFYING EQUALITIES...");
- match equalities with
- | [] -> []
- | hd::tl ->
- let others = List.map (fun e -> (Positive, e)) tl in
- let res =
- List.rev (List.map snd (simpl env (Positive, hd) others []))
- in
- debug_print
- (lazy
- (Printf.sprintf "equalities AFTER:\n%s\n"
- (String.concat "\n"
- (List.map string_of_equality res))));
- res
-;;
-
-(* applies equality to goal to see if the goal can be closed *)
-let apply_equality_to_goal env equality goal =
- let module C = Cic in
- let module HL = HelmLibraryObjects in
- let module I = Inference in
- let metasenv, context, ugraph = env in
- let _, proof, (ty, left, right, _), metas, args = equality in
- let eqterm =
- C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); ty; left; right] in
- let gproof, gmetas, gterm = goal in
-(* debug_print *)
-(* (lazy *)
-(* (Printf.sprintf "APPLY EQUALITY TO GOAL: %s, %s" *)
-(* (string_of_equality equality) (CicPp.ppterm gterm))); *)
- try
- let subst, metasenv', _ =
- let menv = metasenv @ metas @ gmetas in
- Inference.unification menv context eqterm gterm ugraph
- in
- let newproof =
- match proof with
- | I.BasicProof t -> I.BasicProof (CicMetaSubst.apply_subst subst t)
- | I.ProofBlock (s, uri, nt, t, pe, p) ->
- I.ProofBlock (subst @ s, uri, nt, t, pe, p)
- | _ -> assert false
- in
- let newgproof =
- let rec repl = function
- | I.ProofGoalBlock (_, gp) -> I.ProofGoalBlock (newproof, gp)
- | I.NoProof -> newproof
- | I.BasicProof p -> newproof
- | I.SubProof (t, i, p) -> I.SubProof (t, i, repl p)
- | _ -> assert false
- in
- repl gproof
- in
- true, subst, newgproof
- with CicUnification.UnificationFailure _ ->
- false, [], I.NoProof
-;;
-
-
-
-let new_meta metasenv =
- let m = CicMkImplicit.new_meta metasenv [] in
- incr maxmeta;
- while !maxmeta <= m do incr maxmeta done;
- !maxmeta
-;;
-
-
-(* applies a theorem or an equality to goal, returning a list of subgoals or
- an indication of failure *)
-let apply_to_goal env theorems ?passive active goal =
- let metasenv, context, ugraph = env in
- let proof, metas, term = goal in
- (* debug_print *)
- (* (lazy *)
- (* (Printf.sprintf "apply_to_goal with goal: %s" *)
- (* (\* (string_of_proof proof) *\)(CicPp.ppterm term))); *)
- let status =
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- let proof', newmeta =
- let rec get_meta = function
- | SubProof (t, i, p) ->
- let t', i' = get_meta p in
- if i' = -1 then t, i else t', i'
- | ProofGoalBlock (_, p) -> get_meta p
- | _ -> Cic.Implicit None, -1
- in
- let p, m = get_meta proof in
- if m = -1 then
- let n = new_meta (metasenv @ metas) in
- Cic.Meta (n, irl), n
- else
- p, m
- in
- let metasenv = (newmeta, context, term)::metasenv @ metas in
- let bit = new_meta metasenv, context, term in
- let metasenv' = bit::metasenv in
- ((None, metasenv', Cic.Meta (newmeta, irl), term), newmeta)
- in
- let rec aux = function
- | [] -> `No
- | (theorem, thmty, _)::tl ->
- try
- let subst, (newproof, newgoals) =
- PrimitiveTactics.apply_tac_verbose_with_subst ~term:theorem status
- in
- if newgoals = [] then
- let _, _, p, _ = newproof in
- let newp =
- let rec repl = function
- | Inference.ProofGoalBlock (_, gp) ->
- Inference.ProofGoalBlock (Inference.BasicProof p, gp)
- | Inference.NoProof -> Inference.BasicProof p
- | Inference.BasicProof _ -> Inference.BasicProof p
- | Inference.SubProof (t, i, p2) ->
- Inference.SubProof (t, i, repl p2)
- | _ -> assert false
- in
- repl proof
- in
- let _, m = status in
- let subst = List.filter (fun (i, _) -> i = m) subst in
- `Ok (subst, [newp, metas, term])
- else
- let _, menv, p, _ = newproof in
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context
- in
- let goals =
- List.map
- (fun i ->
- let _, _, ty = CicUtil.lookup_meta i menv in
- let p' =
- let rec gp = function
- | SubProof (t, i, p) ->
- SubProof (t, i, gp p)
- | ProofGoalBlock (sp1, sp2) ->
- ProofGoalBlock (sp1, gp sp2)
- | BasicProof _
- | NoProof ->
- SubProof (p, i, BasicProof (Cic.Meta (i, irl)))
- | ProofSymBlock (s, sp) ->
- ProofSymBlock (s, gp sp)
- | ProofBlock (s, u, nt, t, pe, sp) ->
- ProofBlock (s, u, nt, t, pe, gp sp)
- in gp proof
- in
- (p', menv, ty))
- newgoals
- in
- let goals =
- let weight t =
- let w, m = weight_of_term t in
- w + 2 * (List.length m)
- in
- List.sort
- (fun (_, _, t1) (_, _, t2) ->
- Pervasives.compare (weight t1) (weight t2))
- goals
- in
- let best = aux tl in
- match best with
- | `Ok (_, _) -> best
- | `No -> `GoOn ([subst, goals])
- | `GoOn sl -> `GoOn ((subst, goals)::sl)
- with ProofEngineTypes.Fail msg ->
- aux tl
- in
- let r, s, l =
- if Inference.term_is_equality term then
- let rec appleq_a = function
- | [] -> false, [], []
- | (Positive, equality)::tl ->
- let ok, s, newproof = apply_equality_to_goal env equality goal in
- if ok then true, s, [newproof, metas, term] else appleq_a tl
- | _::tl -> appleq_a tl
- in
- let rec appleq_p = function
- | [] -> false, [], []
- | equality::tl ->
- let ok, s, newproof = apply_equality_to_goal env equality goal in
- if ok then true, s, [newproof, metas, term] else appleq_p tl
- in
- let al, _ = active in
- match passive with
- | None -> appleq_a al
- | Some (_, (pl, _), _) ->
- let r, s, l = appleq_a al in if r then r, s, l else appleq_p pl
- else
- false, [], []
- in
- if r = true then `Ok (s, l) else aux theorems
-;;
-
-
-(* sorts a conjunction of goals in order to detect earlier if it is
- unsatisfiable. Non-predicate goals are placed at the end of the list *)
-let sort_goal_conj (metasenv, context, ugraph) (depth, gl) =
- let gl =
- List.stable_sort
- (fun (_, e1, g1) (_, e2, g2) ->
- let ty1, _ =
- CicTypeChecker.type_of_aux' (e1 @ metasenv) context g1 ugraph
- and ty2, _ =
- CicTypeChecker.type_of_aux' (e2 @ metasenv) context g2 ugraph
- in
- let prop1 =
- let b, _ =
- CicReduction.are_convertible context (Cic.Sort Cic.Prop) ty1 ugraph
- in
- if b then 0 else 1
- and prop2 =
- let b, _ =
- CicReduction.are_convertible context (Cic.Sort Cic.Prop) ty2 ugraph
- in
- if b then 0 else 1
- in
- if prop1 = 0 && prop2 = 0 then
- let e1 = if Inference.term_is_equality g1 then 0 else 1
- and e2 = if Inference.term_is_equality g2 then 0 else 1 in
- e1 - e2
- else
- prop1 - prop2)
- gl
- in
- (depth, gl)
-;;
-
-
-let is_meta_closed goals =
- List.for_all (fun (_, _, g) -> CicUtil.is_meta_closed g) goals
-;;
-
-
-(* applies a series of theorems/equalities to a conjunction of goals *)
-let rec apply_to_goal_conj env theorems ?passive active (depth, goals) =
- let aux (goal, r) tl =
- let propagate_subst subst (proof, metas, term) =
- let rec repl = function
- | NoProof -> NoProof
- | BasicProof t ->
- BasicProof (CicMetaSubst.apply_subst subst t)
- | ProofGoalBlock (p, pb) ->
- let pb' = repl pb in
- ProofGoalBlock (p, pb')
- | SubProof (t, i, p) ->
- let t' = CicMetaSubst.apply_subst subst t in
- let p = repl p in
- SubProof (t', i, p)
- | ProofSymBlock (ens, p) -> ProofSymBlock (ens, repl p)
- | ProofBlock (s, u, nty, t, pe, p) ->
- ProofBlock (subst @ s, u, nty, t, pe, p)
- in (repl proof, metas, term)
- in
- (* let r = apply_to_goal env theorems ?passive active goal in *) (
- match r with
- | `No -> `No (depth, goals)
- | `GoOn sl ->
- let l =
- List.map
- (fun (s, gl) ->
- let tl = List.map (propagate_subst s) tl in
- sort_goal_conj env (depth+1, gl @ tl)) sl
- in
- `GoOn l
- | `Ok (subst, gl) ->
- if tl = [] then
- `Ok (depth, gl)
- else
- let p, _, _ = List.hd gl in
- let subproof =
- let rec repl = function
- | SubProof (_, _, p) -> repl p
- | ProofGoalBlock (p1, p2) ->
- ProofGoalBlock (repl p1, repl p2)
- | p -> p
- in
- build_proof_term (repl p)
- in
- let i =
- let rec get_meta = function
- | SubProof (_, i, p) ->
- let i' = get_meta p in
- if i' = -1 then i else i'
-(* max i (get_meta p) *)
- | ProofGoalBlock (_, p) -> get_meta p
- | _ -> -1
- in
- get_meta p
- in
- let subst =
- let _, (context, _, _) = List.hd subst in
- [i, (context, subproof, Cic.Implicit None)]
- in
- let tl = List.map (propagate_subst subst) tl in
- let conj = sort_goal_conj env (depth(* +1 *), tl) in
- `GoOn ([conj])
- )
- in
- if depth > !maxdepth || (List.length goals) > !maxwidth then
- `No (depth, goals)
- else
- let rec search_best res = function
- | [] -> res
- | goal::tl ->
- let r = apply_to_goal env theorems ?passive active goal in
- match r with
- | `Ok _ -> (goal, r)
- | `No -> search_best res tl
- | `GoOn l ->
- let newres =
- match res with
- | _, `Ok _ -> assert false
- | _, `No -> goal, r
- | _, `GoOn l2 ->
- if (List.length l) < (List.length l2) then goal, r else res
- in
- search_best newres tl
- in
- let hd = List.hd goals in
- let res = hd, (apply_to_goal env theorems ?passive active hd) in
- let best =
- match res with
- | _, `Ok _ -> res
- | _, _ -> search_best res (List.tl goals)
- in
- let res = aux best (List.filter (fun g -> g != (fst best)) goals) in
- match res with
- | `GoOn ([conj]) when is_meta_closed (snd conj) &&
- (List.length (snd conj)) < (List.length goals)->
- apply_to_goal_conj env theorems ?passive active conj
- | _ -> res
-;;
-
-
-(*
-module OrderedGoals = struct
- type t = int * (Inference.proof * Cic.metasenv * Cic.term) list
-
- let compare g1 g2 =
- let d1, l1 = g1
- and d2, l2 = g2 in
- let r = d2 - d1 in
- if r <> 0 then r
- else let r = (List.length l1) - (List.length l2) in
- if r <> 0 then r
- else
- let res = ref 0 in
- let _ =
- List.exists2
- (fun (_, _, t1) (_, _, t2) ->
- let r = Pervasives.compare t1 t2 in
- if r <> 0 then (
- res := r;
- true
- ) else
- false) l1 l2
- in !res
-end
-
-module GoalsSet = Set.Make(OrderedGoals);;
-
-
-exception SearchSpaceOver;;
-*)
-
-
-(*
-let apply_to_goals env is_passive_empty theorems active goals =
- debug_print (lazy "\n\n\tapply_to_goals\n\n");
- let add_to set goals =
- List.fold_left (fun s g -> GoalsSet.add g s) set goals
- in
- let rec aux set = function
- | [] ->
- debug_print (lazy "HERE!!!");
- if is_passive_empty then raise SearchSpaceOver else false, set
- | goals::tl ->
- let res = apply_to_goal_conj env theorems active goals in
- match res with
- | `Ok newgoals ->
- let _ =
- let d, p, t =
- match newgoals with
- | (d, (p, _, t)::_) -> d, p, t
- | _ -> assert false
- in
- debug_print
- (lazy
- (Printf.sprintf "\nOK!!!!\ndepth: %d\nProof: %s\ngoal: %s\n"
- d (string_of_proof p) (CicPp.ppterm t)))
- in
- true, GoalsSet.singleton newgoals
- | `GoOn newgoals ->
- let set' = add_to set (goals::tl) in
- let set' = add_to set' newgoals in
- false, set'
- | `No newgoals ->
- aux set tl
- in
- let n = List.length goals in
- let res, goals = aux (add_to GoalsSet.empty goals) goals in
- let goals = GoalsSet.elements goals in
- debug_print (lazy "\n\tapply_to_goals end\n");
- let m = List.length goals in
- if m = n && is_passive_empty then
- raise SearchSpaceOver
- else
- res, goals
-;;
-*)
-
-
-(* sorts the list of passive goals to minimize the search for a proof (doesn't
- work that well yet...) *)
-let sort_passive_goals goals =
- List.stable_sort
- (fun (d1, l1) (d2, l2) ->
- let r1 = d2 - d1
- and r2 = (List.length l1) - (List.length l2) in
- let foldfun ht (_, _, t) =
- let _ = List.map (fun i -> Hashtbl.replace ht i 1) (metas_of_term t)
- in ht
- in
- let m1 = Hashtbl.length (List.fold_left foldfun (Hashtbl.create 3) l1)
- and m2 = Hashtbl.length (List.fold_left foldfun (Hashtbl.create 3) l2)
- in let r3 = m1 - m2 in
- if r3 <> 0 then r3
- else if r2 <> 0 then r2
- else r1)
- (* let _, _, g1 = List.hd l1 *)
-(* and _, _, g2 = List.hd l2 in *)
-(* let e1 = if Inference.term_is_equality g1 then 0 else 1 *)
-(* and e2 = if Inference.term_is_equality g2 then 0 else 1 *)
-(* in let r4 = e1 - e2 in *)
-(* if r4 <> 0 then r3 else r1) *)
- goals
-;;
-
-
-let print_goals goals =
- (String.concat "\n"
- (List.map
- (fun (d, gl) ->
- let gl' =
- List.map
- (fun (p, _, t) ->
- (* (string_of_proof p) ^ ", " ^ *) (CicPp.ppterm t)) gl
- in
- Printf.sprintf "%d: %s" d (String.concat "; " gl')) goals))
-;;
-
-
-(* tries to prove the first conjunction in goals with applications of
- theorems/equalities, returning new sub-goals or an indication of success *)
-let apply_goal_to_theorems dbd env theorems ?passive active goals =
- let theorems, _ = theorems in
- let a_goals, p_goals = goals in
- let goal = List.hd a_goals in
- let not_in_active gl =
- not
- (List.exists
- (fun (_, gl') ->
- if (List.length gl) = (List.length gl') then
- List.for_all2 (fun (_, _, g1) (_, _, g2) -> g1 = g2) gl gl'
- else
- false)
- a_goals)
- in
- let aux theorems =
- let res = apply_to_goal_conj env theorems ?passive active goal in
- match res with
- | `Ok newgoals ->
- true, ([newgoals], [])
- | `No _ ->
- false, (a_goals, p_goals)
- | `GoOn newgoals ->
- let newgoals =
- List.filter
- (fun (d, gl) ->
- (d <= !maxdepth) && (List.length gl) <= !maxwidth &&
- not_in_active gl)
- newgoals in
- let p_goals = newgoals @ p_goals in
- let p_goals = sort_passive_goals p_goals in
- false, (a_goals, p_goals)
- in
- aux theorems
-;;
-
-
-let apply_theorem_to_goals env theorems active goals =
- let a_goals, p_goals = goals in
- let theorem = List.hd (fst theorems) in
- let theorems = [theorem] in
- let rec aux p = function
- | [] -> false, ([], p)
- | goal::tl ->
- let res = apply_to_goal_conj env theorems active goal in
- match res with
- | `Ok newgoals -> true, ([newgoals], [])
- | `No _ -> aux p tl
- | `GoOn newgoals -> aux (newgoals @ p) tl
- in
- let ok, (a, p) = aux p_goals a_goals in
- if ok then
- ok, (a, p)
- else
- let p_goals =
- List.stable_sort
- (fun (d1, l1) (d2, l2) ->
- let r = d2 - d1 in
- if r <> 0 then r
- else let r = (List.length l1) - (List.length l2) in
- if r <> 0 then r
- else
- let res = ref 0 in
- let _ =
- List.exists2
- (fun (_, _, t1) (_, _, t2) ->
- let r = Pervasives.compare t1 t2 in
- if r <> 0 then (res := r; true) else false) l1 l2
- in !res)
- p
- in
- ok, (a_goals, p_goals)
-;;
-
-
-(* given-clause algorithm with lazy reduction strategy *)
-let rec given_clause dbd env goals theorems passive active =
- let goals = simplify_goals env goals active in
- let ok, goals = activate_goal goals in
- (* let theorems = simplify_theorems env theorems active in *)
- if ok then
- let ok, goals = apply_goal_to_theorems dbd env theorems active goals in
- if ok then
- let proof =
- match (fst goals) with
- | (_, [proof, _, _])::_ -> Some proof
- | _ -> assert false
- in
- ParamodulationSuccess (proof, env)
- else
- given_clause_aux dbd env goals theorems passive active
- else
-(* let ok', theorems = activate_theorem theorems in *)
- let ok', theorems = false, theorems in
- if ok' then
- let ok, goals = apply_theorem_to_goals env theorems active goals in
- if ok then
- let proof =
- match (fst goals) with
- | (_, [proof, _, _])::_ -> Some proof
- | _ -> assert false
- in
- ParamodulationSuccess (proof, env)
- else
- given_clause_aux dbd env goals theorems passive active
- else
- if (passive_is_empty passive) then ParamodulationFailure
- else given_clause_aux dbd env goals theorems passive active
-
-and given_clause_aux dbd env goals theorems passive active =
- let time1 = Unix.gettimeofday () in
-
- let selection_estimate = get_selection_estimate () in
- let kept = size_of_passive passive in
- let passive =
- if !time_limit = 0. || !processed_clauses = 0 then
- passive
- else if !elapsed_time > !time_limit then (
- debug_print (lazy (Printf.sprintf "Time limit (%.2f) reached: %.2f\n"
- !time_limit !elapsed_time));
- make_passive [] []
- ) else if kept > selection_estimate then (
- debug_print
- (lazy (Printf.sprintf ("Too many passive equalities: pruning..." ^^
- "(kept: %d, selection_estimate: %d)\n")
- kept selection_estimate));
- prune_passive selection_estimate active passive
- ) else
- passive
- in
-
- let time2 = Unix.gettimeofday () in
- passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1);
-
- kept_clauses := (size_of_passive passive) + (size_of_active active);
- match passive_is_empty passive with
- | true -> (* ParamodulationFailure *)
- given_clause dbd env goals theorems passive active
- | false ->
- let (sign, current), passive = select env (fst goals) passive active in
- let time1 = Unix.gettimeofday () in
- let res = forward_simplify env (sign, current) ~passive active in
- let time2 = Unix.gettimeofday () in
- forward_simpl_time := !forward_simpl_time +. (time2 -. time1);
- match res with
- | None ->
- given_clause dbd env goals theorems passive active
- | Some (sign, current) ->
- if (sign = Negative) && (is_identity env current) then (
- debug_print
- (lazy (Printf.sprintf "OK!!! %s %s" (string_of_sign sign)
- (string_of_equality ~env current)));
- let _, proof, _, _, _ = current in
- ParamodulationSuccess (Some proof, env)
- ) else (
- debug_print
- (lazy "\n================================================");
- debug_print (lazy (Printf.sprintf "selected: %s %s"
- (string_of_sign sign)
- (string_of_equality ~env current)));
-
- let t1 = Unix.gettimeofday () in
- let new' = infer env sign current active in
- let t2 = Unix.gettimeofday () in
- infer_time := !infer_time +. (t2 -. t1);
-
- let res, goal' = contains_empty env new' in
- if res then
- let proof =
- match goal' with
- | Some goal -> let _, proof, _, _, _ = goal in Some proof
- | None -> None
- in
- ParamodulationSuccess (proof, env)
- else
- let t1 = Unix.gettimeofday () in
- let new' = forward_simplify_new env new' active in
- let t2 = Unix.gettimeofday () in
- let _ =
- forward_simpl_new_time :=
- !forward_simpl_new_time +. (t2 -. t1)
- in
- let active =
- match sign with
- | Negative -> active
- | Positive ->
- let t1 = Unix.gettimeofday () in
- let active, _, newa, _ =
- backward_simplify env ([], [current]) active
- in
- let t2 = Unix.gettimeofday () in
- backward_simpl_time :=
- !backward_simpl_time +. (t2 -. t1);
- match newa with
- | None -> active
- | Some (n, p) ->
- let al, tbl = active in
- let nn = List.map (fun e -> Negative, e) n in
- let pp, tbl =
- List.fold_right
- (fun e (l, t) ->
- (Positive, e)::l,
- Indexing.index tbl e)
- p ([], tbl)
- in
- nn @ al @ pp, tbl
- in
- match contains_empty env new' with
- | false, _ ->
- let active =
- let al, tbl = active in
- match sign with
- | Negative -> (sign, current)::al, tbl
- | Positive ->
- al @ [(sign, current)], Indexing.index tbl current
- in
- let passive = add_to_passive passive new' in
- given_clause dbd env goals theorems passive active
- | true, goal ->
- let proof =
- match goal with
- | Some goal ->
- let _, proof, _, _, _ = goal in Some proof
- | None -> None
- in
- ParamodulationSuccess (proof, env)
- )
-;;
-
-
-(** given-clause algorithm with full reduction strategy *)
-let rec given_clause_fullred dbd env goals theorems passive active =
- let goals = simplify_goals env goals ~passive active in
- let ok, goals = activate_goal goals in
-(* let theorems = simplify_theorems env theorems ~passive active in *)
- if ok then
-(* let _ = *)
-(* debug_print *)
-(* (lazy *)
-(* (Printf.sprintf "\ngoals = \nactive\n%s\npassive\n%s\n" *)
-(* (print_goals (fst goals)) (print_goals (snd goals)))); *)
-(* let current = List.hd (fst goals) in *)
-(* let p, _, t = List.hd (snd current) in *)
-(* debug_print *)
-(* (lazy *)
-(* (Printf.sprintf "goal activated:\n%s\n%s\n" *)
-(* (CicPp.ppterm t) (string_of_proof p))); *)
-(* in *)
- let ok, goals =
- apply_goal_to_theorems dbd env theorems ~passive active goals
- in
- if ok then
- let proof =
- match (fst goals) with
- | (_, [proof, _, _])::_ -> Some proof
- | _ -> assert false
- in
- ParamodulationSuccess (proof, env)
- else
- given_clause_fullred_aux dbd env goals theorems passive active
- else
-(* let ok', theorems = activate_theorem theorems in *)
-(* if ok' then *)
-(* let ok, goals = apply_theorem_to_goals env theorems active goals in *)
-(* if ok then *)
-(* let proof = *)
-(* match (fst goals) with *)
-(* | (_, [proof, _, _])::_ -> Some proof *)
-(* | _ -> assert false *)
-(* in *)
-(* ParamodulationSuccess (proof, env) *)
-(* else *)
-(* given_clause_fullred_aux env goals theorems passive active *)
-(* else *)
- if (passive_is_empty passive) then ParamodulationFailure
- else given_clause_fullred_aux dbd env goals theorems passive active
-
-and given_clause_fullred_aux dbd env goals theorems passive active =
- let time1 = Unix.gettimeofday () in
-
- let selection_estimate = get_selection_estimate () in
- let kept = size_of_passive passive in
- let passive =
- if !time_limit = 0. || !processed_clauses = 0 then
- passive
- else if !elapsed_time > !time_limit then (
- debug_print (lazy (Printf.sprintf "Time limit (%.2f) reached: %.2f\n"
- !time_limit !elapsed_time));
- make_passive [] []
- ) else if kept > selection_estimate then (
- debug_print
- (lazy (Printf.sprintf ("Too many passive equalities: pruning..." ^^
- "(kept: %d, selection_estimate: %d)\n")
- kept selection_estimate));
- prune_passive selection_estimate active passive
- ) else
- passive
- in
-
- let time2 = Unix.gettimeofday () in
- passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1);
-
- kept_clauses := (size_of_passive passive) + (size_of_active active);
- match passive_is_empty passive with
- | true -> (* ParamodulationFailure *)
- given_clause_fullred dbd env goals theorems passive active
- | false ->
- let (sign, current), passive = select env (fst goals) passive active in
- let time1 = Unix.gettimeofday () in
- let res = forward_simplify env (sign, current) ~passive active in
- let time2 = Unix.gettimeofday () in
- forward_simpl_time := !forward_simpl_time +. (time2 -. time1);
- match res with
- | None ->
- given_clause_fullred dbd env goals theorems passive active
- | Some (sign, current) ->
- if (sign = Negative) && (is_identity env current) then (
- debug_print
- (lazy (Printf.sprintf "OK!!! %s %s" (string_of_sign sign)
- (string_of_equality ~env current)));
- let _, proof, _, _, _ = current in
- ParamodulationSuccess (Some proof, env)
- ) else (
- debug_print
- (lazy "\n================================================");
- debug_print (lazy (Printf.sprintf "selected: %s %s"
- (string_of_sign sign)
- (string_of_equality ~env current)));
-
- let t1 = Unix.gettimeofday () in
- let new' = infer env sign current active in
- let t2 = Unix.gettimeofday () in
- infer_time := !infer_time +. (t2 -. t1);
-
- let active =
- if is_identity env current then active
- else
- let al, tbl = active in
- match sign with
- | Negative -> (sign, current)::al, tbl
- | Positive ->
- al @ [(sign, current)], Indexing.index tbl current
- in
- let rec simplify new' active passive =
- let t1 = Unix.gettimeofday () in
- let new' = forward_simplify_new env new' ~passive active in
- let t2 = Unix.gettimeofday () in
- forward_simpl_new_time :=
- !forward_simpl_new_time +. (t2 -. t1);
- let t1 = Unix.gettimeofday () in
- let active, passive, newa, retained =
- backward_simplify env new' ~passive active in
- let t2 = Unix.gettimeofday () in
- backward_simpl_time := !backward_simpl_time +. (t2 -. t1);
- match newa, retained with
- | None, None -> active, passive, new'
- | Some (n, p), None
- | None, Some (n, p) ->
- let nn, np = new' in
- simplify (nn @ n, np @ p) active passive
- | Some (n, p), Some (rn, rp) ->
- let nn, np = new' in
- simplify (nn @ n @ rn, np @ p @ rp) active passive
- in
- let active, passive, new' = simplify new' active passive in
-
- let k = size_of_passive passive in
- if k < (kept - 1) then
- processed_clauses := !processed_clauses + (kept - 1 - k);
-
- let _ =
- debug_print
- (lazy
- (Printf.sprintf "active:\n%s\n"
- (String.concat "\n"
- ((List.map
- (fun (s, e) -> (string_of_sign s) ^ " " ^
- (string_of_equality ~env e))
- (fst active))))))
- in
- let _ =
- match new' with
- | neg, pos ->
- debug_print
- (lazy
- (Printf.sprintf "new':\n%s\n"
- (String.concat "\n"
- ((List.map
- (fun e -> "Negative " ^
- (string_of_equality ~env e)) neg) @
- (List.map
- (fun e -> "Positive " ^
- (string_of_equality ~env e)) pos)))))
- in
- match contains_empty env new' with
- | false, _ ->
- let passive = add_to_passive passive new' in
- given_clause_fullred dbd env goals theorems passive active
- | true, goal ->
- let proof =
- match goal with
- | Some goal -> let _, proof, _, _, _ = goal in Some proof
- | None -> None
- in
- ParamodulationSuccess (proof, env)
- )
-;;
-
-
-let rec saturate_equations env goal accept_fun passive active =
- elapsed_time := Unix.gettimeofday () -. !start_time;
- if !elapsed_time > !time_limit then
- (active, passive)
- else
- let (sign, current), passive = select env [1, [goal]] passive active in
- let res = forward_simplify env (sign, current) ~passive active in
- match res with
- | None ->
- saturate_equations env goal accept_fun passive active
- | Some (sign, current) ->
- assert (sign = Positive);
- debug_print
- (lazy "\n================================================");
- debug_print (lazy (Printf.sprintf "selected: %s %s"
- (string_of_sign sign)
- (string_of_equality ~env current)));
- let new' = infer env sign current active in
- let active =
- if is_identity env current then active
- else
- let al, tbl = active in
- al @ [(sign, current)], Indexing.index tbl current
- in
- let rec simplify new' active passive =
- let new' = forward_simplify_new env new' ~passive active in
- let active, passive, newa, retained =
- backward_simplify env new' ~passive active in
- match newa, retained with
- | None, None -> active, passive, new'
- | Some (n, p), None
- | None, Some (n, p) ->
- let nn, np = new' in
- simplify (nn @ n, np @ p) active passive
- | Some (n, p), Some (rn, rp) ->
- let nn, np = new' in
- simplify (nn @ n @ rn, np @ p @ rp) active passive
- in
- let active, passive, new' = simplify new' active passive in
- let _ =
- debug_print
- (lazy
- (Printf.sprintf "active:\n%s\n"
- (String.concat "\n"
- ((List.map
- (fun (s, e) -> (string_of_sign s) ^ " " ^
- (string_of_equality ~env e))
- (fst active))))))
- in
- let _ =
- match new' with
- | neg, pos ->
- debug_print
- (lazy
- (Printf.sprintf "new':\n%s\n"
- (String.concat "\n"
- ((List.map
- (fun e -> "Negative " ^
- (string_of_equality ~env e)) neg) @
- (List.map
- (fun e -> "Positive " ^
- (string_of_equality ~env e)) pos)))))
- in
- let new' = match new' with _, pos -> [], List.filter accept_fun pos in
- let passive = add_to_passive passive new' in
- saturate_equations env goal accept_fun passive active
-;;
-
-
-
-
-let main dbd full term metasenv ugraph =
- let module C = Cic in
- let module T = CicTypeChecker in
- let module PET = ProofEngineTypes in
- let module PP = CicPp in
- let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in
- let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in
- let proof, goals = status in
- let goal' = List.nth goals 0 in
- let _, metasenv, meta_proof, _ = proof in
- let _, context, goal = CicUtil.lookup_meta goal' metasenv in
- let eq_indexes, equalities, maxm = find_equalities context proof in
- let lib_eq_uris, library_equalities, maxm =
-
- find_library_equalities dbd context (proof, goal') (maxm+2)
- in
- let library_equalities = List.map snd library_equalities in
- maxmeta := maxm+2; (* TODO ugly!! *)
- let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in
- let new_meta_goal, metasenv, type_of_goal =
- let _, context, ty = CicUtil.lookup_meta goal' metasenv in
- debug_print
- (lazy
- (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n\n" (CicPp.ppterm ty)));
- Cic.Meta (maxm+1, irl),
- (maxm+1, context, ty)::metasenv,
- ty
- in
- let env = (metasenv, context, ugraph) in
- let t1 = Unix.gettimeofday () in
- let theorems =
- if full then
- let theorems = find_library_theorems dbd env (proof, goal') lib_eq_uris in
- let context_hyp = find_context_hypotheses env eq_indexes in
- context_hyp @ theorems, []
- else
- let refl_equal =
- let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in
- UriManager.uri_of_string (us ^ "#xpointer(1/1/1)")
- in
- let t = CicUtil.term_of_uri refl_equal in
- let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in
- [(t, ty, [])], []
- in
- let t2 = Unix.gettimeofday () in
- debug_print
- (lazy
- (Printf.sprintf "Time to retrieve theorems: %.9f\n" (t2 -. t1)));
- let _ =
- debug_print
- (lazy
- (Printf.sprintf
- "Theorems:\n-------------------------------------\n%s\n"
- (String.concat "\n"
- (List.map
- (fun (t, ty, _) ->
- Printf.sprintf
- "Term: %s, type: %s" (CicPp.ppterm t) (CicPp.ppterm ty))
- (fst theorems)))))
- in
- (*try*)
- let goal = Inference.BasicProof new_meta_goal, [], goal in
- let equalities = simplify_equalities env (equalities@library_equalities) in
- let active = make_active () in
- let passive = make_passive [] equalities in
- Printf.printf "\ncurrent goal: %s\n"
- (let _, _, g = goal in CicPp.ppterm g);
- Printf.printf "\ncontext:\n%s\n" (PP.ppcontext context);
- Printf.printf "\nmetasenv:\n%s\n" (print_metasenv metasenv);
- Printf.printf "\nequalities:\n%s\n"
- (String.concat "\n"
- (List.map
- (string_of_equality ~env) equalities));
-(* (equalities @ library_equalities))); *)
- print_endline "--------------------------------------------------";
- let start = Unix.gettimeofday () in
- print_endline "GO!";
- start_time := Unix.gettimeofday ();
- let res =
- let goals = make_goals goal in
- (if !use_fullred then given_clause_fullred else given_clause)
- dbd env goals theorems passive active
- in
- let finish = Unix.gettimeofday () in
- let _ =
- match res with
- | ParamodulationFailure ->
- Printf.printf "NO proof found! :-(\n\n"
- | ParamodulationSuccess (Some proof, env) ->
- let proof = Inference.build_proof_term proof in
- Printf.printf "OK, found a proof!\n";
- (* REMEMBER: we have to instantiate meta_proof, we should use
- apply the "apply" tactic to proof and status
- *)
- let names = names_of_context context in
- print_endline (PP.pp proof names);
- let newmetasenv =
- List.fold_left
- (fun m (_, _, _, menv, _) -> m @ menv) metasenv equalities
- in
- let _ =
- (*try*)
- let ty, ug =
- CicTypeChecker.type_of_aux' newmetasenv context proof ugraph
- in
- print_endline (string_of_float (finish -. start));
- Printf.printf
- "\nGOAL was: %s\nPROOF has type: %s\nconvertible?: %s\n\n"
- (CicPp.pp type_of_goal names) (CicPp.pp ty names)
- (string_of_bool
- (fst (CicReduction.are_convertible
- context type_of_goal ty ug)));
- (*with e ->
- Printf.printf "\nEXCEPTION!!! %s\n" (Printexc.to_string e);
- Printf.printf "MAXMETA USED: %d\n" !maxmeta;
- print_endline (string_of_float (finish -. start));*)
- in
- ()
-
- | ParamodulationSuccess (None, env) ->
- Printf.printf "Success, but no proof?!?\n\n"
- in
- Printf.printf ("infer_time: %.9f\nforward_simpl_time: %.9f\n" ^^
- "forward_simpl_new_time: %.9f\n" ^^
- "backward_simpl_time: %.9f\n")
- !infer_time !forward_simpl_time !forward_simpl_new_time
- !backward_simpl_time;
- Printf.printf "passive_maintainance_time: %.9f\n"
- !passive_maintainance_time;
- Printf.printf " successful unification/matching time: %.9f\n"
- !Indexing.match_unif_time_ok;
- Printf.printf " failed unification/matching time: %.9f\n"
- !Indexing.match_unif_time_no;
- Printf.printf " indexing retrieval time: %.9f\n"
- !Indexing.indexing_retrieval_time;
- Printf.printf " demodulate_term.build_newtarget_time: %.9f\n"
- !Indexing.build_newtarget_time;
- Printf.printf "derived %d clauses, kept %d clauses.\n"
- !derived_clauses !kept_clauses;
-(*
- with exc ->
- print_endline ("EXCEPTION: " ^ (Printexc.to_string exc));
- raise exc
-*)
-;;
-
-
-let default_depth = !maxdepth
-and default_width = !maxwidth;;
-
-let reset_refs () =
- maxmeta := 0;
- symbols_counter := 0;
- weight_age_counter := !weight_age_ratio;
- processed_clauses := 0;
- start_time := 0.;
- elapsed_time := 0.;
- maximal_retained_equality := None;
- infer_time := 0.;
- forward_simpl_time := 0.;
- forward_simpl_new_time := 0.;
- backward_simpl_time := 0.;
- passive_maintainance_time := 0.;
- derived_clauses := 0;
- kept_clauses := 0;
-;;
-
-let saturate
- dbd ?(full=false) ?(depth=default_depth) ?(width=default_width) status =
- let module C = Cic in
- reset_refs ();
- Indexing.init_index ();
- maxdepth := depth;
- maxwidth := width;
- let proof, goal = status in
- let goal' = goal in
- let uri, metasenv, meta_proof, term_to_prove = proof in
- let _, context, goal = CicUtil.lookup_meta goal' metasenv in
- let eq_indexes, equalities, maxm = find_equalities context proof in
- let new_meta_goal, metasenv, type_of_goal =
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- let _, context, ty = CicUtil.lookup_meta goal' metasenv in
- debug_print
- (lazy (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty)));
- Cic.Meta (maxm+1, irl),
- (maxm+1, context, ty)::metasenv,
- ty
- in
- let ugraph = CicUniv.empty_ugraph in
- let env = (metasenv, context, ugraph) in
- let goal = Inference.BasicProof new_meta_goal, [], goal in
- let res, time =
- let t1 = Unix.gettimeofday () in
- let lib_eq_uris, library_equalities, maxm =
- find_library_equalities dbd context (proof, goal') (maxm+2)
- in
- let library_equalities = List.map snd library_equalities in
- let t2 = Unix.gettimeofday () in
- maxmeta := maxm+2;
- let equalities = simplify_equalities env (equalities@library_equalities) in
- debug_print
- (lazy
- (Printf.sprintf "Time to retrieve equalities: %.9f\n" (t2 -. t1)));
- let t1 = Unix.gettimeofday () in
- let theorems =
- if full then
- let thms = find_library_theorems dbd env (proof, goal') lib_eq_uris in
- let context_hyp = find_context_hypotheses env eq_indexes in
- context_hyp @ thms, []
- else
- let refl_equal =
- let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in
- UriManager.uri_of_string (us ^ "#xpointer(1/1/1)")
- in
- let t = CicUtil.term_of_uri refl_equal in
- let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in
- [(t, ty, [])], []
- in
- let t2 = Unix.gettimeofday () in
- let _ =
- debug_print
- (lazy
- (Printf.sprintf
- "Theorems:\n-------------------------------------\n%s\n"
- (String.concat "\n"
- (List.map
- (fun (t, ty, _) ->
- Printf.sprintf
- "Term: %s, type: %s"
- (CicPp.ppterm t) (CicPp.ppterm ty))
- (fst theorems)))));
- debug_print
- (lazy
- (Printf.sprintf "Time to retrieve theorems: %.9f\n" (t2 -. t1)));
- in
- let active = make_active () in
- let passive = make_passive [] equalities in
- let start = Unix.gettimeofday () in
- let res =
- let goals = make_goals goal in
- given_clause_fullred dbd env goals theorems passive active
- in
- let finish = Unix.gettimeofday () in
- (res, finish -. start)
- in
- match res with
- | ParamodulationSuccess (Some proof, env) ->
- debug_print (lazy "OK, found a proof!");
- let proof = Inference.build_proof_term proof in
- let names = names_of_context context in
- let newmetasenv =
- let i1 =
- match new_meta_goal with
- | C.Meta (i, _) -> i | _ -> assert false
- in
- List.filter (fun (i, _, _) -> i <> i1 && i <> goal') metasenv
- in
- let newstatus =
- try
- let ty, ug =
- CicTypeChecker.type_of_aux' newmetasenv context proof ugraph
- in
- debug_print (lazy (CicPp.pp proof [](* names *)));
- debug_print
- (lazy
- (Printf.sprintf
- "\nGOAL was: %s\nPROOF has type: %s\nconvertible?: %s\n"
- (CicPp.pp type_of_goal names) (CicPp.pp ty names)
- (string_of_bool
- (fst (CicReduction.are_convertible
- context type_of_goal ty ug)))));
- let equality_for_replace i t1 =
- match t1 with
- | C.Meta (n, _) -> n = i
- | _ -> false
- in
- let real_proof =
- ProofEngineReduction.replace
- ~equality:equality_for_replace
- ~what:[goal'] ~with_what:[proof]
- ~where:meta_proof
- in
- debug_print
- (lazy
- (Printf.sprintf "status:\n%s\n%s\n%s\n%s\n"
- (match uri with Some uri -> UriManager.string_of_uri uri
- | None -> "")
- (print_metasenv newmetasenv)
- (CicPp.pp real_proof [](* names *))
- (CicPp.pp term_to_prove names)));
- ((uri, newmetasenv, real_proof, term_to_prove), [])
- with CicTypeChecker.TypeCheckerFailure _ ->
- debug_print (lazy "THE PROOF DOESN'T TYPECHECK!!!");
- debug_print (lazy (CicPp.pp proof names));
- raise (ProofEngineTypes.Fail
- (lazy "Found a proof, but it doesn't typecheck"))
- in
- let tall = fs_time_info.build_all in
- let tdemodulate = fs_time_info.demodulate in
- let tsubsumption = fs_time_info.subsumption in
- debug_print (lazy (Printf.sprintf "\nTIME NEEDED: %.9f" time));
- debug_print (lazy (Printf.sprintf "\ntall: %.9f" tall));
- debug_print (lazy (Printf.sprintf "\ntdemod: %.9f" tdemodulate));
- debug_print (lazy (Printf.sprintf "\ntsubsumption: %.9f" tsubsumption));
- debug_print (lazy (Printf.sprintf "\ninfer_time: %.9f" !infer_time));
- debug_print (lazy (Printf.sprintf "\nforward_simpl_times: %.9f" !forward_simpl_time));
- debug_print (lazy (Printf.sprintf "\nforward_simpl_new_times: %.9f" !forward_simpl_new_time));
- debug_print (lazy (Printf.sprintf "\nbackward_simpl_times: %.9f" !backward_simpl_time));
- debug_print (lazy (Printf.sprintf "\npassive_maintainance_time: %.9f" !passive_maintainance_time));
- newstatus
- | _ ->
- raise (ProofEngineTypes.Fail (lazy "NO proof found"))
-;;
-
-(* dummy function called within matita to trigger linkage *)
-let init () = ();;
-
-
-let retrieve_and_print dbd term metasenv ugraph =
- let module C = Cic in
- let module T = CicTypeChecker in
- let module PET = ProofEngineTypes in
- let module PP = CicPp in
- let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in
- let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in
- let proof, goals = status in
- let goal' = List.nth goals 0 in
- let uri, metasenv, meta_proof, term_to_prove = proof in
- let _, context, goal = CicUtil.lookup_meta goal' metasenv in
- let eq_indexes, equalities, maxm = find_equalities context proof in
- let new_meta_goal, metasenv, type_of_goal =
- let irl =
- CicMkImplicit.identity_relocation_list_for_metavariable context in
- let _, context, ty = CicUtil.lookup_meta goal' metasenv in
- debug_print
- (lazy (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty)));
- Cic.Meta (maxm+1, irl),
- (maxm+1, context, ty)::metasenv,
- ty
- in
- let ugraph = CicUniv.empty_ugraph in
- let env = (metasenv, context, ugraph) in
- let t1 = Unix.gettimeofday () in
- let lib_eq_uris, library_equalities, maxm =
- find_library_equalities dbd context (proof, goal') (maxm+2) in
- let t2 = Unix.gettimeofday () in
- maxmeta := maxm+2;
- let equalities = (* equalities @ *) library_equalities in
- debug_print
- (lazy
- (Printf.sprintf "\n\nequalities:\n%s\n"
- (String.concat "\n"
- (List.map
- (fun (u, e) ->
-(* Printf.sprintf "%s: %s" *)
- (UriManager.string_of_uri u)
-(* (string_of_equality e) *)
- )
- equalities))));
- debug_print (lazy "SIMPLYFYING EQUALITIES...");
- let rec simpl e others others_simpl =
- let (u, e) = e in
- let active = List.map (fun (u, e) -> (Positive, e))
- (others @ others_simpl) in
- let tbl =
- List.fold_left
- (fun t (_, e) -> Indexing.index t e)
- Indexing.empty active
- in
- let res = forward_simplify env (Positive, e) (active, tbl) in
- match others with
- | hd::tl -> (
- match res with
- | None -> simpl hd tl others_simpl
- | Some e -> simpl hd tl ((u, (snd e))::others_simpl)
- )
- | [] -> (
- match res with
- | None -> others_simpl
- | Some e -> (u, (snd e))::others_simpl
- )
- in
- let _equalities =
- match equalities with
- | [] -> []
- | hd::tl ->
- let others = tl in (* List.map (fun e -> (Positive, e)) tl in *)
- let res =
- List.rev (simpl (*(Positive,*) hd others [])
- in
- debug_print
- (lazy
- (Printf.sprintf "\nequalities AFTER:\n%s\n"
- (String.concat "\n"
- (List.map
- (fun (u, e) ->
- Printf.sprintf "%s: %s"
- (UriManager.string_of_uri u)
- (string_of_equality e)
- )
- res))));
- res in
- debug_print
- (lazy
- (Printf.sprintf "Time to retrieve equalities: %.9f\n" (t2 -. t1)))
-;;
-
-
-let main_demod_equalities dbd term metasenv ugraph =
- let module C = Cic in
- let module T = CicTypeChecker in
- let module PET = ProofEngineTypes in
- let module PP = CicPp in
- let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in
- let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in
- let proof, goals = status in
- let goal' = List.nth goals 0 in
- let _, metasenv, meta_proof, _ = proof in
- let _, context, goal = CicUtil.lookup_meta goal' metasenv in
- let eq_indexes, equalities, maxm = find_equalities context proof in
- let lib_eq_uris, library_equalities, maxm =
- find_library_equalities dbd context (proof, goal') (maxm+2)
- in
- let library_equalities = List.map snd library_equalities in
- maxmeta := maxm+2; (* TODO ugly!! *)
- let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in
- let new_meta_goal, metasenv, type_of_goal =
- let _, context, ty = CicUtil.lookup_meta goal' metasenv in
- debug_print
- (lazy
- (Printf.sprintf "\n\nTRYING TO INFER EQUALITIES MATCHING: %s\n\n"
- (CicPp.ppterm ty)));
- Cic.Meta (maxm+1, irl),
- (maxm+1, context, ty)::metasenv,
- ty
- in
- let env = (metasenv, context, ugraph) in
- (*try*)
- let goal = Inference.BasicProof new_meta_goal, [], goal in
- let equalities = simplify_equalities env (equalities@library_equalities) in
- let active = make_active () in
- let passive = make_passive [] equalities in
- Printf.printf "\ncontext:\n%s\n" (PP.ppcontext context);
- Printf.printf "\nmetasenv:\n%s\n" (print_metasenv metasenv);
- Printf.printf "\nequalities:\n%s\n"
- (String.concat "\n"
- (List.map
- (string_of_equality ~env) equalities));
- print_endline "--------------------------------------------------";
- print_endline "GO!";
- start_time := Unix.gettimeofday ();
- if !time_limit < 1. then time_limit := 60.;
- let ra, rp =
- saturate_equations env goal (fun e -> true) passive active
- in
-
- let initial =
- List.fold_left (fun s e -> EqualitySet.add e s)
- EqualitySet.empty equalities
- in
- let addfun s e =
- if not (EqualitySet.mem e initial) then EqualitySet.add e s else s
- in
-
- let passive =
- match rp with
- | (n, _), (p, _), _ ->
- EqualitySet.elements (List.fold_left addfun EqualitySet.empty p)
- in
- let active =
- let l = List.map snd (fst ra) in
- EqualitySet.elements (List.fold_left addfun EqualitySet.empty l)
- in
- Printf.printf "\n\nRESULTS:\nActive:\n%s\n\nPassive:\n%s\n"
- (String.concat "\n" (List.map (string_of_equality ~env) active))
- (* (String.concat "\n"
- (List.map (fun e -> CicPp.ppterm (term_of_equality e)) active)) *)
-(* (String.concat "\n" (List.map (string_of_equality ~env) passive)); *)
- (String.concat "\n"
- (List.map (fun e -> CicPp.ppterm (term_of_equality e)) passive));
- print_newline ();
-(*
- with e ->
- debug_print (lazy ("EXCEPTION: " ^ (Printexc.to_string e)))
-*)
-;;
-
-let demodulate_tac ~dbd ~pattern ((proof,goal) as initialstatus) =
- let module I = Inference in
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = CicUtil.lookup_meta goal metasenv in
- let eq_indexes, equalities, maxm = I.find_equalities context proof in
- let lib_eq_uris, library_equalities, maxm =
- I.find_library_equalities dbd context (proof, goal) (maxm+2) in
- if library_equalities = [] then prerr_endline "VUOTA!!!";
- let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in
- let library_equalities = List.map snd library_equalities in
- let goalterm = Cic.Meta (metano,irl) in
- let initgoal = Inference.BasicProof goalterm, [], ty in
- let env = (metasenv, context, CicUniv.empty_ugraph) in
- let equalities = simplify_equalities env (equalities@library_equalities) in
- let table =
- List.fold_left
- (fun tbl eq -> Indexing.index tbl eq)
- Indexing.empty equalities
- in
- let newmeta,(newproof,newmetasenv, newty) = Indexing.demodulation_goal
- maxm (metasenv,context,CicUniv.empty_ugraph) table initgoal
- in
- if newmeta != maxm then
- begin
- let opengoal = Cic.Meta(maxm,irl) in
- let proofterm =
- Inference.build_proof_term ~noproof:opengoal newproof in
- let extended_metasenv = (maxm,context,newty)::metasenv in
- let extended_status =
- (curi,extended_metasenv,pbo,pty),goal in
- let (status,newgoals) =
- ProofEngineTypes.apply_tactic
- (PrimitiveTactics.apply_tac ~term:proofterm)
- extended_status in
- (status,maxm::newgoals)
- end
- else if newty = ty then
- raise (ProofEngineTypes.Fail (lazy "no progress"))
- else ProofEngineTypes.apply_tactic
- (ReductionTactics.simpl_tac ~pattern)
- initialstatus
-;;
-
-let demodulate_tac ~dbd ~pattern =
- ProofEngineTypes.mk_tactic (demodulate_tac ~dbd ~pattern)
-;;
+++ /dev/null
-(* Copyright (C) 2006, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $Id$ *)
-
-val saturate :
- HMysql.dbd ->
- ?full:bool ->
- ?depth:int ->
- ?width:int ->
- ProofEngineTypes.proof * ProofEngineTypes.goal ->
- (UriManager.uri option * Cic.conjecture list * Cic.term * Cic.term) *
- 'a list
-
-val weight_age_ratio : int ref
-val weight_age_counter: int ref
-val symbols_ratio: int ref
-val symbols_counter: int ref
-val use_fullred: bool ref
-val time_limit: float ref
-val maxwidth: int ref
-val maxdepth: int ref
-val retrieve_and_print: HMysql.dbd -> Cic.term -> Cic.conjecture list -> 'a -> unit
-val main_demod_equalities: HMysql.dbd ->
- Cic.term -> Cic.conjecture list -> CicUniv.universe_graph -> unit
-val main: HMysql.dbd ->
- bool -> Cic.term -> Cic.conjecture list -> CicUniv.universe_graph -> unit
-val demodulate_tac:
- dbd:HMysql.dbd ->
- pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
+++ /dev/null
-(* $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 ();;
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-let debug = true;;
-
-let debug_print s = if debug then prerr_endline (Lazy.force s);;
-
-let print_metasenv metasenv =
- String.concat "\n--------------------------\n"
- (List.map (fun (i, context, term) ->
- (string_of_int i) ^ " [\n" ^ (CicPp.ppcontext context) ^
- "\n] " ^ (CicPp.ppterm term))
- metasenv)
-;;
-
-
-
-
-let print_subst ?(prefix="\n") subst =
- String.concat prefix
- (List.map
- (fun (i, (c, t, ty)) ->
- Printf.sprintf "?%d -> %s : %s" i
- (CicPp.ppterm t) (CicPp.ppterm ty))
- subst)
-;;
-
-type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;;
-
-let string_of_comparison = function
- | Lt -> "<"
- | Le -> "<="
- | Gt -> ">"
- | Ge -> ">="
- | Eq -> "="
- | Incomparable -> "I"
-
-module OrderedTerm =
-struct
- type t = Cic.term
-
- let compare = Pervasives.compare
-end
-
-module TermSet = Set.Make(OrderedTerm);;
-module TermMap = Map.Make(OrderedTerm);;
-
-let symbols_of_term term =
- let module C = Cic in
- let rec aux map = function
- | C.Meta _ -> map
- | C.Appl l ->
- List.fold_left (fun res t -> (aux res t)) map l
- | t ->
- let map =
- try
- let c = TermMap.find t map in
- TermMap.add t (c+1) map
- with Not_found ->
- TermMap.add t 1 map
- in
- map
- in
- aux TermMap.empty term
-;;
-
-
-let metas_of_term term =
- let module C = Cic in
- let rec aux = function
- | C.Meta _ as t -> TermSet.singleton t
- | C.Appl l ->
- List.fold_left (fun res t -> TermSet.union res (aux t)) TermSet.empty l
- | t -> TermSet.empty (* TODO: maybe add other cases? *)
- in
- aux term
-;;
-
-
-(************************* rpo ********************************)
-let number = [
- UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)",3;
- UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)",6;
- UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)",9;
- HelmLibraryObjects.Peano.pred_URI, 12;
- HelmLibraryObjects.Peano.plus_URI, 15;
- HelmLibraryObjects.Peano.minus_URI, 18;
- HelmLibraryObjects.Peano.mult_URI, 21;
- UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1)",103;
- UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1/1)",106;
- UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1/2)",109;
- UriManager.uri_of_string "cic:/matita/nat/nat/pred.con",112;
- UriManager.uri_of_string "cic:/matita/nat/plus/plus.con",115;
- UriManager.uri_of_string "cic:/matita/nat/minus/minus.con",118;
- UriManager.uri_of_string "cic:/matita/nat/times/times.con",121;
- ]
-;;
-
-let atomic t =
- match t with
- Cic.Const _
- | Cic.MutInd _
- | Cic.MutConstruct _
- | Cic.Rel _ -> true
- | _ -> false
-
-let sig_order_const t1 t2 =
- try
- let u1 = CicUtil.uri_of_term t1 in
- let u2 = CicUtil.uri_of_term t2 in
- let n1 = List.assoc u1 number in
- let n2 = List.assoc u2 number in
- if n1 < n2 then Lt
- else if n1 > n2 then Gt
- else
- begin
- prerr_endline ("t1 = "^(CicPp.ppterm t1));
- prerr_endline ("t2 = "^(CicPp.ppterm t2));
- assert false
- end
- with
- Invalid_argument _
- | Not_found -> Incomparable
-
-let sig_order t1 t2 =
- match t1, t2 with
- Cic.Rel n, Cic.Rel m when n < m -> Gt (* inverted order *)
- | Cic.Rel n, Cic.Rel m when n = m -> Incomparable
- | Cic.Rel n, Cic.Rel m when n > m -> Lt
- | Cic.Rel _, _ -> Gt
- | _, Cic.Rel _ -> Lt
- | _,_ -> sig_order_const t1 t2
-
-let rec rpo_lt t1 t2 =
- let module C = Cic in
- let first_trie =
- match t1,t2 with
- C.Meta (_, _), C.Meta (_,_) -> false
- | C.Meta (_,_) , t2 -> TermSet.mem t1 (metas_of_term t2)
- | t1, C.Meta (_,_) -> false
- | C.Appl [h1;a1],C.Appl [h2;a2] when h1=h2 ->
- rpo_lt a1 a2
- | C.Appl (h1::arg1),C.Appl (h2::arg2) when h1=h2 ->
- if lex_lt arg1 arg2 then
- check_lt arg1 t2
- else false
- | C.Appl (h1::arg1),C.Appl (h2::arg2) ->
- (match sig_order h1 h2 with
- | Lt -> check_lt arg1 t2
- | _ -> false)
- | C.Appl (h1::arg1), t2 when atomic t2 ->
- (match sig_order h1 t2 with
- | Lt -> check_lt arg1 t2
- | _ -> false)
- | t1 , C.Appl (h2::arg2) when atomic t1 ->
- (match sig_order t1 h2 with
- | Lt -> true
- | _ -> false )
- | C.Appl [] , _ -> assert false
- | _ , C.Appl [] -> assert false
- | t1, t2 when (atomic t1 && atomic t2 && t1<>t2) ->
- (match sig_order t1 t2 with
- | Lt -> true
- | _ -> false)
- | _,_ -> false
- in
- if first_trie then true else
- match t2 with
- C.Appl (_::args) ->
- List.exists (fun a -> t1 = a || rpo_lt t1 a) args
- | _ -> false
-
-and lex_lt l1 l2 =
- match l1,l2 with
- [],[] -> false
- | [],_ -> assert false
- | _, [] -> assert false
- | a1::l1, a2::l2 when a1 = a2 -> lex_lt l1 l2
- | a1::_, a2::_ -> rpo_lt a1 a2
-
-and check_lt l t =
- List.fold_left
- (fun b a -> b && (rpo_lt a t))
- true l
-;;
-
-let rpo t1 t2 =
- if rpo_lt t2 t1 then Gt
- else if rpo_lt t1 t2 then Lt
- else Incomparable
-
-
-(*********************** fine rpo *****************************)
-
-(* (weight of constants, [(meta, weight_of_meta)]) *)
-type weight = int * (int * int) list;;
-
-let string_of_weight (cw, mw) =
- let s =
- String.concat ", "
- (List.map (function (m, w) -> Printf.sprintf "(%d,%d)" m w) mw)
- in
- Printf.sprintf "[%d; %s]" cw s
-
-
-let weight_of_term ?(consider_metas=true) term =
- let module C = Cic in
- let vars_dict = Hashtbl.create 5 in
- let rec aux = function
- | C.Meta (metano, _) when consider_metas ->
- (try
- let oldw = Hashtbl.find vars_dict metano in
- Hashtbl.replace vars_dict metano (oldw+1)
- with Not_found ->
- Hashtbl.add vars_dict metano 1);
- 0
- | C.Meta _ -> 0 (* "variables" are lighter than constants and functions...*)
-
- | C.Var (_, ens)
- | C.Const (_, ens)
- | C.MutInd (_, _, ens)
- | C.MutConstruct (_, _, _, ens) ->
- List.fold_left (fun w (u, t) -> (aux t) + w) 1 ens
-
- | C.Cast (t1, t2)
- | C.Lambda (_, t1, t2)
- | C.Prod (_, t1, t2)
- | C.LetIn (_, t1, t2) ->
- let w1 = aux t1 in
- let w2 = aux t2 in
- w1 + w2 + 1
-
- | C.Appl l -> List.fold_left (+) 0 (List.map aux l)
-
- | C.MutCase (_, _, outt, t, pl) ->
- let w1 = aux outt in
- let w2 = aux t in
- let w3 = List.fold_left (+) 0 (List.map aux pl) in
- w1 + w2 + w3 + 1
-
- | C.Fix (_, fl) ->
- List.fold_left (fun w (n, i, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl
-
- | C.CoFix (_, fl) ->
- List.fold_left (fun w (n, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl
-
- | _ -> 1
- in
- let w = aux term in
- let l =
- Hashtbl.fold (fun meta metaw resw -> (meta, metaw)::resw) vars_dict [] in
- let compare w1 w2 =
- match w1, w2 with
- | (m1, _), (m2, _) -> m2 - m1
- in
- (w, List.sort compare l) (* from the biggest meta to the smallest (0) *)
-;;
-
-
-module OrderedInt = struct
- type t = int
-
- let compare = Pervasives.compare
-end
-
-module IntSet = Set.Make(OrderedInt)
-
-let compute_equality_weight ty left right =
- let metasw = ref 0 in
- let weight_of t =
- let w, m = (weight_of_term ~consider_metas:true t) in
- metasw := !metasw + (2 * (List.length m));
- w
- in
- (* Warning: the following let cannot be expanded since it forces the
- right evaluation order!!!! *)
- let w = (weight_of ty) + (weight_of left) + (weight_of right) in
- w + !metasw
-;;
-
-
-(* returns a "normalized" version of the polynomial weight wl (with type
- * weight list), i.e. a list sorted ascending by meta number,
- * from 0 to maxmeta. wl must be sorted descending by meta number. Example:
- * normalize_weight 5 (3, [(3, 2); (1, 1)]) ->
- * (3, [(1, 1); (2, 0); (3, 2); (4, 0); (5, 0)]) *)
-let normalize_weight maxmeta (cw, wl) =
- let rec aux = function
- | 0 -> []
- | m -> (m, 0)::(aux (m-1))
- in
- let tmpl = aux maxmeta in
- let wl =
- List.sort
- (fun (m, _) (n, _) -> Pervasives.compare m n)
- (List.fold_left
- (fun res (m, w) -> (m, w)::(List.remove_assoc m res)) tmpl wl)
- in
- (cw, wl)
-;;
-
-
-let normalize_weights (cw1, wl1) (cw2, wl2) =
- let rec aux wl1 wl2 =
- match wl1, wl2 with
- | [], [] -> [], []
- | (m, w)::tl1, (n, w')::tl2 when m = n ->
- let res1, res2 = aux tl1 tl2 in
- (m, w)::res1, (n, w')::res2
- | (m, w)::tl1, ((n, w')::_ as wl2) when m < n ->
- let res1, res2 = aux tl1 wl2 in
- (m, w)::res1, (m, 0)::res2
- | ((m, w)::_ as wl1), (n, w')::tl2 when m > n ->
- let res1, res2 = aux wl1 tl2 in
- (n, 0)::res1, (n, w')::res2
- | [], (n, w)::tl2 ->
- let res1, res2 = aux [] tl2 in
- (n, 0)::res1, (n, w)::res2
- | (m, w)::tl1, [] ->
- let res1, res2 = aux tl1 [] in
- (m, w)::res1, (m, 0)::res2
- | _, _ -> assert false
- in
- let cmp (m, _) (n, _) = compare m n in
- let wl1, wl2 = aux (List.sort cmp wl1) (List.sort cmp wl2) in
- (cw1, wl1), (cw2, wl2)
-;;
-
-
-let compare_weights ?(normalize=false)
- ((h1, w1) as weight1) ((h2, w2) as weight2)=
- let (h1, w1), (h2, w2) =
- if normalize then
- normalize_weights weight1 weight2
- else
- (h1, w1), (h2, w2)
- in
- let res, diffs =
- try
- List.fold_left2
- (fun ((lt, eq, gt), diffs) w1 w2 ->
- match w1, w2 with
- | (meta1, w1), (meta2, w2) when meta1 = meta2 ->
- let diffs = (w1 - w2) + diffs in
- let r = compare w1 w2 in
- if r < 0 then (lt+1, eq, gt), diffs
- else if r = 0 then (lt, eq+1, gt), diffs
- else (lt, eq, gt+1), diffs
- | (meta1, w1), (meta2, w2) ->
- debug_print
- (lazy
- (Printf.sprintf "HMMM!!!! %s, %s\n"
- (string_of_weight weight1) (string_of_weight weight2)));
- assert false)
- ((0, 0, 0), 0) w1 w2
- with Invalid_argument _ ->
- debug_print
- (lazy
- (Printf.sprintf "Invalid_argument: %s{%s}, %s{%s}, normalize = %s\n"
- (string_of_weight (h1, w1)) (string_of_weight weight1)
- (string_of_weight (h2, w2)) (string_of_weight weight2)
- (string_of_bool normalize)));
- assert false
- in
- let hdiff = h1 - h2 in
- match res with
- | (0, _, 0) ->
- if hdiff < 0 then Lt
- else if hdiff > 0 then Gt
- else Eq (* Incomparable *)
- | (m, _, 0) ->
- if hdiff <= 0 then Lt
- else if (- diffs) >= hdiff then Le else Incomparable
- | (0, _, m) ->
- if hdiff >= 0 then Gt
- else if diffs >= (- hdiff) then Ge else Incomparable
- | (m, _, n) when m > 0 && n > 0 ->
- Incomparable
- | _ -> assert false
-
-;;
-
-
-let rec aux_ordering ?(recursion=true) t1 t2 =
- let module C = Cic in
- let compare_uris u1 u2 =
- let res =
- compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2) in
- if res < 0 then Lt
- else if res = 0 then Eq
- else Gt
- in
- match t1, t2 with
- | C.Meta _, _
- | _, C.Meta _ -> Incomparable
-
- | t1, t2 when t1 = t2 -> Eq
-
- | C.Rel n, C.Rel m -> if n > m then Lt else Gt
- | C.Rel _, _ -> Lt
- | _, C.Rel _ -> Gt
-
- | C.Const (u1, _), C.Const (u2, _) -> compare_uris u1 u2
- | C.Const _, _ -> Lt
- | _, C.Const _ -> Gt
-
- | C.MutInd (u1, _, _), C.MutInd (u2, _, _) -> compare_uris u1 u2
- | C.MutInd _, _ -> Lt
- | _, C.MutInd _ -> Gt
-
- | C.MutConstruct (u1, _, _, _), C.MutConstruct (u2, _, _, _) ->
- compare_uris u1 u2
- | C.MutConstruct _, _ -> Lt
- | _, C.MutConstruct _ -> Gt
-
- | C.Appl l1, C.Appl l2 when recursion ->
- let rec cmp t1 t2 =
- match t1, t2 with
- | [], [] -> Eq
- | _, [] -> Gt
- | [], _ -> Lt
- | hd1::tl1, hd2::tl2 ->
- let o = aux_ordering hd1 hd2 in
- if o = Eq then cmp tl1 tl2
- else o
- in
- cmp l1 l2
- | C.Appl (h1::t1), C.Appl (h2::t2) when not recursion ->
- aux_ordering h1 h2
-
- | t1, t2 ->
- debug_print
- (lazy
- (Printf.sprintf "These two terms are not comparable:\n%s\n%s\n\n"
- (CicPp.ppterm t1) (CicPp.ppterm t2)));
- Incomparable
-;;
-
-
-(* w1, w2 are the weights, they should already be normalized... *)
-let nonrec_kbo_w (t1, w1) (t2, w2) =
- match compare_weights w1 w2 with
- | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable
- | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable
- | Eq -> aux_ordering t1 t2
- | res -> res
-;;
-
-
-let nonrec_kbo t1 t2 =
- let w1 = weight_of_term t1 in
- let w2 = weight_of_term t2 in
- (*
- prerr_endline ("weight1 :"^(string_of_weight w1));
- prerr_endline ("weight2 :"^(string_of_weight w2));
- *)
- match compare_weights ~normalize:true w1 w2 with
- | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable
- | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable
- | Eq -> aux_ordering t1 t2
- | res -> res
-;;
-
-
-let rec kbo t1 t2 =
- let aux = aux_ordering ~recursion:false in
- let w1 = weight_of_term t1
- and w2 = weight_of_term t2 in
- let rec cmp t1 t2 =
- match t1, t2 with
- | [], [] -> Eq
- | _, [] -> Gt
- | [], _ -> Lt
- | hd1::tl1, hd2::tl2 ->
- let o =
- kbo hd1 hd2
- in
- if o = Eq then cmp tl1 tl2
- else o
- in
- let comparison = compare_weights ~normalize:true w1 w2 in
- match comparison with
- | Le ->
- let r = aux t1 t2 in
- if r = Lt then Lt
- else if r = Eq then (
- match t1, t2 with
- | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
- if cmp tl1 tl2 = Lt then Lt else Incomparable
- | _, _ -> Incomparable
- ) else Incomparable
- | Ge ->
- let r = aux t1 t2 in
- if r = Gt then Gt
- else if r = Eq then (
- match t1, t2 with
- | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
- if cmp tl1 tl2 = Gt then Gt else Incomparable
- | _, _ -> Incomparable
- ) else Incomparable
- | Eq ->
- let r = aux t1 t2 in
- if r = Eq then (
- match t1, t2 with
- | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
- cmp tl1 tl2
- | _, _ -> Incomparable
- ) else r
- | res -> res
-;;
-
-let rec ao t1 t2 =
- let get_hd t =
- match t with
- Cic.MutConstruct(uri,tyno,cno,_) -> Some(uri,tyno,cno)
- | Cic.Appl(Cic.MutConstruct(uri,tyno,cno,_)::_) ->
- Some(uri,tyno,cno)
- | _ -> None in
- let aux = aux_ordering ~recursion:false in
- let w1 = weight_of_term t1
- and w2 = weight_of_term t2 in
- let rec cmp t1 t2 =
- match t1, t2 with
- | [], [] -> Eq
- | _, [] -> Gt
- | [], _ -> Lt
- | hd1::tl1, hd2::tl2 ->
- let o =
- ao hd1 hd2
- in
- if o = Eq then cmp tl1 tl2
- else o
- in
- match get_hd t1, get_hd t2 with
- Some(_),None -> Lt
- | None,Some(_) -> Gt
- | _ ->
- let comparison = compare_weights ~normalize:true w1 w2 in
- match comparison with
- | Le ->
- let r = aux t1 t2 in
- if r = Lt then Lt
- else if r = Eq then (
- match t1, t2 with
- | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
- if cmp tl1 tl2 = Lt then Lt else Incomparable
- | _, _ -> Incomparable
- ) else Incomparable
- | Ge ->
- let r = aux t1 t2 in
- if r = Gt then Gt
- else if r = Eq then (
- match t1, t2 with
- | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
- if cmp tl1 tl2 = Gt then Gt else Incomparable
- | _, _ -> Incomparable
- ) else Incomparable
- | Eq ->
- let r = aux t1 t2 in
- if r = Eq then (
- match t1, t2 with
- | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
- cmp tl1 tl2
- | _, _ -> Incomparable
- ) else r
- | res -> res
-;;
-
-let names_of_context context =
- List.map
- (function
- | None -> None
- | Some (n, e) -> Some n)
- context
-;;
-
-
-let rec lpo t1 t2 =
- let module C = Cic in
- match t1, t2 with
- | t1, t2 when t1 = t2 -> Eq
- | t1, (C.Meta _ as m) ->
- if TermSet.mem m (metas_of_term t1) then Gt else Incomparable
- | (C.Meta _ as m), t2 ->
- if TermSet.mem m (metas_of_term t2) then Lt else Incomparable
- | C.Appl (hd1::tl1), C.Appl (hd2::tl2) -> (
- let res =
- let f o r t =
- if r then true else
- match lpo t o with
- | Gt | Eq -> true
- | _ -> false
- in
- let res1 = List.fold_left (f t2) false tl1 in
- if res1 then Gt
- else let res2 = List.fold_left (f t1) false tl2 in
- if res2 then Lt
- else Incomparable
- in
- if res <> Incomparable then
- res
- else
- let f o r t =
- if not r then false else
- match lpo o t with
- | Gt -> true
- | _ -> false
- in
- match aux_ordering hd1 hd2 with
- | Gt ->
- let res = List.fold_left (f t1) false tl2 in
- if res then Gt
- else Incomparable
- | Lt ->
- let res = List.fold_left (f t2) false tl1 in
- if res then Lt
- else Incomparable
- | Eq -> (
- let lex_res =
- try
- List.fold_left2
- (fun r t1 t2 -> if r <> Eq then r else lpo t1 t2)
- Eq tl1 tl2
- with Invalid_argument _ ->
- Incomparable
- in
- match lex_res with
- | Gt ->
- if List.fold_left (f t1) false tl2 then Gt
- else Incomparable
- | Lt ->
- if List.fold_left (f t2) false tl1 then Lt
- else Incomparable
- | _ -> Incomparable
- )
- | _ -> Incomparable
- )
- | t1, t2 -> aux_ordering t1 t2
-;;
-
-
-(* settable by the user... *)
-let compare_terms = ref nonrec_kbo;;
-(* let compare_terms = ref ao;; *)
-(* let compare_terms = ref rpo;; *)
-
-let guarded_simpl ?(debug=false) context t =
- if !compare_terms == nonrec_kbo then t
- else
- let t' = ProofEngineReduction.simpl context t in
- if t = t' then t else
- begin
- let simpl_order = !compare_terms t t' in
- if debug then
- prerr_endline ("comparing "^(CicPp.ppterm t)^(CicPp.ppterm t'));
- if simpl_order = Gt then (if debug then prerr_endline "GT";t')
- else (if debug then prerr_endline "NO_GT";t)
- end
-;;
-
-type equality_sign = Negative | Positive;;
-
-let string_of_sign = function
- | Negative -> "Negative"
- | Positive -> "Positive"
-;;
-
-
-type pos = Left | Right
-
-let string_of_pos = function
- | Left -> "Left"
- | Right -> "Right"
-;;
-
-
-let eq_ind_URI () = LibraryObjects.eq_ind_URI ~eq:(LibraryObjects.eq_URI ())
-let eq_ind_r_URI () = LibraryObjects.eq_ind_r_URI ~eq:(LibraryObjects.eq_URI ())
-let sym_eq_URI () = LibraryObjects.sym_eq_URI ~eq:(LibraryObjects.eq_URI ())
-let eq_XURI () =
- let s = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in
- UriManager.uri_of_string (s ^ "#xpointer(1/1/1)")
-let trans_eq_URI () = LibraryObjects.trans_eq_URI ~eq:(LibraryObjects.eq_URI ())
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* (weight of constants, [(meta, weight_of_meta)]) *)
-type weight = int * (int * int) list;;
-
-type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;;
-
-val print_metasenv: Cic.metasenv -> string
-
-val print_subst: ?prefix:string -> Cic.substitution -> string
-
-val string_of_weight: weight -> string
-
-val weight_of_term: ?consider_metas:bool -> Cic.term -> weight
-
-val normalize_weight: int -> weight -> weight
-
-val string_of_comparison: comparison -> string
-
-val compare_weights: ?normalize:bool -> weight -> weight -> comparison
-
-val nonrec_kbo: Cic.term -> Cic.term -> comparison
-
-val rpo: Cic.term -> Cic.term -> comparison
-
-val nonrec_kbo_w: (Cic.term * weight) -> (Cic.term * weight) -> comparison
-
-val names_of_context: Cic.context -> (Cic.name option) list
-
-module TermMap: Map.S with type key = Cic.term
-
-val symbols_of_term: Cic.term -> int TermMap.t
-
-val lpo: Cic.term -> Cic.term -> comparison
-
-val kbo: Cic.term -> Cic.term -> comparison
-
-val ao: Cic.term -> Cic.term -> comparison
-
-(** term-ordering function settable by the user *)
-val compare_terms: (Cic.term -> Cic.term -> comparison) ref
-
-val guarded_simpl: ?debug:bool -> Cic.context -> Cic.term -> Cic.term
-
-type equality_sign = Negative | Positive
-
-val string_of_sign: equality_sign -> string
-
-type pos = Left | Right
-
-val string_of_pos: pos -> string
-
-val compute_equality_weight: Cic.term -> Cic.term -> Cic.term -> int
-
-val debug_print: string Lazy.t -> unit
-
-val eq_ind_URI: unit -> UriManager.uri
-val eq_ind_r_URI: unit -> UriManager.uri
-val sym_eq_URI: unit -> UriManager.uri
-val eq_XURI: unit -> UriManager.uri
-val trans_eq_URI: unit -> UriManager.uri
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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)])
-;;
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* 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
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-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
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 12/04/2002 *)
-(* *)
-(* *)
-(******************************************************************************)
-
-(* $Id$ *)
-
-(* The code of this module is derived from the code of CicReduction *)
-
-exception Impossible of int;;
-exception ReferenceToConstant;;
-exception ReferenceToVariable;;
-exception ReferenceToCurrentProof;;
-exception ReferenceToInductiveDefinition;;
-exception WrongUriToInductiveDefinition;;
-exception WrongUriToConstant;;
-exception RelToHiddenHypothesis;;
-
-let alpha_equivalence =
- let module C = Cic in
- let rec aux t t' =
- if t = t' then true
- else
- match t,t' with
- C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2) ->
- UriManager.eq uri1 uri2 &&
- aux_exp_named_subst exp_named_subst1 exp_named_subst2
- | C.Cast (te,ty), C.Cast (te',ty') ->
- aux te te' && aux ty ty'
- | C.Prod (_,s,t), C.Prod (_,s',t') ->
- aux s s' && aux t t'
- | C.Lambda (_,s,t), C.Lambda (_,s',t') ->
- aux s s' && aux t t'
- | C.LetIn (_,s,t), C.LetIn(_,s',t') ->
- aux s s' && aux t t'
- | C.Appl l, C.Appl l' ->
- (try
- List.fold_left2
- (fun b t1 t2 -> b && aux t1 t2) true l l'
- with
- Invalid_argument _ -> false)
- | C.Const (uri,exp_named_subst1), C.Const (uri',exp_named_subst2) ->
- UriManager.eq uri uri' &&
- aux_exp_named_subst exp_named_subst1 exp_named_subst2
- | C.MutInd (uri,i,exp_named_subst1), C.MutInd (uri',i',exp_named_subst2) ->
- UriManager.eq uri uri' && i = i' &&
- aux_exp_named_subst exp_named_subst1 exp_named_subst2
- | C.MutConstruct (uri,i,j,exp_named_subst1),
- C.MutConstruct (uri',i',j',exp_named_subst2) ->
- UriManager.eq uri uri' && i = i' && j = j' &&
- aux_exp_named_subst exp_named_subst1 exp_named_subst2
- | C.MutCase (sp,i,outt,t,pl), C.MutCase (sp',i',outt',t',pl') ->
- UriManager.eq sp sp' && i = i' &&
- aux outt outt' && aux t t' &&
- (try
- List.fold_left2
- (fun b t1 t2 -> b && aux t1 t2) true pl pl'
- with
- Invalid_argument _ -> false)
- | C.Fix (i,fl), C.Fix (i',fl') ->
- i = i' &&
- (try
- List.fold_left2
- (fun b (_,i,ty,bo) (_,i',ty',bo') ->
- b && i = i' && aux ty ty' && aux bo bo'
- ) true fl fl'
- with
- Invalid_argument _ -> false)
- | C.CoFix (i,fl), C.CoFix (i',fl') ->
- i = i' &&
- (try
- List.fold_left2
- (fun b (_,ty,bo) (_,ty',bo') ->
- b && aux ty ty' && aux bo bo'
- ) true fl fl'
- with
- Invalid_argument _ -> false)
- | _,_ -> false (* we already know that t != t' *)
- and aux_exp_named_subst exp_named_subst1 exp_named_subst2 =
- try
- List.fold_left2
- (fun b (uri1,t1) (uri2,t2) ->
- b && UriManager.eq uri1 uri2 && aux t1 t2
- ) true exp_named_subst1 exp_named_subst2
- with
- Invalid_argument _ -> false
- in
- aux
-;;
-
-exception WhatAndWithWhatDoNotHaveTheSameLength;;
-
-(* "textual" replacement of several subterms with other ones *)
-let replace ~equality ~what ~with_what ~where =
- let module C = Cic in
- let find_image t =
- let rec find_image_aux =
- function
- [],[] -> raise Not_found
- | what::tl1,with_what::tl2 ->
- if equality what t then with_what else find_image_aux (tl1,tl2)
- | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
- in
- find_image_aux (what,with_what)
- in
- let rec aux t =
- try
- find_image t
- with Not_found ->
- match t with
- C.Rel _ -> t
- | C.Var (uri,exp_named_subst) ->
- C.Var (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
- | C.Meta _ -> t
- | C.Sort _ -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (aux te, aux ty)
- | C.Prod (n,s,t) -> C.Prod (n, aux s, aux t)
- | C.Lambda (n,s,t) -> C.Lambda (n, aux s, aux t)
- | C.LetIn (n,s,t) -> C.LetIn (n, aux s, aux t)
- | C.Appl l ->
- (* Invariant enforced: no application of an application *)
- (match List.map aux l with
- (C.Appl l')::tl -> C.Appl (l'@tl)
- | l' -> C.Appl l')
- | C.Const (uri,exp_named_subst) ->
- C.Const (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
- | C.MutInd (uri,i,exp_named_subst) ->
- C.MutInd
- (uri,i,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- C.MutConstruct
- (uri,i,j,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i,aux outt, aux t,List.map aux pl)
- | C.Fix (i,fl) ->
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) -> (name, i, aux ty, aux bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (name, aux ty, aux bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- in
- aux where
-;;
-
-(* replaces in a term a term with another one. *)
-(* Lifting are performed as usual. *)
-let replace_lifting ~equality ~what ~with_what ~where =
- let module C = Cic in
- let module S = CicSubstitution in
- let find_image what t =
- let rec find_image_aux =
- function
- [],[] -> raise Not_found
- | what::tl1,with_what::tl2 ->
- if equality what t then with_what else find_image_aux (tl1,tl2)
- | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
- in
- find_image_aux (what,with_what)
- in
- let rec substaux k what t =
- try
- S.lift (k-1) (find_image what t)
- with Not_found ->
- match t with
- C.Rel n as t -> t
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
- in
- C.Var (uri,exp_named_subst')
- | C.Meta (i, l) ->
- let l' =
- List.map
- (function
- None -> None
- | Some t -> Some (substaux k what t)
- ) l
- in
- C.Meta(i,l')
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (substaux k what te, substaux k what ty)
- | C.Prod (n,s,t) ->
- C.Prod
- (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
- | C.Lambda (n,s,t) ->
- C.Lambda
- (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
- | C.LetIn (n,s,t) ->
- C.LetIn
- (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
- | C.Appl (he::tl) ->
- (* Invariant: no Appl applied to another Appl *)
- let tl' = List.map (substaux k what) tl in
- begin
- match substaux k what he with
- C.Appl l -> C.Appl (l@tl')
- | _ as he' -> C.Appl (he'::tl')
- end
- | C.Appl _ -> assert false
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
- in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,i,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
- in
- C.MutInd (uri,i,exp_named_subst')
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
- in
- C.MutConstruct (uri,i,j,exp_named_subst')
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i,substaux k what outt, substaux k what t,
- List.map (substaux k what) pl)
- | C.Fix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) ->
- (name, i, substaux k what ty,
- substaux (k+len) (List.map (S.lift len) what) bo)
- ) fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) ->
- (name, substaux k what ty,
- substaux (k+len) (List.map (S.lift len) what) bo)
- ) fl
- in
- C.CoFix (i, substitutedfl)
- in
- substaux 1 what where
-;;
-
-(* replaces in a term a list of terms with other ones. *)
-(* Lifting are performed as usual. *)
-let replace_lifting_csc nnn ~equality ~what ~with_what ~where =
- let module C = Cic in
- let module S = CicSubstitution in
- let find_image t =
- let rec find_image_aux =
- function
- [],[] -> raise Not_found
- | what::tl1,with_what::tl2 ->
- if equality what t then with_what else find_image_aux (tl1,tl2)
- | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
- in
- find_image_aux (what,with_what)
- in
- let rec substaux k t =
- try
- S.lift (k-1) (find_image t)
- with Not_found ->
- match t with
- C.Rel n ->
- if n < k then C.Rel n else C.Rel (n + nnn)
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
- in
- C.Var (uri,exp_named_subst')
- | C.Meta (i, l) ->
- let l' =
- List.map
- (function
- None -> None
- | Some t -> Some (substaux k t)
- ) l
- in
- C.Meta(i,l')
- | C.Sort _ as t -> t
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
- | C.Prod (n,s,t) ->
- C.Prod (n, substaux k s, substaux (k + 1) t)
- | C.Lambda (n,s,t) ->
- C.Lambda (n, substaux k s, substaux (k + 1) t)
- | C.LetIn (n,s,t) ->
- C.LetIn (n, substaux k s, substaux (k + 1) t)
- | C.Appl (he::tl) ->
- (* Invariant: no Appl applied to another Appl *)
- let tl' = List.map (substaux k) tl in
- begin
- match substaux k he with
- C.Appl l -> C.Appl (l@tl')
- | _ as he' -> C.Appl (he'::tl')
- end
- | C.Appl _ -> assert false
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
- in
- C.Const (uri,exp_named_subst')
- | C.MutInd (uri,i,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
- in
- C.MutInd (uri,i,exp_named_subst')
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let exp_named_subst' =
- List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
- in
- C.MutConstruct (uri,i,j,exp_named_subst')
- | C.MutCase (sp,i,outt,t,pl) ->
- C.MutCase (sp,i,substaux k outt, substaux k t,
- List.map (substaux k) pl)
- | C.Fix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) ->
- (name, i, substaux k ty, substaux (k+len) bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) ->
- (name, substaux k ty, substaux (k+len) bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- in
- substaux 1 where
-;;
-
-(* Takes a well-typed term and fully reduces it. *)
-(*CSC: It does not perform reduction in a Case *)
-let reduce context =
- let rec reduceaux context l =
- let module C = Cic in
- let module S = CicSubstitution in
- function
- C.Rel n as t ->
- (match List.nth context (n-1) with
- Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
- | Some (_,C.Def (bo,_)) -> reduceaux context l (S.lift n bo)
- | None -> raise RelToHiddenHypothesis
- )
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- reduceaux_exp_named_subst context l exp_named_subst
- in
- (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.Constant _ -> raise ReferenceToConstant
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- | C.Variable (_,None,_,_,_) ->
- let t' = C.Var (uri,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.Variable (_,Some body,_,_,_) ->
- (reduceaux context l
- (CicSubstitution.subst_vars exp_named_subst' body))
- )
- | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
- | C.Sort _ as t -> t (* l should be empty *)
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) ->
- C.Cast (reduceaux context l te, reduceaux context l ty)
- | C.Prod (name,s,t) ->
- assert (l = []) ;
- C.Prod (name,
- reduceaux context [] s,
- reduceaux ((Some (name,C.Decl s))::context) [] t)
- | C.Lambda (name,s,t) ->
- (match l with
- [] ->
- C.Lambda (name,
- reduceaux context [] s,
- reduceaux ((Some (name,C.Decl s))::context) [] t)
- | he::tl -> reduceaux context tl (S.subst he t)
- (* when name is Anonimous the substitution should be superfluous *)
- )
- | C.LetIn (n,s,t) ->
- reduceaux context l (S.subst (reduceaux context [] s) t)
- | C.Appl (he::tl) ->
- let tl' = List.map (reduceaux context []) tl in
- reduceaux context (tl'@l) he
- | C.Appl [] -> raise (Impossible 1)
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- reduceaux_exp_named_subst context l exp_named_subst
- in
- (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.Constant (_,Some body,_,_,_) ->
- (reduceaux context l
- (CicSubstitution.subst_vars exp_named_subst' body))
- | C.Constant (_,None,_,_,_) ->
- let t' = C.Const (uri,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof (_,_,body,_,_,_) ->
- (reduceaux context l
- (CicSubstitution.subst_vars exp_named_subst' body))
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- | C.MutInd (uri,i,exp_named_subst) ->
- let exp_named_subst' =
- reduceaux_exp_named_subst context l exp_named_subst
- in
- let t' = C.MutInd (uri,i,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let exp_named_subst' =
- reduceaux_exp_named_subst context l exp_named_subst
- in
- let t' = C.MutConstruct (uri,i,j,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.MutCase (mutind,i,outtype,term,pl) ->
- let decofix =
- function
- C.CoFix (i,fl) ->
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- reduceaux context [] body'
- | C.Appl (C.CoFix (i,fl) :: tl) ->
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- let tl' = List.map (reduceaux context []) tl in
- reduceaux context tl' body'
- | t -> t
- in
- (match decofix (reduceaux context [] term) with
- C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
- | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
- let (arity, r) =
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in
- match o with
- C.InductiveDefinition (tl,_,r,_) ->
- let (_,_,arity,_) = List.nth tl i in
- (arity,r)
- | _ -> raise WrongUriToInductiveDefinition
- in
- let ts =
- let rec eat_first =
- function
- (0,l) -> l
- | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
- | _ -> raise (Impossible 5)
- in
- eat_first (r,tl)
- in
- reduceaux context (ts@l) (List.nth pl (j-1))
- | C.Cast _ | C.Implicit _ ->
- raise (Impossible 2) (* we don't trust our whd ;-) *)
- | _ ->
- let outtype' = reduceaux context [] outtype in
- let term' = reduceaux context [] term in
- let pl' = List.map (reduceaux context []) pl in
- let res =
- C.MutCase (mutind,i,outtype',term',pl')
- in
- if l = [] then res else C.Appl (res::l)
- )
- | C.Fix (i,fl) ->
- let tys =
- List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
- in
- let t' () =
- let fl' =
- List.map
- (function (n,recindex,ty,bo) ->
- (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
- ) fl
- in
- C.Fix (i, fl')
- in
- let (_,recindex,_,body) = List.nth fl i in
- let recparam =
- try
- Some (List.nth l recindex)
- with
- _ -> None
- in
- (match recparam with
- Some recparam ->
- (match reduceaux context [] recparam with
- C.MutConstruct _
- | C.Appl ((C.MutConstruct _)::_) ->
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
- fl
- body
- in
- (* Possible optimization: substituting whd recparam in l*)
- reduceaux context l body'
- | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
- )
- | None -> if l = [] then t' () else C.Appl ((t' ())::l)
- )
- | C.CoFix (i,fl) ->
- let tys =
- List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
- in
- let t' =
- let fl' =
- List.map
- (function (n,ty,bo) ->
- (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
- ) fl
- in
- C.CoFix (i, fl')
- in
- if l = [] then t' else C.Appl (t'::l)
- and reduceaux_exp_named_subst context l =
- List.map (function uri,t -> uri,reduceaux context [] t)
- in
- reduceaux context []
-;;
-
-exception WrongShape;;
-exception AlreadySimplified;;
-
-(* Takes a well-typed term and *)
-(* 1) Performs beta-iota-zeta reduction until delta reduction is needed *)
-(* 2) Attempts delta-reduction. If the residual is a Fix lambda-abstracted *)
-(* w.r.t. zero or more variables and if the Fix can be reductaed, than it*)
-(* is reduced, the delta-reduction is succesfull and the whole algorithm *)
-(* is applied again to the new redex; Step 3.1) is applied to the result *)
-(* of the recursive simplification. Otherwise, if the Fix can not be *)
-(* reduced, than the delta-reductions fails and the delta-redex is *)
-(* not reduced. Otherwise, if the delta-residual is not the *)
-(* lambda-abstraction of a Fix, then it performs step 3.2). *)
-(* 3.1) Folds the application of the constant to the arguments that did not *)
-(* change in every iteration, i.e. to the actual arguments for the *)
-(* lambda-abstractions that precede the Fix. *)
-(* 3.2) Computes the head beta-zeta normal form of the term. Then it tries *)
-(* reductions. If the reduction cannot be performed, it returns the *)
-(* original term (not the head beta-zeta normal form of the definiendum) *)
-(*CSC: It does not perform simplification in a Case *)
-
-let simpl context =
- (* reduceaux is equal to the reduceaux locally defined inside *)
- (* reduce, but for the const case. *)
- (**** Step 1 ****)
- let rec reduceaux context l =
- let module C = Cic in
- let module S = CicSubstitution in
- function
- C.Rel n as t ->
- (* we never perform delta expansion automatically *)
- if l = [] then t else C.Appl (t::l)
- | C.Var (uri,exp_named_subst) ->
- let exp_named_subst' =
- reduceaux_exp_named_subst context l exp_named_subst
- in
- (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.Constant _ -> raise ReferenceToConstant
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- | C.Variable (_,None,_,_,_) ->
- let t' = C.Var (uri,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.Variable (_,Some body,_,_,_) ->
- reduceaux context l
- (CicSubstitution.subst_vars exp_named_subst' body)
- )
- | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
- | C.Sort _ as t -> t (* l should be empty *)
- | C.Implicit _ as t -> t
- | C.Cast (te,ty) ->
- C.Cast (reduceaux context l te, reduceaux context [] ty)
- | C.Prod (name,s,t) ->
- assert (l = []) ;
- C.Prod (name,
- reduceaux context [] s,
- reduceaux ((Some (name,C.Decl s))::context) [] t)
- | C.Lambda (name,s,t) ->
- (match l with
- [] ->
- C.Lambda (name,
- reduceaux context [] s,
- reduceaux ((Some (name,C.Decl s))::context) [] t)
- | he::tl -> reduceaux context tl (S.subst he t)
- (* when name is Anonimous the substitution should be superfluous *)
- )
- | C.LetIn (n,s,t) ->
- reduceaux context l (S.subst (reduceaux context [] s) t)
- | C.Appl (he::tl) ->
- let tl' = List.map (reduceaux context []) tl in
- reduceaux context (tl'@l) he
- | C.Appl [] -> raise (Impossible 1)
- | C.Const (uri,exp_named_subst) ->
- let exp_named_subst' =
- reduceaux_exp_named_subst context l exp_named_subst
- in
- (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.Constant (_,Some body,_,_,_) ->
- try_delta_expansion context l
- (C.Const (uri,exp_named_subst'))
- (CicSubstitution.subst_vars exp_named_subst' body)
- | C.Constant (_,None,_,_,_) ->
- let t' = C.Const (uri,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof (_,_,body,_,_,_) -> reduceaux context l body
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- | C.MutInd (uri,i,exp_named_subst) ->
- let exp_named_subst' =
- reduceaux_exp_named_subst context l exp_named_subst
- in
- let t' = C.MutInd (uri,i,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.MutConstruct (uri,i,j,exp_named_subst) ->
- let exp_named_subst' =
- reduceaux_exp_named_subst context l exp_named_subst
- in
- let t' = C.MutConstruct(uri,i,j,exp_named_subst') in
- if l = [] then t' else C.Appl (t'::l)
- | C.MutCase (mutind,i,outtype,term,pl) ->
- let decofix =
- function
- C.CoFix (i,fl) ->
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- reduceaux context [] body'
- | C.Appl (C.CoFix (i,fl) :: tl) ->
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- let tl' = List.map (reduceaux context []) tl in
- reduceaux context tl' body'
- | t -> t
- in
- (match decofix (CicReduction.whd context term) with
- C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
- | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
- let (arity, r) =
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in
- match o with
- C.InductiveDefinition (tl,ingredients,r,_) ->
- let (_,_,arity,_) = List.nth tl i in
- (arity,r)
- | _ -> raise WrongUriToInductiveDefinition
- in
- let ts =
- let rec eat_first =
- function
- (0,l) -> l
- | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
- | _ -> raise (Impossible 5)
- in
- eat_first (r,tl)
- in
- reduceaux context (ts@l) (List.nth pl (j-1))
- | C.Cast _ | C.Implicit _ ->
- raise (Impossible 2) (* we don't trust our whd ;-) *)
- | _ ->
- let outtype' = reduceaux context [] outtype in
- let term' = reduceaux context [] term in
- let pl' = List.map (reduceaux context []) pl in
- let res =
- C.MutCase (mutind,i,outtype',term',pl')
- in
- if l = [] then res else C.Appl (res::l)
- )
- | C.Fix (i,fl) ->
- let tys =
- List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
- in
- let t' () =
- let fl' =
- List.map
- (function (n,recindex,ty,bo) ->
- (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
- ) fl
- in
- C.Fix (i, fl')
- in
- let (_,recindex,_,body) = List.nth fl i in
- let recparam =
- try
- Some (List.nth l recindex)
- with
- _ -> None
- in
- (match recparam with
- Some recparam ->
- (match reduceaux context [] recparam with
- C.MutConstruct _
- | C.Appl ((C.MutConstruct _)::_) ->
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
- fl
- body
- in
- (* Possible optimization: substituting whd recparam in l*)
- reduceaux context l body'
- | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
- )
- | None -> if l = [] then t' () else C.Appl ((t' ())::l)
- )
- | C.CoFix (i,fl) ->
- let tys =
- List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
- in
- let t' =
- let fl' =
- List.map
- (function (n,ty,bo) ->
- (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
- ) fl
- in
- C.CoFix (i, fl')
- in
- if l = [] then t' else C.Appl (t'::l)
- and reduceaux_exp_named_subst context l =
- List.map (function uri,t -> uri,reduceaux context [] t)
- (**** Step 2 ****)
- and try_delta_expansion context l term body =
- let module C = Cic in
- let module S = CicSubstitution in
- try
- let res,constant_args =
- let rec aux rev_constant_args l =
- function
- C.Lambda (name,s,t) ->
- begin
- match l with
- [] -> raise WrongShape
- | he::tl ->
- (* when name is Anonimous the substitution should *)
- (* be superfluous *)
- aux (he::rev_constant_args) tl (S.subst he t)
- end
- | C.LetIn (_,s,t) ->
- aux rev_constant_args l (S.subst s t)
- | C.Fix (i,fl) ->
- let (_,recindex,_,body) = List.nth fl i in
- let recparam =
- try
- List.nth l recindex
- with
- _ -> raise AlreadySimplified
- in
- (match CicReduction.whd context recparam with
- C.MutConstruct _
- | C.Appl ((C.MutConstruct _)::_) ->
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (function _ ->
- decr counter ; S.subst (C.Fix (!counter,fl))
- ) fl body
- in
- (* Possible optimization: substituting whd *)
- (* recparam in l *)
- reduceaux context l body',
- List.rev rev_constant_args
- | _ -> raise AlreadySimplified
- )
- | _ -> raise WrongShape
- in
- aux [] l body
- in
- (**** Step 3.1 ****)
- let term_to_fold, delta_expanded_term_to_fold =
- match constant_args with
- [] -> term,body
- | _ -> C.Appl (term::constant_args), C.Appl (body::constant_args)
- in
- let simplified_term_to_fold =
- reduceaux context [] delta_expanded_term_to_fold
- in
- replace (=) [simplified_term_to_fold] [term_to_fold] res
- with
- WrongShape ->
- (**** Step 3.2 ****)
- let rec aux l =
- function
- C.Lambda (name,s,t) ->
- (match l with
- [] -> raise AlreadySimplified
- | he::tl ->
- (* when name is Anonimous the substitution should *)
- (* be superfluous *)
- aux tl (S.subst he t))
- | C.LetIn (_,s,t) -> aux l (S.subst s t)
- | t ->
- let simplified = reduceaux context l t in
- if t = simplified then
- raise AlreadySimplified
- else
- simplified
- in
- (try aux l body
- with
- AlreadySimplified ->
- if l = [] then term else C.Appl (term::l))
- | AlreadySimplified ->
- (* If we performed delta-reduction, we would find a Fix *)
- (* not applied to a constructor. So, we refuse to perform *)
- (* delta-reduction. *)
- if l = [] then term else C.Appl (term::l)
- in
- reduceaux context []
-;;
-
-let unfold ?what context where =
- let contextlen = List.length context in
- let first_is_the_expandable_head_of_second context' t1 t2 =
- match t1,t2 with
- Cic.Const (uri,_), Cic.Const (uri',_)
- | Cic.Var (uri,_), Cic.Var (uri',_)
- | Cic.Const (uri,_), Cic.Appl (Cic.Const (uri',_)::_)
- | Cic.Var (uri,_), Cic.Appl (Cic.Var (uri',_)::_) -> UriManager.eq uri uri'
- | Cic.Const _, _
- | Cic.Var _, _ -> false
- | Cic.Rel n, Cic.Rel m
- | Cic.Rel n, Cic.Appl (Cic.Rel m::_) ->
- n + (List.length context' - contextlen) = m
- | Cic.Rel _, _ -> false
- | _,_ ->
- raise
- (ProofEngineTypes.Fail
- (lazy "The term to unfold is not a constant, a variable or a bound variable "))
- in
- let appl he tl =
- if tl = [] then he else Cic.Appl (he::tl) in
- let cannot_delta_expand t =
- raise
- (ProofEngineTypes.Fail
- (lazy ("The term " ^ CicPp.ppterm t ^ " cannot be delta-expanded"))) in
- let rec hd_delta_beta context tl =
- function
- Cic.Rel n as t ->
- (try
- match List.nth context (n-1) with
- Some (_,Cic.Decl _) -> cannot_delta_expand t
- | Some (_,Cic.Def (bo,_)) ->
- CicReduction.head_beta_reduce
- (appl (CicSubstitution.lift n bo) tl)
- | None -> raise RelToHiddenHypothesis
- with
- Failure _ -> assert false)
- | Cic.Const (uri,exp_named_subst) as t ->
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- (match o with
- Cic.Constant (_,Some body,_,_,_) ->
- CicReduction.head_beta_reduce
- (appl (CicSubstitution.subst_vars exp_named_subst body) tl)
- | Cic.Constant (_,None,_,_,_) -> cannot_delta_expand t
- | Cic.Variable _ -> raise ReferenceToVariable
- | Cic.CurrentProof _ -> raise ReferenceToCurrentProof
- | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- | Cic.Var (uri,exp_named_subst) as t ->
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- (match o with
- Cic.Constant _ -> raise ReferenceToConstant
- | Cic.CurrentProof _ -> raise ReferenceToCurrentProof
- | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- | Cic.Variable (_,Some body,_,_,_) ->
- CicReduction.head_beta_reduce
- (appl (CicSubstitution.subst_vars exp_named_subst body) tl)
- | Cic.Variable (_,None,_,_,_) -> cannot_delta_expand t
- )
- | Cic.Appl [] -> assert false
- | Cic.Appl (he::tl) -> hd_delta_beta context tl he
- | t -> cannot_delta_expand t
- in
- let context_and_matched_term_list =
- match what with
- None -> [context, where]
- | Some what ->
- let res =
- ProofEngineHelpers.locate_in_term
- ~equality:first_is_the_expandable_head_of_second
- what ~where context
- in
- if res = [] then
- raise
- (ProofEngineTypes.Fail
- (lazy ("Term "^ CicPp.ppterm what ^ " not found in " ^ CicPp.ppterm where)))
- else
- res
- in
- let reduced_terms =
- List.map
- (function (context,where) -> hd_delta_beta context [] where)
- context_and_matched_term_list in
- let whats = List.map snd context_and_matched_term_list in
- replace ~equality:(==) ~what:whats ~with_what:reduced_terms ~where
-;;
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception Impossible of int
-exception ReferenceToConstant
-exception ReferenceToVariable
-exception ReferenceToCurrentProof
-exception ReferenceToInductiveDefinition
-exception WrongUriToInductiveDefinition
-exception RelToHiddenHypothesis
-exception WrongShape
-exception AlreadySimplified
-exception WhatAndWithWhatDoNotHaveTheSameLength;;
-
-val alpha_equivalence: Cic.term -> Cic.term -> bool
-val replace :
- equality:('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
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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))))
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val clearbody: hyp: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
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
- (**
- current proof (proof uri * metas * (in)complete proof * term to be prooved)
- *)
-type proof = UriManager.uri 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
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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)
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val 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
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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
-
+++ /dev/null
-
- (* ring tactics *)
-val ring_tac: ProofEngineTypes.tactic
-
-(*Galla: spostata in variuosTactics.ml
- (* auxiliary tactics *)
-val elim_type_tac: term: Cic.term -> ProofEngineTypes.tactic
-*)
-
-(* spostata in variousTactics.ml
-val reflexivity_tac: ProofEngineTypes.tactic
-*)
+++ /dev/null
-(* Copyright (C) 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 _ _ -> ()) ()
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(*****************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 18/02/2003 *)
-(* *)
-(* *)
-(*****************************************************************************)
-
-(* $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
-;;
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val id_tac : ProofEngineTypes.tactic
-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
-
+++ /dev/null
-(* Copyright (C) 2004, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-let absurd = NegationTactics.absurd_tac
-let apply = PrimitiveTactics.apply_tac
-let assumption = VariousTactics.assumption_tac
-let auto = AutoTactic.auto_tac
-let change = ReductionTactics.change_tac
-let clear = ProofEngineStructuralRules.clear
-let clearbody = ProofEngineStructuralRules.clearbody
-let compare = DiscriminationTactics.compare_tac
-let constructor = IntroductionTactics.constructor_tac
-let contradiction = NegationTactics.contradiction_tac
-let cut = PrimitiveTactics.cut_tac
-let decide_equality = DiscriminationTactics.decide_equality_tac
-let decompose = EliminationTactics.decompose_tac
-let demodulate = Saturation.demodulate_tac
-let discriminate = DiscriminationTactics.discriminate_tac
-let elim_intros = PrimitiveTactics.elim_intros_tac
-let elim_intros_simpl = PrimitiveTactics.elim_intros_simpl_tac
-let elim_type = EliminationTactics.elim_type_tac
-let exact = PrimitiveTactics.exact_tac
-let exists = IntroductionTactics.exists_tac
-let fail = Tacticals.fail_tac
-let fold = ReductionTactics.fold_tac
-let fourier = FourierR.fourier_tac
-let fwd_simpl = FwdSimplTactic.fwd_simpl_tac
-let generalize = VariousTactics.generalize_tac
-let id = Tacticals.id_tac
-let injection = DiscriminationTactics.injection_tac
-let intros = PrimitiveTactics.intros_tac
-let inversion = Inversion.inversion_tac
-let lapply = FwdSimplTactic.lapply_tac
-let left = IntroductionTactics.left_tac
-let letin = PrimitiveTactics.letin_tac
-let normalize = ReductionTactics.normalize_tac
-let reduce = ReductionTactics.reduce_tac
-let reflexivity = EqualityTactics.reflexivity_tac
-let replace = EqualityTactics.replace_tac
-let rewrite = EqualityTactics.rewrite_tac
-let rewrite_simpl = EqualityTactics.rewrite_simpl_tac
-let right = IntroductionTactics.right_tac
-let ring = Ring.ring_tac
-let set_goal = ProofEngineStructuralRules.set_goal
-let simpl = ReductionTactics.simpl_tac
-let split = IntroductionTactics.split_tac
-let symmetry = EqualityTactics.symmetry_tac
-let transitivity = EqualityTactics.transitivity_tac
-let unfold = ReductionTactics.unfold_tac
-let whd = ReductionTactics.whd_tac
+++ /dev/null
-(* GENERATED FILE, DO NOT EDIT *)
-val absurd : term:Cic.term -> ProofEngineTypes.tactic
-val apply : term:Cic.term -> ProofEngineTypes.tactic
-val assumption : ProofEngineTypes.tactic
-val auto :
- ?depth:int ->
- ?width:int ->
- ?paramodulation:string ->
- ?full:string -> dbd:HMysql.dbd -> unit -> ProofEngineTypes.tactic
-val change :
- pattern:ProofEngineTypes.lazy_pattern ->
- Cic.lazy_term -> ProofEngineTypes.tactic
-val clear : hyp:string -> ProofEngineTypes.tactic
-val clearbody : hyp:string -> ProofEngineTypes.tactic
-val compare : term:Cic.term -> ProofEngineTypes.tactic
-val constructor : n:int -> ProofEngineTypes.tactic
-val contradiction : ProofEngineTypes.tactic
-val cut :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- Cic.term -> ProofEngineTypes.tactic
-val decide_equality : ProofEngineTypes.tactic
-val decompose :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?user_types:(UriManager.uri * int) list ->
- dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic
-val demodulate :
- dbd:HMysql.dbd ->
- pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val discriminate : term:Cic.term -> ProofEngineTypes.tactic
-val elim_intros :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic
-val elim_intros_simpl :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic
-val elim_type :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic
-val exact : term:Cic.term -> ProofEngineTypes.tactic
-val exists : ProofEngineTypes.tactic
-val fail : ProofEngineTypes.tactic
-val fold :
- reduction:ProofEngineTypes.lazy_reduction ->
- term:Cic.lazy_term ->
- pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val fourier : ProofEngineTypes.tactic
-val fwd_simpl :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic
-val generalize :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val id : ProofEngineTypes.tactic
-val injection : term:Cic.term -> ProofEngineTypes.tactic
-val intros :
- ?howmany:int ->
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- unit -> ProofEngineTypes.tactic
-val inversion : term:Cic.term -> ProofEngineTypes.tactic
-val lapply :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ?how_many:int ->
- ?to_what:Cic.term list -> Cic.term -> ProofEngineTypes.tactic
-val left : ProofEngineTypes.tactic
-val letin :
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- Cic.term -> ProofEngineTypes.tactic
-val normalize :
- pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val reduce : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val reflexivity : ProofEngineTypes.tactic
-val replace :
- pattern:ProofEngineTypes.lazy_pattern ->
- with_what:Cic.lazy_term -> ProofEngineTypes.tactic
-val rewrite :
- direction:[ `LeftToRight | `RightToLeft ] ->
- pattern:ProofEngineTypes.lazy_pattern ->
- Cic.term -> ProofEngineTypes.tactic
-val rewrite_simpl :
- direction:[ `LeftToRight | `RightToLeft ] ->
- pattern:ProofEngineTypes.lazy_pattern ->
- Cic.term -> ProofEngineTypes.tactic
-val right : ProofEngineTypes.tactic
-val ring : ProofEngineTypes.tactic
-val set_goal : int -> ProofEngineTypes.tactic
-val simpl : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val split : ProofEngineTypes.tactic
-val symmetry : ProofEngineTypes.tactic
-val transitivity : term:Cic.term -> ProofEngineTypes.tactic
-val unfold :
- Cic.lazy_term option ->
- pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
-val whd : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $Id$ *)
-
-
-(* TODO se ce n'e' piu' di una, prende la prima che trova... sarebbe meglio
-chiedere: find dovrebbe restituire una lista di hyp (?) da passare all'utonto con una
-funzione di callback che restituisce la (sola) hyp da applicare *)
-
-let assumption_tac =
- let module PET = ProofEngineTypes in
- let assumption_tac status =
- let (proof, goal) = status in
- let module C = Cic in
- let module R = CicReduction in
- let module S = CicSubstitution in
- let module PT = PrimitiveTactics in
- let _,metasenv,_,_ = proof in
- let _,context,ty = CicUtil.lookup_meta goal metasenv in
- let rec find n = function
- hd::tl ->
- (match hd with
- (Some (_, C.Decl t)) when
- fst (R.are_convertible context (S.lift n t) ty
- CicUniv.empty_ugraph) -> n
- | (Some (_, C.Def (_,Some ty'))) when
- fst (R.are_convertible context (S.lift n ty') ty
- CicUniv.empty_ugraph) -> n
- | (Some (_, C.Def (t,None))) ->
- let ty_t, u = (* TASSI: FIXME *)
- CicTypeChecker.type_of_aux' metasenv context (S.lift n t)
- CicUniv.empty_ugraph in
- let b,_ = R.are_convertible context ty_t ty u in
- if b then n else find (n+1) tl
- | _ -> find (n+1) tl
- )
- | [] -> raise (PET.Fail (lazy "Assumption: No such assumption"))
- in PET.apply_tactic (PT.apply_tac ~term:(C.Rel (find 1 context))) status
- in
- PET.mk_tactic assumption_tac
-;;
-
-(* ANCORA DA DEBUGGARE *)
-
-exception UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly;;
-exception TheSelectedTermsMustLiveInTheGoalContext
-exception AllSelectedTermsMustBeConvertible;;
-exception GeneralizationInHypothesesNotImplementedYet;;
-
-let generalize_tac
- ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[])
- pattern
- =
- let module PET = ProofEngineTypes in
- let generalize_tac mk_fresh_name_callback
- ~pattern:(term,hyps_pat,concl_pat) status
- =
- if hyps_pat <> [] then raise GeneralizationInHypothesesNotImplementedYet;
- let (proof, goal) = status in
- let module C = Cic in
- let module P = PrimitiveTactics in
- let module T = Tacticals in
- let uri,metasenv,pbo,pty = proof in
- let (_,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in
- let subst,metasenv,u,selected_hyps,terms_with_context =
- ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph
- ~conjecture ~pattern in
- let context = CicMetaSubst.apply_subst_context subst context in
- let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
- let pbo = CicMetaSubst.apply_subst subst pbo in
- let pty = CicMetaSubst.apply_subst subst pty in
- let term =
- match term with
- None -> None
- | Some term ->
- Some (fun context metasenv ugraph ->
- let term, metasenv, ugraph = term context metasenv ugraph in
- CicMetaSubst.apply_subst subst term,
- CicMetaSubst.apply_subst_metasenv subst metasenv,
- ugraph)
- in
- let u,typ,term, metasenv' =
- let context_of_t, (t, metasenv, u) =
- match terms_with_context, term with
- [], None ->
- raise
- UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly
- | [], Some t -> context, t context metasenv u
- | (context_of_t, _)::_, Some t ->
- context_of_t, t context_of_t metasenv u
- | (context_of_t, t)::_, None -> context_of_t, (t, metasenv, u)
- in
- let t,subst,metasenv' =
- try
- CicMetaSubst.delift_rels [] metasenv
- (List.length context_of_t - List.length context) t
- with
- CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
- raise TheSelectedTermsMustLiveInTheGoalContext
- in
- (*CSC: I am not sure about the following two assertions;
- maybe I need to propagate the new subst and metasenv *)
- assert (subst = []);
- assert (metasenv' = metasenv);
- let typ,u = CicTypeChecker.type_of_aux' ~subst metasenv context t u in
- u,typ,t,metasenv
- in
- (* We need to check:
- 1. whether they live in the context of the goal;
- if they do they are also well-typed since they are closed subterms
- of a well-typed term in the well-typed context of the well-typed
- term
- 2. whether they are convertible
- *)
- ignore (
- List.fold_left
- (fun u (context_of_t,t) ->
- (* 1 *)
- let t,subst,metasenv'' =
- try
- CicMetaSubst.delift_rels [] metasenv'
- (List.length context_of_t - List.length context) t
- with
- CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
- raise TheSelectedTermsMustLiveInTheGoalContext in
- (*CSC: I am not sure about the following two assertions;
- maybe I need to propagate the new subst and metasenv *)
- assert (subst = []);
- assert (metasenv'' = metasenv');
- (* 2 *)
- let b,u1 = CicReduction.are_convertible ~subst context term t u in
- if not b then
- raise AllSelectedTermsMustBeConvertible
- else
- u1
- ) u terms_with_context) ;
- let status = (uri,metasenv',pbo,pty),goal in
- let proof,goals =
- PET.apply_tactic
- (T.thens
- ~start:
- (P.cut_tac
- (C.Prod(
- (mk_fresh_name_callback metasenv context C.Anonymous ~typ:typ),
- typ,
- (ProofEngineReduction.replace_lifting_csc 1
- ~equality:(==)
- ~what:(List.map snd terms_with_context)
- ~with_what:(List.map (function _ -> C.Rel 1) terms_with_context)
- ~where:ty)
- )))
- ~continuations:
- [(P.apply_tac ~term:(C.Appl [C.Rel 1; CicSubstitution.lift 1 term])) ;
- T.id_tac])
- status
- in
- let _,metasenv'',_,_ = proof in
- (* CSC: the following is just a bad approximation since a meta
- can be closed and then re-opened! *)
- (proof,
- goals @
- (List.filter
- (fun j -> List.exists (fun (i,_,_) -> i = j) metasenv'')
- (ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv
- ~newmetasenv:metasenv')))
- in
- PET.mk_tactic (generalize_tac mk_fresh_name_callback ~pattern)
-;;
+++ /dev/null
-
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception AllSelectedTermsMustBeConvertible;;
-
-val assumption_tac: ProofEngineTypes.tactic
-
-val generalize_tac:
- ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
- ProofEngineTypes.lazy_pattern ->
- ProofEngineTypes.tactic
-
+++ /dev/null
-threadSafe.cmo: threadSafe.cmi
-threadSafe.cmx: threadSafe.cmi
-extThread.cmo: extThread.cmi
-extThread.cmx: extThread.cmi
+++ /dev/null
-
-PACKAGE = thread
-INTERFACE_FILES = threadSafe.mli extThread.mli
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-
-all: thread_fake.cma
-opt: thread_fake.cmxa
-
-include ../../Makefile.defs
-include ../Makefile.common
-
-fake/threadSafe.cmi: fake/threadSafe.mli
- @echo " OCAMLC $<"
- @cd fake/ \
- && ocamlfind ocamlc -c threadSafe.mli
-thread_fake.cma: fake/threadSafe.cmi
- @echo " OCAMLC -a $@"
- @cd fake/ \
- && ocamlfind ocamlc -a -o $@ threadSafe.ml \
- && cp $@ ../
-thread_fake.cmxa: fake/threadSafe.cmi
- @echo " OCAMLOPT -a $@"
- @cd fake/ \
- && ocamlfind opt -a -o $@ threadSafe.ml \
- && cp $@ ../
-
-clean: clean_fake
-clean_fake:
- rm -f fake/*.cm[aiox] fake/*.cmxa fake/*.[ao]
- rm -f thread_fake.cma thread_fake.cmxa
-
+++ /dev/null
-(*
- * 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 ])
-
+++ /dev/null
-(*
- * Copyright (C) 2003:
- * Stefano Zacchiroli <zack@cs.unibo.it>
- * for the HELM Team http://helm.cs.unibo.it/
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(** {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
-
+++ /dev/null
-(*
- * 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
-
+++ /dev/null
-(*
- * 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
-
+++ /dev/null
-(*
- * 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
-
+++ /dev/null
-(*
- * 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
-
+++ /dev/null
-uriManager.cmo: uriManager.cmi
-uriManager.cmx: uriManager.cmi
+++ /dev/null
-PACKAGE = urimanager
-PREDICATES =
-
-INTERFACE_FILES = uriManager.mli
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-EXTRA_OBJECTS_TO_INSTALL =
-EXTRA_OBJECTS_TO_CLEAN =
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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)
-
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception 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
-
+++ /dev/null
-utf8Macro.cmo: utf8MacroTable.cmo utf8Macro.cmi
-utf8Macro.cmx: utf8MacroTable.cmx utf8Macro.cmi
+++ /dev/null
-PACKAGE = utf8_macros
-PREDICATES =
-MAKE_TABLE_PACKAGES = helm-xml
-
-# modules which have both a .ml and a .mli
-INTERFACE_FILES = utf8Macro.mli
-IMPLEMENTATION_FILES = utf8MacroTable.ml $(INTERFACE_FILES:%.mli=%.ml)
-EXTRA_OBJECTS_TO_INSTALL =
-EXTRA_OBJECTS_TO_CLEAN =
-
-all: utf8_macros.cma pa_unicode_macro.cma
-
-make_table: make_table.ml
- @echo " OCAMLC $<"
- @$(OCAMLFIND) ocamlc -package $(MAKE_TABLE_PACKAGES) -linkpkg -o $@ $^
-
-utf8MacroTable.ml:
- ./make_table $@
-utf8MacroTable.cmo: utf8MacroTable.ml
- @echo " OCAMLC $<"
- @$(OCAMLFIND) ocamlc -c $<
-
-pa_unicode_macro.cmo: pa_unicode_macro.ml utf8Macro.cmo
- @echo " OCAMLC $<"
- @$(OCAMLFIND) ocamlc -package camlp4 -pp "camlp4o q_MLast.cmo pa_extend.cmo -loc loc" -c $<
-pa_unicode_macro.cma: utf8MacroTable.cmo utf8Macro.cmo pa_unicode_macro.cmo
- @echo " OCAMLC -a $@"
- @$(OCAMLFIND) ocamlc -a -o $@ $^
-
-.PHONY: test
-test: test.ml
- $(OCAMLFIND) ocamlc -package helm-utf8_macros -syntax camlp4o $< -o $@
-
-clean:
-distclean: extra_clean
-extra_clean:
- rm -f make_table test
-
-STATS_EXCLUDE = utf8MacroTable.ml
-
-include ../../Makefile.defs
-include ../Makefile.common
-
+++ /dev/null
-
-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
-
+++ /dev/null
-<?xml version="1.0"?>
-
-<!--
- This file is part of EdiTeX, an editor of mathematical
- expressions based on TeX syntax.
-
- Copyright (C) 2002-2003 Luca Padovani <lpadovan@cs.unibo.it>,
- 2003 Paolo Marinelli <pmarinel@cs.unibo.it>.
-
- This library is free software; you can redistribute it and/or
- modify it under the terms of the GNU Lesser General Public
- License as published by the Free Software Foundation; either
- version 2.1 of the License, or (at your option) any later version.
-
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- Lesser General Public License for more details.
-
- You should have received a copy of the GNU Lesser General Public
- License along with this library; if not, write to the Free Software
- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-
- For more information, please visit the project's home page
- http://helm.cs.unibo.it/editex/
- or send an email to <lpadovan@cs.unibo.it>
--->
-
-<dictionary name="TeX">
-
- <include href="dictionary-basic.xml"/>
-
- <!-- Greek Letters (lower case) -->
-
- <entry name="alpha" class="i" val="α"/>
- <entry name="beta" class="i" val="β"/>
- <entry name="gamma" class="i" val="γ"/>
- <entry name="delta" class="i" val="δ"/>
- <entry name="epsilon" class="i" val="ϵ"/>
- <entry name="varepsilon" class="i" val="ε"/>
- <entry name="zeta" class="i" val="ζ"/>
- <entry name="eta" class="i" val="η"/>
- <entry name="theta" class="i" val="θ"/>
- <entry name="vartheta" class="i" val="ϑ"/>
- <entry name="iota" class="i" val="ι"/>
- <entry name="kappa" class="i" val="κ"/>
- <entry name="lambda" class="i" val="λ"/>
- <entry name="mu" class="i" val="μ"/>
- <entry name="nu" class="i" val="ν"/>
- <entry name="xi" class="i" val="ξ"/>
- <entry name="o" class="i" val="ο"/>
- <entry name="pi" class="i" val="π"/>
- <entry name="varpi" class="i" val="ϖ"/>
- <entry name="rho" class="i" val="ρ"/>
- <entry name="varrho" class="i" val="ϱ"/>
- <entry name="sigma" class="i" val="σ"/>
- <entry name="varsigma" class="i" val="ς"/>
- <entry name="tau" class="i" val="τ"/>
- <entry name="upsilon" class="i" val="υ"/>
- <entry name="phi" class="i" val="ϕ"/>
- <entry name="varphi" class="i" val="φ"/>
- <entry name="chi" class="i" val="χ"/>
- <entry name="psi" class="i" val="ψ"/>
- <entry name="omega" class="i" val="ω"/>
-
- <!-- Greek Letters (upper case) -->
-
- <entry name="Gamma" class="i" val="Γ"/>
- <entry name="Delta" class="i" val="Δ"/>
- <entry name="Theta" class="i" val="Θ"/>
- <entry name="Lambda" class="i" val="Λ"/>
- <entry name="Xi" class="i" val="Ξ"/>
- <entry name="Pi" class="i" val="Π"/>
- <entry name="Sigma" class="i" val="Σ"/>
- <entry name="Upsilon" class="i" val="ϒ"/>
- <entry name="Phi" class="i" val="Φ"/>
- <entry name="Psi" class="i" val="Ψ"/>
- <entry name="Omega" class="i" val="Ω"/>
-
- <!-- Symbols of Type Ord -->
-
- <entry name="aleph" class="i" val="ℵ"/>
- <entry name="hbar" class="i" val="ℏ︀"/>
- <entry name="imath" class="i" val="ı"/>
- <entry name="jmath" class="i" val="j︀"/>
- <entry name="ell" class="i" val="ℓ"/>
- <entry name="wp" class="i" val="℘"/>
- <entry name="Re" class="o" val="ℜ"/>
- <entry name="Im" class="o" val="ℑ"/>
- <entry name="partial" class="o" val="∂"/>
- <entry name="infty" class="i" val="∞"/>
- <entry name="prime" class="o" val="′"/>
- <entry name="emptyset" class="i" val="∅︀"/>
- <entry name="nabla" class="o" val="∇"/>
- <entry name="surd" class="o" val="????"/>
- <entry name="top" class="i" val="⊤"/>
- <entry name="bot" class="i" val="⊥"/>
- <entry name="|" class="o" val="|" delimiter="1"/>
- <entry name="angle" class="o" val="∠"/>
- <entry name="triangle" class="o" val="▵"/>
- <entry name="backslash" class="o" val="\"/>
- <entry name="forall" class="o" val="∀"/>
- <entry name="exists" class="o" val="∃"/>
- <entry name="neg" class="o" val="¬"/>
- <entry name="lnot" class="o" val="¬"/>
- <entry name="flat" class="i" val="♭"/>
- <entry name="natural" class="i" val="♮"/>
- <entry name="sharp" class="i" val="♯"/>
- <entry name="clubsuit" class="i" val="♣"/>
- <entry name="diamondsuit" class="i" val="♢"/>
- <entry name="heartsuit" class="i" val="♡"/>
- <entry name="spadesuit" class="i" val="♠"/>
-
- <!-- Large Operators -->
-
- <entry name="sum" class="o" val="∑" limits="1"/>
- <entry name="prod" class="o" val="∏" limits="1"/>
- <entry name="coprod" class="o" val="∐" limits="1"/>
- <entry name="int" class="o" val="∫" limits="1"/>
- <entry name="oint" class="o" val="∮" limits="1"/>
- <entry name="bigcap" class="o" val="⋂" limits="1"/>
- <entry name="bigcup" class="o" val="⋃" limits="1"/>
- <entry name="bigsqcup" class="o" val="⊔" limits="1"/>
- <entry name="bigvee" class="o" val="⋁" limits="1"/>
- <entry name="bigwedge" class="o" val="⋀" limits="1"/>
- <entry name="bigodot" class="o" val="⊙" limits="1"/>
- <entry name="bigotimes" class="o" val="⊗" limits="1"/>
- <entry name="bigoplus" class="o" val="⊕" limits="1"/>
- <entry name="biguplus" class="o" val="⊎" limits="1"/>
-
- <!-- Binary Operations -->
-
- <entry name="pm" class="o" val="±"/>
- <entry name="mp" class="o" val="∓"/>
- <entry name="setminus" class="o" val="∖"/>
- <entry name="cdot" class="o" val="ċ"/>
- <entry name="times" class="o" val="×"/>
- <entry name="ast" class="o" val="*"/>
- <entry name="star" class="o" val="⋆"/>
- <entry name="diamond" class="o" val="⋄"/>
- <entry name="circ" class="o" val="^"/>
- <entry name="bullet" class="o" val="•"/>
- <entry name="div" class="o" val="÷"/>
- <entry name="cap" class="o" val="∩"/>
- <entry name="cup" class="o" val="∪"/>
- <entry name="uplus" class="o" val="⊎"/>
- <entry name="sqcap" class="o" val="⊓"/>
- <entry name="sqcup" class="o" val="⊔"/>
- <entry name="triangleleft" class="o" val="◃"/>
- <entry name="triangleright" class="o" val="▹"/>
- <entry name="wr" class="o" val="≀"/>
- <entry name="bigcirc" class="o" val="◯"/>
- <entry name="bigtriangleup" class="o" val="△"/>
- <entry name="bigtriangledown" class="o" val="▽"/>
- <entry name="vee" class="o" val="∨"/>
- <entry name="lor" class="o" val="∨"/>
- <entry name="wedge" class="o" val="∧"/>
- <entry name="land" class="o" val="∧"/>
- <entry name="oplus" class="o" val="⊕"/>
- <entry name="ominus" class="o" val="⊖"/>
- <entry name="otimes" class="o" val="⊗"/>
- <entry name="oslash" class="o" val="ø"/>
- <entry name="odot" class="o" val="⊙"/>
- <entry name="dagger" class="o" val="†"/>
- <entry name="ddagger" class="o" val="‡"/>
- <entry name="amalg" class="o" val="⨿"/>
-
- <!-- Relations -->
-
- <entry name="leq" class="o" val="≤"/>
- <entry name="le" class="o" val="≤"/>
- <entry name="prec" class="o" val="≺"/>
- <entry name="preceq" class="o" val="⪯"/>
- <entry name="ll" class="o" val="≪"/>
- <entry name="subset" class="o" val="⊂"/>
- <entry name="subseteq" class="o" val="⊆"/>
- <entry name="in" class="o" val="∈"/>
- <entry name="vdash" class="o" val="⊢"/>
- <entry name="smile" class="o" val="⌣"/>
- <entry name="frown" class="o" val="⌢"/>
- <entry name="propto" class="o" val="∝"/>
- <entry name="geq" class="o" val="≥"/>
- <entry name="ge" class="o" val="≥"/>
- <entry name="succ" class="o" val="≻"/>
- <entry name="succeq" class="o" val="≽"/>
- <entry name="gg" class="o" val="≫"/>
- <entry name="supset" class="o" val="⊃"/>
- <entry name="supseteq" class="o" val="⊇"/>
- <entry name="sqsupseteq" class="o" val="⊒"/>
- <entry name="notin" class="o" val="∉"/>
- <entry name="dashv" class="o" val="⊣"/>
- <entry name="mid" class="o" val="∣"/>
- <entry name="parallet" class="o" val="????"/>
- <entry name="equiv" class="o" val="≡"/>
- <entry name="sim" class="o" val="∼"/>
- <entry name="simeq" class="o" val="≃"/>
- <entry name="asymp" class="o" val="≍"/>
- <entry name="approx" class="o" val="≈"/>
- <entry name="cong" class="o" val="≅"/>
- <entry name="bowtie" class="o" val="⋈"/>
- <entry name="ni" class="o" val="∋"/>
- <entry name="owns" class="o" val="∋"/>
- <entry name="models" class="o" val="⊧"/>
- <entry name="doteq" class="o" val="≐"/>
- <entry name="perp" class="o" val="⊥"/>
-
- <entry name="not" pattern="#1" embellishment="1"/>
- <entry name="ne" class="o" val="≠"/>
-
- <!-- Arrows -->
-
- <entry name="leftarrow" class="o" val="←"/>
- <entry name="gets" class="o" val="←"/>
- <entry name="Leftarrow" class="o" val="⇐"/>
- <entry name="rightarrow" class="o" val="→"/>
- <entry name="to" class="o" val="→"/>
- <entry name="Rightarrow" class="o" val="⇒"/>
- <entry name="leftrightarrow" class="o" val="↔"/>
- <entry name="Leftrightarrow" class="o" val="⇔"/>
- <entry name="mapsto" class="o" val="↦"/>
- <entry name="hookleftarrow" class="o" val="↩"/>
- <entry name="uparrow" class="o" val="↑"/>
- <entry name="downarrow" class="o" val="↓"/>
- <entry name="updownarrow" class="o" val="↕"/>
- <entry name="nearrow" class="o" val="↗"/>
- <entry name="nwarrow" class="o" val="↖"/>
- <entry name="longleftarrow" class="o" val="????;"/>
- <entry name="Longleftarrow" class="o" val="????"/>
- <entry name="longrightarrow" class="o" val="????"/>
- <entry name="Longrightarrow" class="o" val="⇒"/>
- <entry name="longleftrightarrow" class="o" val="????"/>
- <entry name="Longleftrightarrow" class="o" val="????"/>
- <entry name="longmapsto" class="o" val="????"/>
- <entry name="hookrightarrow" class="o" val="↪"/>
- <entry name="Uparrow" class="o" val="⇑"/>
- <entry name="Downarrow" class="o" val="⇓"/>
- <entry name="searrow" class="o" val="↘"/>
- <entry name="swarrow" class="o" val="↙"/>
-
- <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="‖" 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="⌊" delimiter="1"/>
- <entry name="rfloor" class="o" val="⌋" delimiter="1"/>
- <entry name="langle" class="o" val="〈" delimiter="1"/>
- <entry name="rangle" class="o" val="〉" delimiter="1"/>
- <entry name="lceil" class="o" val="⌈" delimiter="1"/>
- <entry name="rceil" class="o" val="⌉" 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="…"/>
- <entry name="ldots" class="i" val="…"/>
- <entry name="cdots" class="i" val="⋯"/>
- <entry name="vdots" class="i" val="⋮"/>
- <entry name="ddots" class="i" val="⋱"/>
-
- <!-- 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=">"/>
- <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>
+++ /dev/null
-<?xml version="1.0"?>
-
-<entities-table>
- <entity name="aacute" value="á"/>
- <entity name="Aacute" value="Á"/>
- <entity name="abreve" value="ă"/>
- <entity name="Abreve" value="Ă"/>
- <entity name="ac" value="⤏"/>
- <entity name="acd" value="∿"/>
- <entity name="acE" value="⧛"/>
- <entity name="acirc" value="â"/>
- <entity name="Acirc" value="Â"/>
- <entity name="acute" value="´"/>
- <entity name="acy" value="а"/>
- <entity name="Acy" value="А"/>
- <entity name="aelig" value="æ"/>
- <entity name="AElig" value="Æ"/>
- <entity name="af" value="⁡"/>
- <entity name="afr" value="𝔞"/>
- <entity name="Afr" value="𝔄"/>
- <entity name="agrave" value="à"/>
- <entity name="Agrave" value="À"/>
- <entity name="aleph" value="ℵ"/>
- <entity name="alpha" value="α"/>
- <entity name="amacr" value="ā"/>
- <entity name="Amacr" value="Ā"/>
- <entity name="amalg" value="⨿"/>
- <entity name="amp" value="&"/>
- <entity name="and" value="∧"/>
- <entity name="And" value="⩓"/>
- <entity name="andand" value="⩕"/>
- <entity name="andd" value="⩜"/>
- <entity name="andslope" value="⩘"/>
- <entity name="andv" value="⩚"/>
- <entity name="ang" value="∠"/>
- <entity name="ange" value="⦤"/>
- <entity name="angle" value="∠"/>
- <entity name="angmsd" value="∡"/>
- <entity name="angmsdaa" value="⦨"/>
- <entity name="angmsdab" value="⦩"/>
- <entity name="angmsdac" value="⦪"/>
- <entity name="angmsdad" value="⦫"/>
- <entity name="angmsdae" value="⦬"/>
- <entity name="angmsdaf" value="⦭"/>
- <entity name="angmsdag" value="⦮"/>
- <entity name="angmsdah" value="⦯"/>
- <entity name="angrt" value="∟"/>
- <entity name="angrtvb" value="⦝︀"/>
- <entity name="angrtvbd" value="⦝"/>
- <entity name="angsph" value="∢"/>
- <entity name="angst" value="Å"/>
- <entity name="angzarr" value="⍼"/>
- <entity name="aogon" value="ą"/>
- <entity name="Aogon" value="Ą"/>
- <entity name="aopf" value="𝕒"/>
- <entity name="Aopf" value="𝔸"/>
- <entity name="ap" value="≈"/>
- <entity name="apacir" value="⩯"/>
- <entity name="ape" value="≊"/>
- <entity name="apE" value="≊"/>
- <entity name="apid" value="≋"/>
- <entity name="apos" value="'"/>
- <entity name="ApplyFunction" value="⁡"/>
- <entity name="approx" value="≈"/>
- <entity name="approxeq" value="≊"/>
- <entity name="aring" value="å"/>
- <entity name="Aring" value="Å"/>
- <entity name="ascr" value="𝒶"/>
- <entity name="Ascr" value="𝒜"/>
- <entity name="Assign" value="≔"/>
- <entity name="ast" value="*"/>
- <entity name="asymp" value="≍"/>
- <entity name="atilde" value="ã"/>
- <entity name="Atilde" value="Ã"/>
- <entity name="auml" value="ä"/>
- <entity name="Auml" value="Ä"/>
- <entity name="awconint" value="∳"/>
- <entity name="awint" value="⨑"/>
- <entity name="backcong" value="≌"/>
- <entity name="backepsilon" value="϶"/>
- <entity name="backprime" value="‵"/>
- <entity name="backsim" value="∽"/>
- <entity name="backsimeq" value="⋍"/>
- <entity name="Backslash" value="∖"/>
- <entity name="Barv" value="⫧"/>
- <entity name="barvee" value="⊽"/>
- <entity name="barwed" value="⊼"/>
- <entity name="Barwed" value="⌆"/>
- <entity name="barwedge" value="⊼"/>
- <entity name="bbrk" value="⎵"/>
- <entity name="bcong" value="≌"/>
- <entity name="bcy" value="б"/>
- <entity name="Bcy" value="Б"/>
- <entity name="becaus" value="∵"/>
- <entity name="because" value="∵"/>
- <entity name="Because" value="∵"/>
- <entity name="bemptyv" value="⦰"/>
- <entity name="bepsi" value="϶"/>
- <entity name="bernou" value="ℬ"/>
- <entity name="Bernoullis" value="ℬ"/>
- <entity name="beta" value="β"/>
- <entity name="beth" value="ℶ"/>
- <entity name="between" value="≬"/>
- <entity name="bfr" value="𝔟"/>
- <entity name="Bfr" value="𝔅"/>
- <entity name="bigcap" value="⋂"/>
- <entity name="bigcirc" value="◯"/>
- <entity name="bigcup" value="⋃"/>
- <entity name="bigodot" value="⊙"/>
- <entity name="bigoplus" value="⊕"/>
- <entity name="bigotimes" value="⊗"/>
- <entity name="bigsqcup" value="⊔"/>
- <entity name="bigstar" value="★"/>
- <entity name="bigtriangledown" value="▽"/>
- <entity name="bigtriangleup" value="△"/>
- <entity name="biguplus" value="⊎"/>
- <entity name="bigvee" value="⋁"/>
- <entity name="bigwedge" value="⋀"/>
- <entity name="bkarow" value="⤍"/>
- <entity name="blacklozenge" value="⧫"/>
- <entity name="blacksquare" value="▪"/>
- <entity name="blacktriangle" value="▴"/>
- <entity name="blacktriangledown" value="▾"/>
- <entity name="blacktriangleleft" value="◂"/>
- <entity name="blacktriangleright" value="▸"/>
- <entity name="blank" value="␣"/>
- <entity name="blk12" value="▒"/>
- <entity name="blk14" value="░"/>
- <entity name="blk34" value="▓"/>
- <entity name="block" value="█"/>
- <entity name="bne" value="=⃥"/>
- <entity name="bnequiv" value="≡⃥"/>
- <entity name="bnot" value="⌐"/>
- <entity name="bNot" value="⫭"/>
- <entity name="bopf" value="𝕓"/>
- <entity name="Bopf" value="𝔹"/>
- <entity name="bot" value="⊥"/>
- <entity name="bottom" value="⊥"/>
- <entity name="bowtie" value="⋈"/>
- <entity name="boxbox" value="⧉"/>
- <entity name="boxdl" value="┐"/>
- <entity name="boxdL" value="╕"/>
- <entity name="boxDl" value="╖"/>
- <entity name="boxDL" value="╗"/>
- <entity name="boxdr" value="┌"/>
- <entity name="boxdR" value="╒"/>
- <entity name="boxDr" value="╓"/>
- <entity name="boxDR" value="╔"/>
- <entity name="boxh" value="─"/>
- <entity name="boxH" value="═"/>
- <entity name="boxhd" value="┬"/>
- <entity name="boxhD" value="╥"/>
- <entity name="boxHd" value="╤"/>
- <entity name="boxHD" value="╦"/>
- <entity name="boxhu" value="┴"/>
- <entity name="boxhU" value="╨"/>
- <entity name="boxHu" value="╧"/>
- <entity name="boxHU" value="╩"/>
- <entity name="boxminus" value="⊟"/>
- <entity name="boxplus" value="⊞"/>
- <entity name="boxtimes" value="⊠"/>
- <entity name="boxul" value="┘"/>
- <entity name="boxuL" value="╛"/>
- <entity name="boxUl" value="╜"/>
- <entity name="boxUL" value="╝"/>
- <entity name="boxur" value="└"/>
- <entity name="boxuR" value="╘"/>
- <entity name="boxUr" value="╙"/>
- <entity name="boxUR" value="╚"/>
- <entity name="boxv" value="│"/>
- <entity name="boxV" value="║"/>
- <entity name="boxvh" value="┼"/>
- <entity name="boxvH" value="╪"/>
- <entity name="boxVh" value="╫"/>
- <entity name="boxVH" value="╬"/>
- <entity name="boxvl" value="┤"/>
- <entity name="boxvL" value="╡"/>
- <entity name="boxVl" value="╢"/>
- <entity name="boxVL" value="╣"/>
- <entity name="boxvr" value="├"/>
- <entity name="boxvR" value="╞"/>
- <entity name="boxVr" value="╟"/>
- <entity name="boxVR" value="╠"/>
- <entity name="bprime" value="‵"/>
- <entity name="breve" value="˘"/>
- <entity name="Breve" value="˘"/>
- <entity name="brvbar" value="¦"/>
- <entity name="bscr" value="𝒷"/>
- <entity name="Bscr" value="ℬ"/>
- <entity name="bsemi" value="⁏"/>
- <entity name="bsim" value="∽"/>
- <entity name="bsime" value="⋍"/>
- <entity name="bsol" value="\"/>
- <entity name="bsolb" value="⧅"/>
- <entity name="bsolhsub" value="\⊂"/>
- <entity name="bull" value="•"/>
- <entity name="bullet" value="•"/>
- <entity name="bump" value="≎"/>
- <entity name="bumpe" value="≏"/>
- <entity name="bumpE" value="⪮"/>
- <entity name="bumpeq" value="≏"/>
- <entity name="Bumpeq" value="≎"/>
- <entity name="cacute" value="ć"/>
- <entity name="Cacute" value="Ć"/>
- <entity name="cap" value="∩"/>
- <entity name="Cap" value="⋒"/>
- <entity name="capand" value="⩄"/>
- <entity name="capbrcup" value="⩉"/>
- <entity name="capcap" value="⩋"/>
- <entity name="capcup" value="⩇"/>
- <entity name="capdot" value="⩀"/>
- <entity name="CapitalDifferentialD" value="ⅅ"/>
- <entity name="caps" value="∩︀"/>
- <entity name="caret" value="⁁"/>
- <entity name="caron" value="ˇ"/>
- <entity name="Cayleys" value="ℭ"/>
- <entity name="ccaps" value="⩍"/>
- <entity name="ccaron" value="č"/>
- <entity name="Ccaron" value="Č"/>
- <entity name="ccedil" value="ç"/>
- <entity name="Ccedil" value="Ç"/>
- <entity name="ccirc" value="ĉ"/>
- <entity name="Ccirc" value="Ĉ"/>
- <entity name="Cconint" value="∰"/>
- <entity name="ccups" value="⩌"/>
- <entity name="ccupssm" value="⩐"/>
- <entity name="cdot" value="ċ"/>
- <entity name="Cdot" value="Ċ"/>
- <entity name="cedil" value="¸"/>
- <entity name="Cedilla" value="¸"/>
- <entity name="cemptyv" value="⦲"/>
- <entity name="cent" value="¢"/>
- <entity name="centerdot" value="·"/>
- <entity name="CenterDot" value="·"/>
- <entity name="cfr" value="𝔠"/>
- <entity name="Cfr" value="ℭ"/>
- <entity name="chcy" value="ч"/>
- <entity name="CHcy" value="Ч"/>
- <entity name="check" value="✓"/>
- <entity name="checkmark" value="✓"/>
- <entity name="chi" value="χ"/>
- <entity name="cir" value="○"/>
- <entity name="circ" value="^"/>
- <entity name="circeq" value="≗"/>
- <entity name="circlearrowleft" value="↺"/>
- <entity name="circlearrowright" value="↻"/>
- <entity name="circledast" value="⊛"/>
- <entity name="circledcirc" value="⊚"/>
- <entity name="circleddash" value="⊝"/>
- <entity name="CircleDot" value="⊙"/>
- <entity name="circledR" value="®"/>
- <entity name="circledS" value="Ⓢ"/>
- <entity name="CircleMinus" value="⊖"/>
- <entity name="CirclePlus" value="⊕"/>
- <entity name="CircleTimes" value="⊗"/>
- <entity name="cire" value="≗"/>
- <entity name="cirE" value="⧃"/>
- <entity name="cirfnint" value="⨐"/>
- <entity name="cirmid" value="⫯"/>
- <entity name="cirscir" value="⧂"/>
- <entity name="ClockwiseContourIntegral" value="∲"/>
- <entity name="CloseCurlyDoubleQuote" value="”"/>
- <entity name="CloseCurlyQuote" value="’"/>
- <entity name="clubs" value="♣"/>
- <entity name="clubsuit" value="♣"/>
- <entity name="colon" value=":"/>
- <entity name="Colon" value="∷"/>
- <entity name="colone" value="≔"/>
- <entity name="Colone" value="⩴"/>
- <entity name="coloneq" value="≔"/>
- <entity name="comma" value=","/>
- <entity name="commat" value="@"/>
- <entity name="comp" value="∁"/>
- <entity name="compfn" value="∘"/>
- <entity name="complement" value="∁"/>
- <entity name="complexes" value="ℂ"/>
- <entity name="cong" value="≅"/>
- <entity name="congdot" value="⩭"/>
- <entity name="Congruent" value="≡"/>
- <entity name="conint" value="∮"/>
- <entity name="Conint" value="∯"/>
- <entity name="ContourIntegral" value="∮"/>
- <entity name="copf" value="𝕔"/>
- <entity name="Copf" value="ℂ"/>
- <entity name="coprod" value="∐"/>
- <entity name="Coproduct" value="∐"/>
- <entity name="copy" value="©"/>
- <entity name="copysr" value="℗"/>
- <entity name="CounterClockwiseContourIntegral" value="∳"/>
- <entity name="cross" value="✗"/>
- <entity name="Cross" value="⨯"/>
- <entity name="cscr" value="𝒸"/>
- <entity name="Cscr" value="𝒞"/>
- <entity name="csub" value="⫏"/>
- <entity name="csube" value="⫑"/>
- <entity name="csup" value="⫐"/>
- <entity name="csupe" value="⫒"/>
- <entity name="ctdot" value="⋯"/>
- <entity name="cudarrl" value="⤸"/>
- <entity name="cudarrr" value="⤵"/>
- <entity name="cuepr" value="⋞"/>
- <entity name="cuesc" value="⋟"/>
- <entity name="cularr" value="↶"/>
- <entity name="cularrp" value="⤽"/>
- <entity name="cup" value="∪"/>
- <entity name="Cup" value="⋓"/>
- <entity name="cupbrcap" value="⩈"/>
- <entity name="cupcap" value="⩆"/>
- <entity name="CupCap" value="≍"/>
- <entity name="cupcup" value="⩊"/>
- <entity name="cupdot" value="⊍"/>
- <entity name="cupor" value="⩅"/>
- <entity name="cups" value="∪︀"/>
- <entity name="curarr" value="↷"/>
- <entity name="curarrm" value="⤼"/>
- <entity name="curlyeqprec" value="⋞"/>
- <entity name="curlyeqsucc" value="⋟"/>
- <entity name="curlyvee" value="⋎"/>
- <entity name="curlywedge" value="⋏"/>
- <entity name="curren" value="¤"/>
- <entity name="curvearrowleft" value="↶"/>
- <entity name="curvearrowright" value="↷"/>
- <entity name="cuvee" value="⋎"/>
- <entity name="cuwed" value="⋏"/>
- <entity name="cwconint" value="∲"/>
- <entity name="cwint" value="∱"/>
- <entity name="cylcty" value="⌭"/>
- <entity name="dagger" value="†"/>
- <entity name="dagger" value="†"/>
- <entity name="Dagger" value="‡"/>
- <entity name="Dagger" value="‡"/>
- <entity name="daleth" value="ℸ"/>
- <entity name="darr" value="↓"/>
- <entity name="dArr" value="⇓"/>
- <entity name="Darr" value="↡"/>
- <entity name="dash" value="‐"/>
- <entity name="dashv" value="⊣"/>
- <entity name="Dashv" value="⫤"/>
- <entity name="dbkarow" value="⤏"/>
- <entity name="dblac" value="˝"/>
- <entity name="dcaron" value="ď"/>
- <entity name="Dcaron" value="Ď"/>
- <entity name="dcy" value="д"/>
- <entity name="Dcy" value="Д"/>
- <entity name="dd" value="ⅆ"/>
- <entity name="DD" value="ⅅ"/>
- <entity name="ddagger" value="‡"/>
- <entity name="ddarr" value="⇊"/>
- <entity name="DDotrahd" value="⤑"/>
- <entity name="ddotseq" value="⩷"/>
- <entity name="deg" value="°"/>
- <entity name="Del" value="∇"/>
- <entity name="delta" value="δ"/>
- <entity name="Delta" value="Δ"/>
- <entity name="demptyv" value="⦱"/>
- <entity name="dfisht" value="⥿"/>
- <entity name="dfr" value="𝔡"/>
- <entity name="Dfr" value="𝔇"/>
- <entity name="dHar" value="⥥"/>
- <entity name="dharl" value="⇃"/>
- <entity name="dharr" value="⇂"/>
- <entity name="DiacriticalAcute" value="´"/>
- <entity name="DiacriticalDot" value="˙"/>
- <entity name="DiacriticalDoubleAcute" value="˝"/>
- <entity name="DiacriticalGrave" value="`"/>
- <entity name="DiacriticalTilde" value="˜"/>
- <entity name="diam" value="⋄"/>
- <entity name="diamond" value="⋄"/>
- <entity name="Diamond" value="⋄"/>
- <entity name="diamondsuit" value="♦"/>
- <entity name="diams" value="♦"/>
- <entity name="die" value="¨"/>
- <entity name="DifferentialD" value="ⅆ"/>
- <entity name="digamma" value="Ϝ"/>
- <entity name="disin" value="⋲"/>
- <entity name="div" value="÷"/>
- <entity name="divide" value="÷"/>
- <entity name="divideontimes" value="⋇"/>
- <entity name="divonx" value="⋇"/>
- <entity name="djcy" value="ђ"/>
- <entity name="DJcy" value="Ђ"/>
- <entity name="dlcorn" value="⌞"/>
- <entity name="dlcrop" value="⌍"/>
- <entity name="dollar" value="$"/>
- <entity name="dopf" value="𝕕"/>
- <entity name="Dopf" value="𝔻"/>
- <entity name="dot" value="˙"/>
- <entity name="Dot" value="¨"/>
- <entity name="DotDot" value="⃜"/>
- <entity name="doteq" value="≐"/>
- <entity name="doteqdot" value="≑"/>
- <entity name="DotEqual" value="≐"/>
- <entity name="dotminus" value="∸"/>
- <entity name="dotplus" value="∔"/>
- <entity name="dotsquare" value="⊡"/>
- <entity name="doublebarwedge" value="⌆"/>
- <entity name="DoubleContourIntegral" value="∯"/>
- <entity name="DoubleDot" value="¨"/>
- <entity name="DoubleDownArrow" value="⇓"/>
- <entity name="DoubleLeftArrow" value="⇐"/>
- <entity name="DoubleLeftRightArrow" value="⇔"/>
- <entity name="DoubleLeftTee" value="⫤"/>
- <entity name="DoubleLongLeftArrow" value=""/>
- <entity name="DoubleLongLeftRightArrow" value=""/>
- <entity name="DoubleLongRightArrow" value=""/>
- <entity name="DoubleRightArrow" value="⇒"/>
- <entity name="DoubleRightTee" value="⊨"/>
- <entity name="DoubleUpArrow" value="⇑"/>
- <entity name="DoubleUpDownArrow" value="⇕"/>
- <entity name="DoubleVerticalBar" value="∥"/>
- <entity name="downarrow" value="↓"/>
- <entity name="Downarrow" value="⇓"/>
- <entity name="DownArrow" value="↓"/>
- <entity name="DownArrowBar" value="⤓"/>
- <entity name="DownArrowUpArrow" value="⇵"/>
- <entity name="DownBreve" value="̑"/>
- <entity name="downdownarrows" value="⇊"/>
- <entity name="downharpoonleft" value="⇃"/>
- <entity name="downharpoonright" value="⇂"/>
- <entity name="DownLeftRightVector" value="⥐"/>
- <entity name="DownLeftTeeVector" value="⥞"/>
- <entity name="DownLeftVector" value="↽"/>
- <entity name="DownLeftVectorBar" value="⥖"/>
- <entity name="DownRightTeeVector" value="⥟"/>
- <entity name="DownRightVector" value="⇁"/>
- <entity name="DownRightVectorBar" value="⥗"/>
- <entity name="DownTee" value="⊤"/>
- <entity name="DownTeeArrow" value="↧"/>
- <entity name="drbkarow" value="⤐"/>
- <entity name="drcorn" value="⌟"/>
- <entity name="drcrop" value="⌌"/>
- <entity name="dscr" value="𝒹"/>
- <entity name="Dscr" value="𝒟"/>
- <entity name="dscy" value="ѕ"/>
- <entity name="DScy" value="Ѕ"/>
- <entity name="dsol" value="⧶"/>
- <entity name="dstrok" value="đ"/>
- <entity name="Dstrok" value="Đ"/>
- <entity name="dtdot" value="⋱"/>
- <entity name="dtri" value="▿"/>
- <entity name="dtrif" value="▾"/>
- <entity name="duarr" value="⇵"/>
- <entity name="duhar" value="⥯"/>
- <entity name="dwangle" value="⦦"/>
- <entity name="dzcy" value="џ"/>
- <entity name="DZcy" value="Џ"/>
- <entity name="dzigrarr" value=""/>
- <entity name="eacute" value="é"/>
- <entity name="Eacute" value="É"/>
- <entity name="easter" value="≛"/>
- <entity name="ecaron" value="ě"/>
- <entity name="Ecaron" value="Ě"/>
- <entity name="ecir" value="≖"/>
- <entity name="ecirc" value="ê"/>
- <entity name="Ecirc" value="Ê"/>
- <entity name="ecolon" value="≕"/>
- <entity name="ecy" value="э"/>
- <entity name="Ecy" value="Э"/>
- <entity name="eDDot" value="⩷"/>
- <entity name="edot" value="ė"/>
- <entity name="eDot" value="≑"/>
- <entity name="Edot" value="Ė"/>
- <entity name="ee" value="ⅇ"/>
- <entity name="efDot" value="≒"/>
- <entity name="efr" value="𝔢"/>
- <entity name="Efr" value="𝔈"/>
- <entity name="eg" value="⪚"/>
- <entity name="egrave" value="è"/>
- <entity name="Egrave" value="È"/>
- <entity name="egs" value="⋝"/>
- <entity name="egsdot" value="⪘"/>
- <entity name="el" value="⪙"/>
- <entity name="Element" value="∈"/>
- <entity name="ell" value="ℓ"/>
- <entity name="els" value="⋜"/>
- <entity name="elsdot" value="⪗"/>
- <entity name="emacr" value="ē"/>
- <entity name="Emacr" value="Ē"/>
- <entity name="empty" value="∅︀"/>
- <entity name="emptyset" value="∅︀"/>
- <entity name="EmptySmallSquare" value="◽"/>
- <entity name="emptyv" value="∅"/>
- <entity name="EmptyVerySmallSquare" value=""/>
- <entity name="emsp" value=" "/>
- <entity name="emsp13" value=" "/>
- <entity name="emsp14" value=" "/>
- <entity name="eng" value="ŋ"/>
- <entity name="ENG" value="Ŋ"/>
- <entity name="ensp" value=" "/>
- <entity name="eogon" value="ę"/>
- <entity name="Eogon" value="Ę"/>
- <entity name="eopf" value="𝕖"/>
- <entity name="Eopf" value="𝔼"/>
- <entity name="epar" value="⋕"/>
- <entity name="eparsl" value="⧣"/>
- <entity name="eplus" value="⩱"/>
- <entity name="epsi" value="ε"/>
- <entity name="epsiv" value="ɛ"/>
- <entity name="eqcirc" value="≖"/>
- <entity name="eqcolon" value="≕"/>
- <entity name="eqsim" value="≂"/>
- <entity name="eqslantgtr" value="⋝"/>
- <entity name="eqslantless" value="⋜"/>
- <entity name="Equal" value="⩵"/>
- <entity name="equals" value="="/>
- <entity name="EqualTilde" value="≂"/>
- <entity name="equest" value="≟"/>
- <entity name="Equilibrium" value="⇌"/>
- <entity name="equiv" value="≡"/>
- <entity name="equivDD" value="⩸"/>
- <entity name="eqvparsl" value="⧥"/>
- <entity name="erarr" value="⥱"/>
- <entity name="erDot" value="≓"/>
- <entity name="escr" value="ℯ"/>
- <entity name="Escr" value="ℰ"/>
- <entity name="esdot" value="≐"/>
- <entity name="esim" value="≂"/>
- <entity name="Esim" value="⩳"/>
- <entity name="eta" value="η"/>
- <entity name="eth" value="ð"/>
- <entity name="ETH" value="Ð"/>
- <entity name="euml" value="ë"/>
- <entity name="Euml" value="Ë"/>
- <entity name="excl" value="!"/>
- <entity name="exist" value="∃"/>
- <entity name="Exists" value="∃"/>
- <entity name="expectation" value="ℰ"/>
- <entity name="exponentiale" value="ⅇ"/>
- <entity name="ExponentialE" value="ⅇ"/>
- <entity name="fallingdotseq" value="≒"/>
- <entity name="fcy" value="ф"/>
- <entity name="Fcy" value="Ф"/>
- <entity name="female" value="♀"/>
- <entity name="ffilig" value="ffi"/>
- <entity name="fflig" value="ff"/>
- <entity name="ffllig" value="ffl"/>
- <entity name="ffr" value="𝔣"/>
- <entity name="Ffr" value="𝔉"/>
- <entity name="filig" value="fi"/>
- <entity name="FilledSmallSquare" value="◾"/>
- <entity name="FilledVerySmallSquare" value=""/>
- <entity name="flat" value="♭"/>
- <entity name="fllig" value="fl"/>
- <entity name="fnof" value="ƒ"/>
- <entity name="fopf" value="𝕗"/>
- <entity name="Fopf" value="𝔽"/>
- <entity name="forall" value="∀"/>
- <entity name="ForAll" value="∀"/>
- <entity name="fork" value="⋔"/>
- <entity name="forkv" value="⫙"/>
- <entity name="Fouriertrf" value="ℱ"/>
- <entity name="fpartint" value="⨍"/>
- <entity name="frac12" value="½"/>
- <entity name="frac13" value="⅓"/>
- <entity name="frac14" value="¼"/>
- <entity name="frac15" value="⅕"/>
- <entity name="frac16" value="⅙"/>
- <entity name="frac18" value="⅛"/>
- <entity name="frac23" value="⅔"/>
- <entity name="frac25" value="⅖"/>
- <entity name="frac34" value="¾"/>
- <entity name="frac35" value="⅗"/>
- <entity name="frac38" value="⅜"/>
- <entity name="frac45" value="⅘"/>
- <entity name="frac56" value="⅚"/>
- <entity name="frac58" value="⅝"/>
- <entity name="frac78" value="⅞"/>
- <entity name="frown" value="⌢"/>
- <entity name="fscr" value="𝒻"/>
- <entity name="Fscr" value="ℱ"/>
- <entity name="gacute" value="ǵ"/>
- <entity name="gamma" value="γ"/>
- <entity name="Gamma" value="Γ"/>
- <entity name="gammad" value="Ϝ"/>
- <entity name="Gammad" value="Ϝ"/>
- <entity name="gap" value="≳"/>
- <entity name="gbreve" value="ğ"/>
- <entity name="Gbreve" value="Ğ"/>
- <entity name="Gcedil" value="Ģ"/>
- <entity name="gcirc" value="ĝ"/>
- <entity name="Gcirc" value="Ĝ"/>
- <entity name="gcy" value="г"/>
- <entity name="Gcy" value="Г"/>
- <entity name="gdot" value="ġ"/>
- <entity name="Gdot" value="Ġ"/>
- <entity name="ge" value="≥"/>
- <entity name="gE" value="≧"/>
- <entity name="gel" value="⋛"/>
- <entity name="gEl" value="⋛"/>
- <entity name="geq" value="≥"/>
- <entity name="geqq" value="≧"/>
- <entity name="geqslant" value="⩾"/>
- <entity name="ges" value="⩾"/>
- <entity name="gescc" value="⪩"/>
- <entity name="gesdot" value="⪀"/>
- <entity name="gesdoto" value="⪂"/>
- <entity name="gesdotol" value="⪄"/>
- <entity name="gesl" value="⋛︀"/>
- <entity name="gesles" value="⪔"/>
- <entity name="gfr" value="𝔤"/>
- <entity name="Gfr" value="𝔊"/>
- <entity name="gg" value="≫"/>
- <entity name="Gg" value="⋙"/>
- <entity name="ggg" value="⋙"/>
- <entity name="gimel" value="ℷ"/>
- <entity name="gjcy" value="ѓ"/>
- <entity name="GJcy" value="Ѓ"/>
- <entity name="gl" value="≷"/>
- <entity name="gla" value="⪥"/>
- <entity name="glE" value="⪒"/>
- <entity name="glj" value="⪤"/>
- <entity name="gnap" value="⪊"/>
- <entity name="gnapprox" value="⪊"/>
- <entity name="gne" value="≩"/>
- <entity name="gnE" value="≩"/>
- <entity name="gneq" value="≩"/>
- <entity name="gneqq" value="≩"/>
- <entity name="gnsim" value="⋧"/>
- <entity name="gopf" value="𝕘"/>
- <entity name="Gopf" value="𝔾"/>
- <entity name="grave" value="`"/>
- <entity name="GreaterEqual" value="≥"/>
- <entity name="GreaterEqualLess" value="⋛"/>
- <entity name="GreaterFullEqual" value="≧"/>
- <entity name="GreaterGreater" value="⪢"/>
- <entity name="GreaterLess" value="≷"/>
- <entity name="GreaterSlantEqual" value="⩾"/>
- <entity name="GreaterTilde" value="≳"/>
- <entity name="gscr" value="ℊ"/>
- <entity name="Gscr" value="𝒢"/>
- <entity name="gsim" value="≳"/>
- <entity name="gsime" value="⪎"/>
- <entity name="gsiml" value="⪐"/>
- <entity name="gt" value=">"/>
- <entity name="Gt" value="≫"/>
- <entity name="gtcc" value="⪧"/>
- <entity name="gtcir" value="⩺"/>
- <entity name="gtdot" value="⋗"/>
- <entity name="gtlPar" value="⦕"/>
- <entity name="gtquest" value="⩼"/>
- <entity name="gtrapprox" value="≳"/>
- <entity name="gtrarr" value="⥸"/>
- <entity name="gtrdot" value="⋗"/>
- <entity name="gtreqless" value="⋛"/>
- <entity name="gtreqqless" value="⋛"/>
- <entity name="gtrless" value="≷"/>
- <entity name="gtrsim" value="≳"/>
- <entity name="gvertneqq" value="≩︀"/>
- <entity name="gvnE" value="≩︀"/>
- <entity name="Hacek" value="ˇ"/>
- <entity name="hairsp" value=" "/>
- <entity name="half" value="½"/>
- <entity name="hamilt" value="ℋ"/>
- <entity name="hardcy" value="ъ"/>
- <entity name="HARDcy" value="Ъ"/>
- <entity name="harr" value="↔"/>
- <entity name="hArr" value="⇔"/>
- <entity name="harrcir" value="⥈"/>
- <entity name="harrw" value="↭"/>
- <entity name="Hat" value="̂"/>
- <entity name="hbar" value="ℏ︀"/>
- <entity name="hcirc" value="ĥ"/>
- <entity name="Hcirc" value="Ĥ"/>
- <entity name="heartsuit" value="♡"/>
- <entity name="hellip" value="…"/>
- <entity name="hercon" value="⊹"/>
- <entity name="hfr" value="𝔥"/>
- <entity name="Hfr" value="ℌ"/>
- <entity name="HilbertSpace" value="ℋ"/>
- <entity name="hksearow" value="⤥"/>
- <entity name="hkswarow" value="⤦"/>
- <entity name="hoarr" value="⇿"/>
- <entity name="homtht" value="∻"/>
- <entity name="hookleftarrow" value="↩"/>
- <entity name="hookrightarrow" value="↪"/>
- <entity name="hopf" value="𝕙"/>
- <entity name="Hopf" value="ℍ"/>
- <entity name="horbar" value="―"/>
- <entity name="HorizontalLine" value="─"/>
- <entity name="hscr" value="𝒽"/>
- <entity name="Hscr" value="ℋ"/>
- <entity name="hslash" value="ℏ"/>
- <entity name="hstrok" value="ħ"/>
- <entity name="Hstrok" value="Ħ"/>
- <entity name="HumpDownHump" value="≎"/>
- <entity name="HumpEqual" value="≏"/>
- <entity name="hybull" value="⁃"/>
- <entity name="hyphen" value="‐"/>
- <entity name="iacute" value="í"/>
- <entity name="Iacute" value="Í"/>
- <entity name="ic" value="​"/>
- <entity name="icirc" value="î"/>
- <entity name="Icirc" value="Î"/>
- <entity name="icy" value="и"/>
- <entity name="Icy" value="И"/>
- <entity name="Idot" value="İ"/>
- <entity name="iecy" value="е"/>
- <entity name="IEcy" value="Е"/>
- <entity name="iexcl" value="¡"/>
- <entity name="iff" value="⇔"/>
- <entity name="ifr" value="𝔦"/>
- <entity name="Ifr" value="ℑ"/>
- <entity name="igrave" value="ì"/>
- <entity name="Igrave" value="Ì"/>
- <entity name="ii" value="ⅈ"/>
- <entity name="iiiint" value="⨌"/>
- <entity name="iiint" value="∭"/>
- <entity name="iinfin" value="⧜"/>
- <entity name="iiota" value="℩"/>
- <entity name="ijlig" value="ij"/>
- <entity name="IJlig" value="IJ"/>
- <entity name="Im" value="ℑ"/>
- <entity name="imacr" value="ī"/>
- <entity name="Imacr" value="Ī"/>
- <entity name="image" value="ℑ"/>
- <entity name="ImaginaryI" value="ⅈ"/>
- <entity name="imagline" value="ℐ"/>
- <entity name="imagpart" value="ℑ"/>
- <entity name="imath" value="ı"/>
- <entity name="imof" value="⊷"/>
- <entity name="imped" value="𝕃"/>
- <entity name="Implies" value="⇒"/>
- <entity name="in" value="∈"/>
- <entity name="incare" value="℅"/>
- <entity name="infin" value="∞"/>
- <entity name="inodot" value="ı"/>
- <entity name="int" value="∫"/>
- <entity name="Int" value="∬"/>
- <entity name="intcal" value="⊺"/>
- <entity name="integers" value="ℤ"/>
- <entity name="Integral" value="∫"/>
- <entity name="intercal" value="⊺"/>
- <entity name="Intersection" value="⋂"/>
- <entity name="intlarhk" value="⨗"/>
- <entity name="intprod" value="⨼"/>
- <entity name="InvisibleComma" value="​"/>
- <entity name="InvisibleTimes" value="⁢"/>
- <entity name="iocy" value="ё"/>
- <entity name="IOcy" value="Ё"/>
- <entity name="iogon" value="į"/>
- <entity name="Iogon" value="Į"/>
- <entity name="iopf" value="𝕚"/>
- <entity name="Iopf" value="𝕀"/>
- <entity name="iota" value="ι"/>
- <entity name="iprod" value="⨼"/>
- <entity name="iquest" value="¿"/>
- <entity name="iscr" value="𝒾"/>
- <entity name="Iscr" value="ℐ"/>
- <entity name="isin" value="∈"/>
- <entity name="isindot" value="⋵"/>
- <entity name="isinE" value="⋹"/>
- <entity name="isins" value="⋴"/>
- <entity name="isinsv" value="⋳"/>
- <entity name="isinv" value="∈"/>
- <entity name="it" value="⁢"/>
- <entity name="itilde" value="ĩ"/>
- <entity name="Itilde" value="Ĩ"/>
- <entity name="iukcy" value="і"/>
- <entity name="Iukcy" value="І"/>
- <entity name="iuml" value="ï"/>
- <entity name="Iuml" value="Ï"/>
- <entity name="jcirc" value="ĵ"/>
- <entity name="Jcirc" value="Ĵ"/>
- <entity name="jcy" value="й"/>
- <entity name="Jcy" value="Й"/>
- <entity name="jfr" value="𝔧"/>
- <entity name="Jfr" value="𝔍"/>
- <entity name="jmath" value="j︀"/>
- <entity name="jopf" value="𝕛"/>
- <entity name="Jopf" value="𝕁"/>
- <entity name="jscr" value="𝒿"/>
- <entity name="Jscr" value="𝒥"/>
- <entity name="jsercy" value="ј"/>
- <entity name="Jsercy" value="Ј"/>
- <entity name="jukcy" value="є"/>
- <entity name="Jukcy" value="Є"/>
- <entity name="kappa" value="κ"/>
- <entity name="kappav" value="ϰ"/>
- <entity name="kcedil" value="ķ"/>
- <entity name="Kcedil" value="Ķ"/>
- <entity name="kcy" value="к"/>
- <entity name="Kcy" value="К"/>
- <entity name="kfr" value="𝔨"/>
- <entity name="Kfr" value="𝔎"/>
- <entity name="kgreen" value="ĸ"/>
- <entity name="khcy" value="х"/>
- <entity name="KHcy" value="Х"/>
- <entity name="kjcy" value="ќ"/>
- <entity name="KJcy" value="Ќ"/>
- <entity name="kopf" value="𝕜"/>
- <entity name="Kopf" value="𝕂"/>
- <entity name="kscr" value="𝓀"/>
- <entity name="Kscr" value="𝒦"/>
- <entity name="lAarr" value="⇚"/>
- <entity name="lacute" value="ĺ"/>
- <entity name="Lacute" value="Ĺ"/>
- <entity name="laemptyv" value="⦴"/>
- <entity name="lagran" value="ℒ"/>
- <entity name="lambda" value="λ"/>
- <entity name="Lambda" value="Λ"/>
- <entity name="lang" value="〈"/>
- <entity name="Lang" value="《"/>
- <entity name="langd" value="⦑"/>
- <entity name="langle" value="〈"/>
- <entity name="lap" value="≲"/>
- <entity name="Laplacetrf" value="ℒ"/>
- <entity name="laquo" value="«"/>
- <entity name="larr" value="←"/>
- <entity name="lArr" value="⇐"/>
- <entity name="Larr" value="↞"/>
- <entity name="larrb" value="⇤"/>
- <entity name="larrbfs" value="⤟"/>
- <entity name="larrfs" value="⤝"/>
- <entity name="larrhk" value="↩"/>
- <entity name="larrlp" value="↫"/>
- <entity name="larrpl" value="⤹"/>
- <entity name="larrsim" value="⥳"/>
- <entity name="larrtl" value="↢"/>
- <entity name="lat" value="⪫"/>
- <entity name="latail" value="⤙"/>
- <entity name="lAtail" value="⤛"/>
- <entity name="late" value="⪭"/>
- <entity name="lates" value="⪭︀"/>
- <entity name="lbarr" value="⤌"/>
- <entity name="lBarr" value="⤎"/>
- <entity name="lbbrk" value="〔"/>
- <entity name="lbrace" value="{"/>
- <entity name="lbrack" value="["/>
- <entity name="lbrke" value="⦋"/>
- <entity name="lbrksld" value="⦏"/>
- <entity name="lbrkslu" value="⦍"/>
- <entity name="lcaron" value="ľ"/>
- <entity name="Lcaron" value="Ľ"/>
- <entity name="lcedil" value="ļ"/>
- <entity name="Lcedil" value="Ļ"/>
- <entity name="lceil" value="⌈"/>
- <entity name="lcub" value="{"/>
- <entity name="lcy" value="л"/>
- <entity name="Lcy" value="Л"/>
- <entity name="ldca" value="⤶"/>
- <entity name="ldquo" value="“"/>
- <entity name="ldquor" value="„"/>
- <entity name="ldrdhar" value="⥧"/>
- <entity name="ldrushar" value="⥋"/>
- <entity name="ldsh" value="↲"/>
- <entity name="le" value="≤"/>
- <entity name="lE" value="≦"/>
- <entity name="LeftAngleBracket" value="〈"/>
- <entity name="leftarrow" value="←"/>
- <entity name="Leftarrow" value="⇐"/>
- <entity name="LeftArrow" value="←"/>
- <entity name="LeftArrowBar" value="⇤"/>
- <entity name="LeftArrowRightArrow" value="⇆"/>
- <entity name="leftarrowtail" value="↢"/>
- <entity name="LeftCeiling" value="⌈"/>
- <entity name="LeftDoubleBracket" value="〚"/>
- <entity name="LeftDownTeeVector" value="⥡"/>
- <entity name="LeftDownVector" value="⇃"/>
- <entity name="LeftDownVectorBar" value="⥙"/>
- <entity name="LeftFloor" value="⌊"/>
- <entity name="leftharpoondown" value="↽"/>
- <entity name="leftharpoonup" value="↼"/>
- <entity name="leftleftarrows" value="⇇"/>
- <entity name="leftrightarrow" value="↔"/>
- <entity name="Leftrightarrow" value="⇔"/>
- <entity name="LeftRightArrow" value="↔"/>
- <entity name="leftrightarrows" value="⇆"/>
- <entity name="leftrightharpoons" value="⇋"/>
- <entity name="leftrightsquigarrow" value="↭"/>
- <entity name="LeftRightVector" value="⥎"/>
- <entity name="LeftTee" value="⊣"/>
- <entity name="LeftTeeArrow" value="↤"/>
- <entity name="LeftTeeVector" value="⥚"/>
- <entity name="leftthreetimes" value="⋋"/>
- <entity name="LeftTriangle" value="⊲"/>
- <entity name="LeftTriangleBar" value="⧏"/>
- <entity name="LeftTriangleEqual" value="⊴"/>
- <entity name="LeftUpDownVector" value="⥑"/>
- <entity name="LeftUpTeeVector" value="⥠"/>
- <entity name="LeftUpVector" value="↿"/>
- <entity name="LeftUpVectorBar" value="⥘"/>
- <entity name="LeftVector" value="↼"/>
- <entity name="LeftVectorBar" value="⥒"/>
- <entity name="leg" value="⋚"/>
- <entity name="lEg" value="⋚"/>
- <entity name="leq" value="≤"/>
- <entity name="leqq" value="≦"/>
- <entity name="leqslant" value="⩽"/>
- <entity name="les" value="⩽"/>
- <entity name="lescc" value="⪨"/>
- <entity name="lesdot" value="⩿"/>
- <entity name="lesdoto" value="⪁"/>
- <entity name="lesdotor" value="⪃"/>
- <entity name="lesg" value="⋚︀"/>
- <entity name="lesges" value="⪓"/>
- <entity name="lessapprox" value="≲"/>
- <entity name="lessdot" value="⋖"/>
- <entity name="lesseqgtr" value="⋚"/>
- <entity name="lesseqqgtr" value="⋚"/>
- <entity name="LessEqualGreater" value="⋚"/>
- <entity name="LessFullEqual" value="≦"/>
- <entity name="LessGreater" value="≶"/>
- <entity name="lessgtr" value="≶"/>
- <entity name="LessLess" value="⪡"/>
- <entity name="lesssim" value="≲"/>
- <entity name="LessSlantEqual" value="⩽"/>
- <entity name="LessTilde" value="≲"/>
- <entity name="lfisht" value="⥼"/>
- <entity name="lfloor" value="⌊"/>
- <entity name="lfr" value="𝔩"/>
- <entity name="Lfr" value="𝔏"/>
- <entity name="lg" value="≶"/>
- <entity name="lgE" value="⪑"/>
- <entity name="lHar" value="⥢"/>
- <entity name="lhard" value="↽"/>
- <entity name="lharu" value="↼"/>
- <entity name="lharul" value="⥪"/>
- <entity name="lhblk" value="▄"/>
- <entity name="ljcy" value="љ"/>
- <entity name="LJcy" value="Љ"/>
- <entity name="ll" value="≪"/>
- <entity name="Ll" value="⋘"/>
- <entity name="llarr" value="⇇"/>
- <entity name="llcorner" value="⌞"/>
- <entity name="Lleftarrow" value="⇚"/>
- <entity name="llhard" value="⥫"/>
- <entity name="lltri" value="◺"/>
- <entity name="lmidot" value="ŀ"/>
- <entity name="Lmidot" value="Ŀ"/>
- <entity name="lmoust" value="⎰"/>
- <entity name="lmoustache" value="⎰"/>
- <entity name="lnap" value="⪉"/>
- <entity name="lnapprox" value="⪉"/>
- <entity name="lne" value="≨"/>
- <entity name="lnE" value="≨"/>
- <entity name="lneq" value="≨"/>
- <entity name="lneqq" value="≨"/>
- <entity name="lnsim" value="⋦"/>
- <entity name="loang" value=""/>
- <entity name="loarr" value="⇽"/>
- <entity name="lobrk" value="〚"/>
- <entity name="longleftarrow" value=""/>
- <entity name="Longleftarrow" value=""/>
- <entity name="LongLeftArrow" value=""/>
- <entity name="longleftrightarrow" value=""/>
- <entity name="Longleftrightarrow" value=""/>
- <entity name="LongLeftRightArrow" value=""/>
- <entity name="longmapsto" value=""/>
- <entity name="longrightarrow" value=""/>
- <entity name="Longrightarrow" value=""/>
- <entity name="LongRightArrow" value=""/>
- <entity name="looparrowleft" value="↫"/>
- <entity name="looparrowright" value="↬"/>
- <entity name="lopar" value="〘"/>
- <entity name="lopf" value="𝕝"/>
- <entity name="Lopf" value="𝕃"/>
- <entity name="loplus" value="⨭"/>
- <entity name="lotimes" value="⨴"/>
- <entity name="lowast" value="∗"/>
- <entity name="lowbar" value="_"/>
- <entity name="LowerLeftArrow" value="↙"/>
- <entity name="LowerRightArrow" value="↘"/>
- <entity name="loz" value="◊"/>
- <entity name="lozenge" value="◊"/>
- <entity name="lozf" value="⧫"/>
- <entity name="lpar" value="("/>
- <entity name="lparlt" value="⦓"/>
- <entity name="lrarr" value="⇆"/>
- <entity name="lrcorner" value="⌟"/>
- <entity name="lrhar" value="⇋"/>
- <entity name="lrhard" value="⥭"/>
- <entity name="lrtri" value="⊿"/>
- <entity name="lscr" value="ℓ"/>
- <entity name="Lscr" value="ℒ"/>
- <entity name="lsh" value="↰"/>
- <entity name="Lsh" value="↰"/>
- <entity name="lsim" value="≲"/>
- <entity name="lsime" value="⪍"/>
- <entity name="lsimg" value="⪏"/>
- <entity name="lsqb" value="["/>
- <entity name="lsquo" value="‘"/>
- <entity name="lsquor" value="‚"/>
- <entity name="lstrok" value="ł"/>
- <entity name="Lstrok" value="Ł"/>
- <entity name="lt" value="<"/>
- <entity name="Lt" value="≪"/>
- <entity name="ltcc" value="⪦"/>
- <entity name="ltcir" value="⩹"/>
- <entity name="ltdot" value="⋖"/>
- <entity name="lthree" value="⋋"/>
- <entity name="ltimes" value="⋉"/>
- <entity name="ltlarr" value="⥶"/>
- <entity name="ltquest" value="⩻"/>
- <entity name="ltri" value="◃"/>
- <entity name="ltrie" value="⊴"/>
- <entity name="ltrif" value="◂"/>
- <entity name="ltrPar" value="⦖"/>
- <entity name="lurdshar" value="⥊"/>
- <entity name="luruhar" value="⥦"/>
- <entity name="lvertneqq" value="≨︀"/>
- <entity name="lvnE" value="≨︀"/>
- <entity name="macr" value="¯"/>
- <entity name="male" value="♂"/>
- <entity name="malt" value="✠"/>
- <entity name="maltese" value="✠"/>
- <entity name="map" value="↦"/>
- <entity name="Map" value="⤅"/>
- <entity name="mapsto" value="↦"/>
- <entity name="mapstodown" value="↧"/>
- <entity name="mapstoleft" value="↤"/>
- <entity name="mapstoup" value="↥"/>
- <entity name="marker" value="▮"/>
- <entity name="mcomma" value="⨩"/>
- <entity name="mcy" value="м"/>
- <entity name="Mcy" value="М"/>
- <entity name="mdash" value="—"/>
- <entity name="mDDot" value="∺"/>
- <entity name="measuredangle" value="∡"/>
- <entity name="MediumSpace" value=" "/>
- <entity name="Mellintrf" value="ℳ"/>
- <entity name="mfr" value="𝔪"/>
- <entity name="Mfr" value="𝔐"/>
- <entity name="mho" value="℧"/>
- <entity name="micro" value="µ"/>
- <entity name="mid" value="∣"/>
- <entity name="midast" value="*"/>
- <entity name="midcir" value="⫰"/>
- <entity name="middot" value="·"/>
- <entity name="minus" value="−"/>
- <entity name="minusb" value="⊟"/>
- <entity name="minusd" value="∸"/>
- <entity name="minusdu" value="⨪"/>
- <entity name="MinusPlus" value="∓"/>
- <entity name="mlcp" value="⫛"/>
- <entity name="mldr" value="…"/>
- <entity name="mnplus" value="∓"/>
- <entity name="models" value="⊧"/>
- <entity name="mopf" value="𝕞"/>
- <entity name="Mopf" value="𝕄"/>
- <entity name="mp" value="∓"/>
- <entity name="mscr" value="𝓂"/>
- <entity name="Mscr" value="ℳ"/>
- <entity name="mstpos" value="∾"/>
- <entity name="mu" value="μ"/>
- <entity name="multimap" value="⊸"/>
- <entity name="mumap" value="⊸"/>
- <entity name="nabla" value="∇"/>
- <entity name="nacute" value="ń"/>
- <entity name="Nacute" value="Ń"/>
- <entity name="nang" value="∠̸"/>
- <entity name="nap" value="≉"/>
- <entity name="napE" value="⩰̸"/>
- <entity name="napid" value="≋̸"/>
- <entity name="napos" value="ʼn"/>
- <entity name="napprox" value="≉"/>
- <entity name="natur" value="♮"/>
- <entity name="natural" value="♮"/>
- <entity name="naturals" value="ℕ"/>
- <entity name="nbsp" value=" "/>
- <entity name="nbump" value="≎̸"/>
- <entity name="nbumpe" value="≏̸"/>
- <entity name="ncap" value="⩃"/>
- <entity name="ncaron" value="ň"/>
- <entity name="Ncaron" value="Ň"/>
- <entity name="ncedil" value="ņ"/>
- <entity name="Ncedil" value="Ņ"/>
- <entity name="ncong" value="≇"/>
- <entity name="ncongdot" value="⩭̸"/>
- <entity name="ncup" value="⩂"/>
- <entity name="ncy" value="н"/>
- <entity name="Ncy" value="Н"/>
- <entity name="ndash" value="–"/>
- <entity name="ne" value="≠"/>
- <entity name="nearhk" value="⤤"/>
- <entity name="nearr" value="↗"/>
- <entity name="neArr" value="⇗"/>
- <entity name="nearrow" value="↗"/>
- <entity name="nedot" value="≠︀"/>
- <entity name="NegativeMediumSpace" value=" ︀"/>
- <entity name="NegativeThickSpace" value=" ︀"/>
- <entity name="NegativeThinSpace" value=" ︀"/>
- <entity name="NegativeVeryThinSpace" value=" ︀"/>
- <entity name="nequiv" value="≢"/>
- <entity name="nesear" value="⤨"/>
- <entity name="nesim" value="≂̸"/>
- <entity name="NestedGreaterGreater" value="≫"/>
- <entity name="NestedLessLess" value="≪"/>
- <entity name="NewLine" value="
"/>
- <entity name="nexist" value="∄"/>
- <entity name="nexists" value="∄"/>
- <entity name="nfr" value="𝔫"/>
- <entity name="Nfr" value="𝔑"/>
- <entity name="nge" value="≱⃥"/>
- <entity name="ngE" value="≱"/>
- <entity name="ngeq" value="≱⃥"/>
- <entity name="ngeqq" value="≱"/>
- <entity name="ngeqslant" value="≱"/>
- <entity name="nges" value="≱"/>
- <entity name="nGg" value="⋙̸"/>
- <entity name="ngsim" value="≵"/>
- <entity name="ngt" value="≯"/>
- <entity name="nGt" value="≫̸"/>
- <entity name="ngtr" value="≯"/>
- <entity name="nGtv" value="≫̸︀"/>
- <entity name="nharr" value="↮"/>
- <entity name="nhArr" value="⇎"/>
- <entity name="nhpar" value="⫲"/>
- <entity name="ni" value="∋"/>
- <entity name="nis" value="⋼"/>
- <entity name="nisd" value="⋺"/>
- <entity name="niv" value="∋"/>
- <entity name="njcy" value="њ"/>
- <entity name="NJcy" value="Њ"/>
- <entity name="nlarr" value="↚"/>
- <entity name="nlArr" value="⇍"/>
- <entity name="nldr" value="‥"/>
- <entity name="nle" value="≰⃥"/>
- <entity name="nlE" value="≰"/>
- <entity name="nleftarrow" value="↚"/>
- <entity name="nLeftarrow" value="⇍"/>
- <entity name="nleftrightarrow" value="↮"/>
- <entity name="nLeftrightarrow" value="⇎"/>
- <entity name="nleq" value="≰⃥"/>
- <entity name="nleqq" value="≰"/>
- <entity name="nleqslant" value="≰"/>
- <entity name="nles" value="≰"/>
- <entity name="nless" value="≮"/>
- <entity name="nLl" value="⋘̸"/>
- <entity name="nlsim" value="≴"/>
- <entity name="nlt" value="≮"/>
- <entity name="nLt" value="≪̸"/>
- <entity name="nltri" value="⋪"/>
- <entity name="nltrie" value="⋬"/>
- <entity name="nLtv" value="≪̸︀"/>
- <entity name="nmid" value="∤"/>
- <entity name="NoBreak" value=""/>
- <entity name="NonBreakingSpace" value=" "/>
- <entity name="nopf" value="𝕟"/>
- <entity name="Nopf" value="ℕ"/>
- <entity name="not" value="¬"/>
- <entity name="Not" value="⫬"/>
- <entity name="NotCongruent" value="≢"/>
- <entity name="NotCupCap" value="≭"/>
- <entity name="NotDoubleVerticalBar" value="∦"/>
- <entity name="NotElement" value="∉"/>
- <entity name="NotEqual" value="≠"/>
- <entity name="NotEqualTilde" value="≂̸"/>
- <entity name="NotExists" value="∄"/>
- <entity name="NotGreater" value="≯"/>
- <entity name="NotGreaterEqual" value="≱⃥"/>
- <entity name="NotGreaterFullEqual" value="≰"/>
- <entity name="NotGreaterGreater" value="≫̸︀"/>
- <entity name="NotGreaterLess" value="≹"/>
- <entity name="NotGreaterSlantEqual" value="≱"/>
- <entity name="NotGreaterTilde" value="≵"/>
- <entity name="NotHumpDownHump" value="≎̸"/>
- <entity name="NotHumpEqual" value="≏̸"/>
- <entity name="notin" value="∉"/>
- <entity name="notindot" value="⋶︀"/>
- <entity name="notinva" value="∉̸"/>
- <entity name="notinvb" value="⋷"/>
- <entity name="notinvc" value="⋶"/>
- <entity name="NotLeftTriangle" value="⋪"/>
- <entity name="NotLeftTriangleBar" value="⧏̸"/>
- <entity name="NotLeftTriangleEqual" value="⋬"/>
- <entity name="NotLess" value="≮"/>
- <entity name="NotLessEqual" value="≰⃥"/>
- <entity name="NotLessGreater" value="≸"/>
- <entity name="NotLessLess" value="≪̸︀"/>
- <entity name="NotLessSlantEqual" value="≰"/>
- <entity name="NotLessTilde" value="≴"/>
- <entity name="NotNestedGreaterGreater" value="⒢̸"/>
- <entity name="NotNestedLessLess" value="⒡̸"/>
- <entity name="notni" value="∌"/>
- <entity name="notniva" value="∌"/>
- <entity name="notnivb" value="⋾"/>
- <entity name="notnivc" value="⋽"/>
- <entity name="NotPrecedes" value="⊀"/>
- <entity name="NotPrecedesEqual" value="⪯̸"/>
- <entity name="NotPrecedesSlantEqual" value="⋠"/>
- <entity name="NotReverseElement" value="∌"/>
- <entity name="NotRightTriangle" value="⋫"/>
- <entity name="NotRightTriangleBar" value="⧐̸"/>
- <entity name="NotRightTriangleEqual" value="⋭"/>
- <entity name="NotSquareSubset" value="⊏̸"/>
- <entity name="NotSquareSubsetEqual" value="⋢"/>
- <entity name="NotSquareSuperset" value="⊐̸"/>
- <entity name="NotSquareSupersetEqual" value="⋣"/>
- <entity name="NotSubset" value="⊄"/>
- <entity name="NotSubsetEqual" value="⊈"/>
- <entity name="NotSucceeds" value="⊁"/>
- <entity name="NotSucceedsEqual" value="⪰̸"/>
- <entity name="NotSucceedsSlantEqual" value="⋡"/>
- <entity name="NotSucceedsTilde" value="≿̸"/>
- <entity name="NotSuperset" value="⊅"/>
- <entity name="NotSupersetEqual" value="⊉"/>
- <entity name="NotTilde" value="≁"/>
- <entity name="NotTildeEqual" value="≄"/>
- <entity name="NotTildeFullEqual" value="≇"/>
- <entity name="NotTildeTilde" value="≉"/>
- <entity name="NotVerticalBar" value="∤"/>
- <entity name="npar" value="∦"/>
- <entity name="nparallel" value="∦"/>
- <entity name="nparsl" value="∥︀⃥"/>
- <entity name="npart" value="∂̸"/>
- <entity name="npolint" value="⨔"/>
- <entity name="npr" value="⊀"/>
- <entity name="nprcue" value="⋠"/>
- <entity name="npre" value="⪯̸"/>
- <entity name="nprec" value="⊀"/>
- <entity name="npreceq" value="⪯̸"/>
- <entity name="nrarr" value="↛"/>
- <entity name="nrArr" value="⇏"/>
- <entity name="nrarrc" value="⤳̸"/>
- <entity name="nrarrw" value="↝̸"/>
- <entity name="nrightarrow" value="↛"/>
- <entity name="nRightarrow" value="⇏"/>
- <entity name="nrtri" value="⋫"/>
- <entity name="nrtrie" value="⋭"/>
- <entity name="nsc" value="⊁"/>
- <entity name="nsccue" value="⋡"/>
- <entity name="nsce" value="⪰̸"/>
- <entity name="nscr" value="𝓃"/>
- <entity name="Nscr" value="𝒩"/>
- <entity name="nshortmid" value="∤︀"/>
- <entity name="nshortparallel" value="∦︀"/>
- <entity name="nsim" value="≁"/>
- <entity name="nsime" value="≄"/>
- <entity name="nsimeq" value="≄"/>
- <entity name="nsmid" value="∤︀"/>
- <entity name="nspar" value="∦︀"/>
- <entity name="nsqsube" value="⋢"/>
- <entity name="nsqsupe" value="⋣"/>
- <entity name="nsub" value="⊄"/>
- <entity name="nsube" value="⊈"/>
- <entity name="nsubE" value="⊈"/>
- <entity name="nsubset" value="⊄"/>
- <entity name="nsubseteq" value="⊈"/>
- <entity name="nsubseteqq" value="⊈"/>
- <entity name="nsucc" value="⊁"/>
- <entity name="nsucceq" value="⪰̸"/>
- <entity name="nsup" value="⊅"/>
- <entity name="nsupe" value="⊉"/>
- <entity name="nsupE" value="⊉"/>
- <entity name="nsupset" value="⊅"/>
- <entity name="nsupseteq" value="⊉"/>
- <entity name="nsupseteqq" value="⊉"/>
- <entity name="ntgl" value="≹"/>
- <entity name="ntilde" value="ñ"/>
- <entity name="Ntilde" value="Ñ"/>
- <entity name="ntlg" value="≸"/>
- <entity name="ntriangleleft" value="⋪"/>
- <entity name="ntrianglelefteq" value="⋬"/>
- <entity name="ntriangleright" value="⋫"/>
- <entity name="ntrianglerighteq" value="⋭"/>
- <entity name="nu" value="ν"/>
- <entity name="num" value="#"/>
- <entity name="numero" value="№"/>
- <entity name="numsp" value=" "/>
- <entity name="nvap" value="≉̸"/>
- <entity name="nvdash" value="⊬"/>
- <entity name="nvDash" value="⊭"/>
- <entity name="nVdash" value="⊮"/>
- <entity name="nVDash" value="⊯"/>
- <entity name="nvge" value="≱"/>
- <entity name="nvgt" value="≯"/>
- <entity name="nvHarr" value="⇎"/>
- <entity name="nvinfin" value="⧞"/>
- <entity name="nvlArr" value="⇍"/>
- <entity name="nvle" value="≰"/>
- <entity name="nvlt" value="≮"/>
- <entity name="nvltrie" value="⋬̸"/>
- <entity name="nvrArr" value="⇏"/>
- <entity name="nvrtrie" value="⋭̸"/>
- <entity name="nvsim" value="≁̸"/>
- <entity name="nwarhk" value="⤣"/>
- <entity name="nwarr" value="↖"/>
- <entity name="nwArr" value="⇖"/>
- <entity name="nwarrow" value="↖"/>
- <entity name="nwnear" value="⤧"/>
- <entity name="oacute" value="ó"/>
- <entity name="Oacute" value="Ó"/>
- <entity name="oast" value="⊛"/>
- <entity name="ocir" value="⊚"/>
- <entity name="ocirc" value="ô"/>
- <entity name="Ocirc" value="Ô"/>
- <entity name="ocy" value="о"/>
- <entity name="Ocy" value="О"/>
- <entity name="odash" value="⊝"/>
- <entity name="odblac" value="ő"/>
- <entity name="Odblac" value="Ő"/>
- <entity name="odiv" value="⨸"/>
- <entity name="odot" value="⊙"/>
- <entity name="odsold" value="⦼"/>
- <entity name="oelig" value="œ"/>
- <entity name="OElig" value="Œ"/>
- <entity name="ofcir" value="⦿"/>
- <entity name="ofr" value="𝔬"/>
- <entity name="Ofr" value="𝔒"/>
- <entity name="ogon" value="˛"/>
- <entity name="ograve" value="ò"/>
- <entity name="Ograve" value="Ò"/>
- <entity name="ogt" value="⧁"/>
- <entity name="ohbar" value="⦵"/>
- <entity name="ohm" value="Ω"/>
- <entity name="oint" value="∮"/>
- <entity name="olarr" value="↺"/>
- <entity name="olcir" value="⦾"/>
- <entity name="olcross" value="⦻"/>
- <entity name="olt" value="⧀"/>
- <entity name="omacr" value="ō"/>
- <entity name="Omacr" value="Ō"/>
- <entity name="omega" value="ω"/>
- <entity name="Omega" value="Ω"/>
- <entity name="omid" value="⦶"/>
- <entity name="ominus" value="⊖"/>
- <entity name="oopf" value="𝕠"/>
- <entity name="Oopf" value="𝕆"/>
- <entity name="opar" value="⦷"/>
- <entity name="OpenCurlyDoubleQuote" value="“"/>
- <entity name="OpenCurlyQuote" value="‘"/>
- <entity name="operp" value="⦹"/>
- <entity name="oplus" value="⊕"/>
- <entity name="or" value="∨"/>
- <entity name="Or" value="⩔"/>
- <entity name="orarr" value="↻"/>
- <entity name="ord" value="⩝"/>
- <entity name="order" value="ℴ"/>
- <entity name="orderof" value="ℴ"/>
- <entity name="ordf" value="ª"/>
- <entity name="ordm" value="º"/>
- <entity name="origof" value="⊶"/>
- <entity name="oror" value="⩖"/>
- <entity name="orslope" value="⩗"/>
- <entity name="orv" value="⩛"/>
- <entity name="oS" value="Ⓢ"/>
- <entity name="oscr" value="ℴ"/>
- <entity name="Oscr" value="𝒪"/>
- <entity name="oslash" value="ø"/>
- <entity name="Oslash" value="Ø"/>
- <entity name="osol" value="⊘"/>
- <entity name="otilde" value="õ"/>
- <entity name="Otilde" value="Õ"/>
- <entity name="otimes" value="⊗"/>
- <entity name="Otimes" value="⨷"/>
- <entity name="otimesas" value="⨶"/>
- <entity name="ouml" value="ö"/>
- <entity name="Ouml" value="Ö"/>
- <entity name="ovbar" value="⌽"/>
- <entity name="OverBar" value="¯"/>
- <entity name="OverBrace" value="︷"/>
- <entity name="OverBracket" value="⎴"/>
- <entity name="OverParenthesis" value="︵"/>
- <entity name="par" value="∥"/>
- <entity name="para" value="¶"/>
- <entity name="parallel" value="∥"/>
- <entity name="parsim" value="⫳"/>
- <entity name="parsl" value="∥︀"/>
- <entity name="part" value="∂"/>
- <entity name="PartialD" value="∂"/>
- <entity name="pcy" value="п"/>
- <entity name="Pcy" value="П"/>
- <entity name="percnt" value="%"/>
- <entity name="period" value="."/>
- <entity name="permil" value="‰"/>
- <entity name="perp" value="⊥"/>
- <entity name="pertenk" value="‱"/>
- <entity name="pfr" value="𝔭"/>
- <entity name="Pfr" value="𝔓"/>
- <entity name="phi" value="φ"/>
- <entity name="Phi" value="Φ"/>
- <entity name="phiv" value="ϕ"/>
- <entity name="phmmat" value="ℳ"/>
- <entity name="phone" value="☎"/>
- <entity name="pi" value="π"/>
- <entity name="Pi" value="Π"/>
- <entity name="pitchfork" value="⋔"/>
- <entity name="piv" value="ϖ"/>
- <entity name="planck" value="ℏ︀"/>
- <entity name="planckh" value="ℎ"/>
- <entity name="plankv" value="ℏ"/>
- <entity name="plus" value="+"/>
- <entity name="plusacir" value="⨣"/>
- <entity name="plusb" value="⊞"/>
- <entity name="pluscir" value="⨢"/>
- <entity name="plusdo" value="∔"/>
- <entity name="plusdu" value="⨥"/>
- <entity name="pluse" value="⩲"/>
- <entity name="PlusMinus" value="±"/>
- <entity name="plusmn" value="±"/>
- <entity name="plussim" value="⨦"/>
- <entity name="plustwo" value="⨧"/>
- <entity name="pm" value="±"/>
- <entity name="Poincareplane" value="ℌ"/>
- <entity name="pointint" value="⨕"/>
- <entity name="popf" value="𝕡"/>
- <entity name="Popf" value="ℙ"/>
- <entity name="pound" value="£"/>
- <entity name="pr" value="≺"/>
- <entity name="Pr" value="⪻"/>
- <entity name="prap" value="≾"/>
- <entity name="prcue" value="≼"/>
- <entity name="pre" value="⪯"/>
- <entity name="prE" value="⪯"/>
- <entity name="prec" value="≺"/>
- <entity name="precapprox" value="≾"/>
- <entity name="preccurlyeq" value="≼"/>
- <entity name="Precedes" value="≺"/>
- <entity name="PrecedesEqual" value="⪯"/>
- <entity name="PrecedesSlantEqual" value="≼"/>
- <entity name="PrecedesTilde" value="≾"/>
- <entity name="preceq" value="⪯"/>
- <entity name="precnapprox" value="⋨"/>
- <entity name="precneqq" value="⪵"/>
- <entity name="precnsim" value="⋨"/>
- <entity name="precsim" value="≾"/>
- <entity name="prime" value="′"/>
- <entity name="Prime" value="″"/>
- <entity name="primes" value="ℙ"/>
- <entity name="prnap" value="⋨"/>
- <entity name="prnE" value="⪵"/>
- <entity name="prnsim" value="⋨"/>
- <entity name="prod" value="∏"/>
- <entity name="Product" value="∏"/>
- <entity name="profalar" value="⌮"/>
- <entity name="profline" value="⌒"/>
- <entity name="profsurf" value="⌓"/>
- <entity name="prop" value="∝"/>
- <entity name="Proportion" value="∷"/>
- <entity name="Proportional" value="∝"/>
- <entity name="propto" value="∝"/>
- <entity name="prsim" value="≾"/>
- <entity name="prurel" value="⊰"/>
- <entity name="pscr" value="𝓅"/>
- <entity name="Pscr" value="𝒫"/>
- <entity name="psi" value="ψ"/>
- <entity name="Psi" value="Ψ"/>
- <entity name="puncsp" value=" "/>
- <entity name="qfr" value="𝔮"/>
- <entity name="Qfr" value="𝔔"/>
- <entity name="qint" value="⨌"/>
- <entity name="qopf" value="𝕢"/>
- <entity name="Qopf" value="ℚ"/>
- <entity name="qprime" value="⁗"/>
- <entity name="qscr" value="𝓆"/>
- <entity name="Qscr" value="𝒬"/>
- <entity name="quaternions" value="ℍ"/>
- <entity name="quatint" value="⨖"/>
- <entity name="quest" value="?"/>
- <entity name="questeq" value="≟"/>
- <entity name="quot" value="""/>
- <entity name="rAarr" value="⇛"/>
- <entity name="race" value="⧚"/>
- <entity name="racute" value="ŕ"/>
- <entity name="Racute" value="Ŕ"/>
- <entity name="radic" value="√"/>
- <entity name="raemptyv" value="⦳"/>
- <entity name="rang" value="〉"/>
- <entity name="Rang" value="》"/>
- <entity name="rangd" value="⦒"/>
- <entity name="range" value="⦥"/>
- <entity name="rangle" value="〉"/>
- <entity name="raquo" value="»"/>
- <entity name="rarr" value="→"/>
- <entity name="rArr" value="⇒"/>
- <entity name="Rarr" value="↠"/>
- <entity name="rarrap" value="⥵"/>
- <entity name="rarrb" value="⇥"/>
- <entity name="rarrbfs" value="⤠"/>
- <entity name="rarrc" value="⤳"/>
- <entity name="rarrfs" value="⤞"/>
- <entity name="rarrhk" value="↪"/>
- <entity name="rarrlp" value="↬"/>
- <entity name="rarrpl" value="⥅"/>
- <entity name="rarrsim" value="⥴"/>
- <entity name="rarrtl" value="↣"/>
- <entity name="Rarrtl" value="⤖"/>
- <entity name="rarrw" value="↝"/>
- <entity name="ratail" value="↣"/>
- <entity name="rAtail" value="⤜"/>
- <entity name="ratio" value="∶"/>
- <entity name="rationals" value="ℚ"/>
- <entity name="rbarr" value="⤍"/>
- <entity name="rBarr" value="⤏"/>
- <entity name="RBarr" value="⤐"/>
- <entity name="rbbrk" value="〕"/>
- <entity name="rbrace" value="}"/>
- <entity name="rbrack" value="]"/>
- <entity name="rbrke" value="⦌"/>
- <entity name="rbrksld" value="⦎"/>
- <entity name="rbrkslu" value="⦐"/>
- <entity name="rcaron" value="ř"/>
- <entity name="Rcaron" value="Ř"/>
- <entity name="rcedil" value="ŗ"/>
- <entity name="Rcedil" value="Ŗ"/>
- <entity name="rceil" value="⌉"/>
- <entity name="rcub" value="}"/>
- <entity name="rcy" value="р"/>
- <entity name="Rcy" value="Р"/>
- <entity name="rdca" value="⤷"/>
- <entity name="rdldhar" value="⥩"/>
- <entity name="rdquo" value="”"/>
- <entity name="rdquor" value="”"/>
- <entity name="rdsh" value="↳"/>
- <entity name="Re" value="ℜ"/>
- <entity name="real" value="ℜ"/>
- <entity name="realine" value="ℛ"/>
- <entity name="realpart" value="ℜ"/>
- <entity name="reals" value="ℝ"/>
- <entity name="rect" value="▭"/>
- <entity name="reg" value="®"/>
- <entity name="ReverseElement" value="∋"/>
- <entity name="ReverseEquilibrium" value="⇋"/>
- <entity name="ReverseUpEquilibrium" value="⥯"/>
- <entity name="rfisht" value="⥽"/>
- <entity name="rfloor" value="⌋"/>
- <entity name="rfr" value="𝔯"/>
- <entity name="Rfr" value="ℜ"/>
- <entity name="rHar" value="⥤"/>
- <entity name="rhard" value="⇁"/>
- <entity name="rharu" value="⇀"/>
- <entity name="rharul" value="⥬"/>
- <entity name="rho" value="ρ"/>
- <entity name="rhov" value="ϱ"/>
- <entity name="RightAngleBracket" value="〉"/>
- <entity name="rightarrow" value="→"/>
- <entity name="Rightarrow" value="⇒"/>
- <entity name="RightArrow" value="→"/>
- <entity name="RightArrowBar" value="⇥"/>
- <entity name="RightArrowLeftArrow" value="⇄"/>
- <entity name="rightarrowtail" value="↣"/>
- <entity name="RightCeiling" value="⌉"/>
- <entity name="RightDoubleBracket" value="〛"/>
- <entity name="RightDownTeeVector" value="⥝"/>
- <entity name="RightDownVector" value="⇂"/>
- <entity name="RightDownVectorBar" value="⥕"/>
- <entity name="RightFloor" value="⌋"/>
- <entity name="rightharpoondown" value="⇁"/>
- <entity name="rightharpoonup" value="⇀"/>
- <entity name="rightleftarrows" value="⇄"/>
- <entity name="rightleftharpoons" value="⇌"/>
- <entity name="rightrightarrows" value="⇉"/>
- <entity name="rightsquigarrow" value="↝"/>
- <entity name="RightTee" value="⊢"/>
- <entity name="RightTeeArrow" value="↦"/>
- <entity name="RightTeeVector" value="⥛"/>
- <entity name="rightthreetimes" value="⋌"/>
- <entity name="RightTriangle" value="⊳"/>
- <entity name="RightTriangleBar" value="⧐"/>
- <entity name="RightTriangleEqual" value="⊵"/>
- <entity name="RightUpDownVector" value="⥏"/>
- <entity name="RightUpTeeVector" value="⥜"/>
- <entity name="RightUpVector" value="↾"/>
- <entity name="RightUpVectorBar" value="⥔"/>
- <entity name="RightVector" value="⇀"/>
- <entity name="RightVectorBar" value="⥓"/>
- <entity name="ring" value="˚"/>
- <entity name="risingdotseq" value="≓"/>
- <entity name="rlarr" value="⇄"/>
- <entity name="rlhar" value="⇌"/>
- <entity name="rmoust" value="⎱"/>
- <entity name="rmoustache" value="⎱"/>
- <entity name="rnmid" value="⫮"/>
- <entity name="roang" value=""/>
- <entity name="roarr" value="⇾"/>
- <entity name="robrk" value="〛"/>
- <entity name="ropar" value="〙"/>
- <entity name="ropf" value="𝕣"/>
- <entity name="Ropf" value="ℝ"/>
- <entity name="roplus" value="⨮"/>
- <entity name="rotimes" value="⨵"/>
- <entity name="RoundImplies" value="⥰"/>
- <entity name="rpar" value=")"/>
- <entity name="rpargt" value="⦔"/>
- <entity name="rppolint" value="⨒"/>
- <entity name="rrarr" value="⇉"/>
- <entity name="Rrightarrow" value="⇛"/>
- <entity name="rscr" value="𝓇"/>
- <entity name="Rscr" value="ℛ"/>
- <entity name="rsh" value="↱"/>
- <entity name="Rsh" value="↱"/>
- <entity name="rsqb" value="]"/>
- <entity name="rsquo" value="’"/>
- <entity name="rsquor" value="’"/>
- <entity name="rthree" value="⋌"/>
- <entity name="rtimes" value="⋊"/>
- <entity name="rtri" value="▹"/>
- <entity name="rtrie" value="⊵"/>
- <entity name="rtrif" value="▸"/>
- <entity name="rtriltri" value="⧎"/>
- <entity name="RuleDelayed" value="⧴"/>
- <entity name="ruluhar" value="⥨"/>
- <entity name="rx" value="℞"/>
- <entity name="sacute" value="ś"/>
- <entity name="Sacute" value="Ś"/>
- <entity name="sc" value="≻"/>
- <entity name="Sc" value="⪼"/>
- <entity name="scap" value="≿"/>
- <entity name="scaron" value="š"/>
- <entity name="Scaron" value="Š"/>
- <entity name="sccue" value="≽"/>
- <entity name="sce" value="≽"/>
- <entity name="scE" value="≾"/>
- <entity name="scedil" value="ş"/>
- <entity name="Scedil" value="Ş"/>
- <entity name="scirc" value="ŝ"/>
- <entity name="Scirc" value="Ŝ"/>
- <entity name="scnap" value="⋩"/>
- <entity name="scnE" value="⪶"/>
- <entity name="scnsim" value="⋩"/>
- <entity name="scpolint" value="⨓"/>
- <entity name="scsim" value="≿"/>
- <entity name="scy" value="с"/>
- <entity name="Scy" value="С"/>
- <entity name="sdot" value="⋅"/>
- <entity name="sdotb" value="⊡"/>
- <entity name="sdote" value="⩦"/>
- <entity name="searhk" value="⤥"/>
- <entity name="searr" value="↘"/>
- <entity name="seArr" value="⇘"/>
- <entity name="searrow" value="↘"/>
- <entity name="sect" value="§"/>
- <entity name="semi" value=";"/>
- <entity name="seswar" value="⤩"/>
- <entity name="setminus" value="∖"/>
- <entity name="setmn" value="∖"/>
- <entity name="sext" value="✶"/>
- <entity name="sfr" value="𝔰"/>
- <entity name="Sfr" value="𝔖"/>
- <entity name="sharp" value="♯"/>
- <entity name="shchcy" value="щ"/>
- <entity name="SHCHcy" value="Щ"/>
- <entity name="shcy" value="ш"/>
- <entity name="SHcy" value="Ш"/>
- <entity name="ShortDownArrow" value="⌄︀"/>
- <entity name="ShortLeftArrow" value="←︀"/>
- <entity name="shortmid" value="∣︀"/>
- <entity name="shortparallel" value="∥︀"/>
- <entity name="ShortRightArrow" value="→︀"/>
- <entity name="ShortUpArrow" value="⌃︀"/>
- <entity name="shy" value="­"/>
- <entity name="sigma" value="σ"/>
- <entity name="Sigma" value="Σ"/>
- <entity name="sigmav" value="ς"/>
- <entity name="sim" value="∼"/>
- <entity name="simdot" value="⩪"/>
- <entity name="sime" value="≃"/>
- <entity name="simeq" value="≃"/>
- <entity name="simg" value="⪞"/>
- <entity name="simgE" value="⪠"/>
- <entity name="siml" value="⪝"/>
- <entity name="simlE" value="⪟"/>
- <entity name="simne" value="≆"/>
- <entity name="simplus" value="⨤"/>
- <entity name="simrarr" value="⥲"/>
- <entity name="slarr" value="←︀"/>
- <entity name="SmallCircle" value="∘"/>
- <entity name="smallsetminus" value="∖︀"/>
- <entity name="smashp" value="⨳"/>
- <entity name="smeparsl" value="⧤"/>
- <entity name="smid" value="∣︀"/>
- <entity name="smile" value="⌣"/>
- <entity name="smt" value="⪪"/>
- <entity name="smte" value="⪬"/>
- <entity name="smtes" value="⪬︀"/>
- <entity name="softcy" value="ь"/>
- <entity name="SOFTcy" value="Ь"/>
- <entity name="sol" value="/"/>
- <entity name="solb" value="⧄"/>
- <entity name="solbar" value="⌿"/>
- <entity name="sopf" value="𝕤"/>
- <entity name="Sopf" value="𝕊"/>
- <entity name="spades" value="♠"/>
- <entity name="spadesuit" value="♠"/>
- <entity name="spar" value="∥︀"/>
- <entity name="sqcap" value="⊓"/>
- <entity name="sqcaps" value="⊓︀"/>
- <entity name="sqcup" value="⊔"/>
- <entity name="sqcups" value="⊔︀"/>
- <entity name="Sqrt" value="√"/>
- <entity name="sqsub" value="⊏"/>
- <entity name="sqsube" value="⊑"/>
- <entity name="sqsubset" value="⊏"/>
- <entity name="sqsubseteq" value="⊑"/>
- <entity name="sqsup" value="⊐"/>
- <entity name="sqsupe" value="⊒"/>
- <entity name="sqsupset" value="⊐"/>
- <entity name="sqsupseteq" value="⊒"/>
- <entity name="squ" value="□"/>
- <entity name="square" value="□"/>
- <entity name="Square" value="□"/>
- <entity name="SquareIntersection" value="⊓"/>
- <entity name="SquareSubset" value="⊏"/>
- <entity name="SquareSubsetEqual" value="⊑"/>
- <entity name="SquareSuperset" value="⊐"/>
- <entity name="SquareSupersetEqual" value="⊒"/>
- <entity name="SquareUnion" value="⊔"/>
- <entity name="squarf" value="▪"/>
- <entity name="squf" value="▪"/>
- <entity name="srarr" value="→︀"/>
- <entity name="sscr" value="𝓈"/>
- <entity name="Sscr" value="𝒮"/>
- <entity name="ssetmn" value="∖︀"/>
- <entity name="sstarf" value="⋆"/>
- <entity name="star" value="⋆"/>
- <entity name="Star" value="⋆"/>
- <entity name="starf" value="★"/>
- <entity name="straightepsilon" value="ε"/>
- <entity name="straightphi" value="φ"/>
- <entity name="Sub" value="⋐"/>
- <entity name="subdot" value="⪽"/>
- <entity name="sube" value="⊆"/>
- <entity name="subE" value="⊆"/>
- <entity name="subedot" value="⫃"/>
- <entity name="submult" value="⫁"/>
- <entity name="subne" value="⊊"/>
- <entity name="subnE" value="⊊"/>
- <entity name="subplus" value="⪿"/>
- <entity name="subrarr" value="⥹"/>
- <entity name="subset" value="⊂"/>
- <entity name="Subset" value="⋐"/>
- <entity name="subseteq" value="⊆"/>
- <entity name="subseteqq" value="⊆"/>
- <entity name="SubsetEqual" value="⊆"/>
- <entity name="subsetneq" value="⊊"/>
- <entity name="subsetneqq" value="⊊"/>
- <entity name="subsim" value="⫇"/>
- <entity name="subsub" value="⫕"/>
- <entity name="subsup" value="⫓"/>
- <entity name="succ" value="≻"/>
- <entity name="succapprox" value="≿"/>
- <entity name="succcurlyeq" value="≽"/>
- <entity name="Succeeds" value="≻"/>
- <entity name="SucceedsEqual" value="≽"/>
- <entity name="SucceedsSlantEqual" value="≽"/>
- <entity name="SucceedsTilde" value="≿"/>
- <entity name="succeq" value="≽"/>
- <entity name="succnapprox" value="⋩"/>
- <entity name="succneqq" value="⪶"/>
- <entity name="succnsim" value="⋩"/>
- <entity name="succsim" value="≿"/>
- <entity name="SuchThat" value="∋"/>
- <entity name="sum" value="∑"/>
- <entity name="Sum" value="∑"/>
- <entity name="sung" value="♪"/>
- <entity name="Sup" value="⋑"/>
- <entity name="sup1" value="¹"/>
- <entity name="sup2" value="²"/>
- <entity name="sup3" value="³"/>
- <entity name="supdot" value="⪾"/>
- <entity name="supdsub" value="⫘"/>
- <entity name="supe" value="⊇"/>
- <entity name="supE" value="⊇"/>
- <entity name="supedot" value="⫄"/>
- <entity name="Superset" value="⊃"/>
- <entity name="SupersetEqual" value="⊇"/>
- <entity name="suphsol" value="⊃/"/>
- <entity name="suphsub" value="⫗"/>
- <entity name="suplarr" value="⥻"/>
- <entity name="supmult" value="⫂"/>
- <entity name="supne" value="⊋"/>
- <entity name="supnE" value="⊋"/>
- <entity name="supplus" value="⫀"/>
- <entity name="supset" value="⊃"/>
- <entity name="Supset" value="⋑"/>
- <entity name="supseteq" value="⊇"/>
- <entity name="supseteqq" value="⊇"/>
- <entity name="supsetneq" value="⊋"/>
- <entity name="supsetneqq" value="⊋"/>
- <entity name="supsim" value="⫈"/>
- <entity name="supsub" value="⫔"/>
- <entity name="supsup" value="⫖"/>
- <entity name="swarhk" value="⤦"/>
- <entity name="swarr" value="↙"/>
- <entity name="swArr" value="⇙"/>
- <entity name="swarrow" value="↙"/>
- <entity name="swnwar" value="⤪"/>
- <entity name="szlig" value="ß"/>
- <entity name="Tab" value="	"/>
- <entity name="target" value="⌖"/>
- <entity name="tau" value="τ"/>
- <entity name="tbrk" value="⎴"/>
- <entity name="tcaron" value="ť"/>
- <entity name="Tcaron" value="Ť"/>
- <entity name="tcedil" value="ţ"/>
- <entity name="Tcedil" value="Ţ"/>
- <entity name="tcy" value="т"/>
- <entity name="Tcy" value="Т"/>
- <entity name="tdot" value="⃛"/>
- <entity name="telrec" value="⌕"/>
- <entity name="tfr" value="𝔱"/>
- <entity name="Tfr" value="𝔗"/>
- <entity name="there4" value="∴"/>
- <entity name="therefore" value="∴"/>
- <entity name="Therefore" value="∴"/>
- <entity name="theta" value="θ"/>
- <entity name="Theta" value="Θ"/>
- <entity name="thetav" value="ϑ"/>
- <entity name="thickapprox" value="≈︀"/>
- <entity name="thicksim" value="∼︀"/>
- <entity name="ThickSpace" value="   "/>
- <entity name="thinsp" value=" "/>
- <entity name="ThinSpace" value=" "/>
- <entity name="thkap" value="≈︀"/>
- <entity name="thksim" value="∼︀"/>
- <entity name="thorn" value="þ"/>
- <entity name="THORN" value="Þ"/>
- <entity name="tilde" value="˜"/>
- <entity name="Tilde" value="∼"/>
- <entity name="TildeEqual" value="≃"/>
- <entity name="TildeFullEqual" value="≅"/>
- <entity name="TildeTilde" value="≈"/>
- <entity name="times" value="×"/>
- <entity name="timesb" value="⊠"/>
- <entity name="timesbar" value="⨱"/>
- <entity name="timesd" value="⨰"/>
- <entity name="tint" value="∭"/>
- <entity name="toea" value="⤨"/>
- <entity name="top" value="⊤"/>
- <entity name="topbot" value="⌶"/>
- <entity name="topcir" value="⫱"/>
- <entity name="topf" value="𝕥"/>
- <entity name="Topf" value="𝕋"/>
- <entity name="topfork" value="⫚"/>
- <entity name="tosa" value="⤩"/>
- <entity name="tprime" value="‴"/>
- <entity name="trade" value="™"/>
- <entity name="triangle" value="▵"/>
- <entity name="triangledown" value="▿"/>
- <entity name="triangleleft" value="◃"/>
- <entity name="trianglelefteq" value="⊴"/>
- <entity name="triangleq" value="≜"/>
- <entity name="triangleright" value="▹"/>
- <entity name="trianglerighteq" value="⊵"/>
- <entity name="tridot" value="◬"/>
- <entity name="trie" value="≜"/>
- <entity name="triminus" value="⨺"/>
- <entity name="TripleDot" value="⃛"/>
- <entity name="triplus" value="⨹"/>
- <entity name="trisb" value="⧍"/>
- <entity name="tritime" value="⨻"/>
- <entity name="tscr" value="𝓉"/>
- <entity name="Tscr" value="𝒯"/>
- <entity name="tscy" value="ц"/>
- <entity name="TScy" value="Ц"/>
- <entity name="tshcy" value="ћ"/>
- <entity name="TSHcy" value="Ћ"/>
- <entity name="tstrok" value="ŧ"/>
- <entity name="Tstrok" value="Ŧ"/>
- <entity name="twixt" value="≬"/>
- <entity name="twoheadleftarrow" value="↞"/>
- <entity name="twoheadrightarrow" value="↠"/>
- <entity name="uacute" value="ú"/>
- <entity name="Uacute" value="Ú"/>
- <entity name="uarr" value="↑"/>
- <entity name="uArr" value="⇑"/>
- <entity name="Uarr" value="↟"/>
- <entity name="Uarrocir" value="⥉"/>
- <entity name="ubrcy" value="ў"/>
- <entity name="Ubrcy" value="Ў"/>
- <entity name="ubreve" value="ŭ"/>
- <entity name="Ubreve" value="Ŭ"/>
- <entity name="ucirc" value="û"/>
- <entity name="Ucirc" value="Û"/>
- <entity name="ucy" value="у"/>
- <entity name="Ucy" value="У"/>
- <entity name="udarr" value="⇅"/>
- <entity name="udblac" value="ű"/>
- <entity name="Udblac" value="Ű"/>
- <entity name="udhar" value="⥮"/>
- <entity name="ufisht" value="⥾"/>
- <entity name="ufr" value="𝔲"/>
- <entity name="Ufr" value="𝔘"/>
- <entity name="ugrave" value="ù"/>
- <entity name="Ugrave" value="Ù"/>
- <entity name="uHar" value="⥣"/>
- <entity name="uharl" value="↿"/>
- <entity name="uharr" value="↾"/>
- <entity name="uhblk" value="▀"/>
- <entity name="ulcorn" value="⌜"/>
- <entity name="ulcorner" value="⌜"/>
- <entity name="ulcrop" value="⌏"/>
- <entity name="ultri" value="◸"/>
- <entity name="umacr" value="ū"/>
- <entity name="Umacr" value="Ū"/>
- <entity name="uml" value="¨"/>
- <entity name="UnderBar" value="̲"/>
- <entity name="UnderBrace" value="︸"/>
- <entity name="UnderBracket" value="⎵"/>
- <entity name="UnderParenthesis" value="︶"/>
- <entity name="Union" value="⋃"/>
- <entity name="UnionPlus" value="⊎"/>
- <entity name="uogon" value="ų"/>
- <entity name="Uogon" value="Ų"/>
- <entity name="uopf" value="𝕦"/>
- <entity name="Uopf" value="𝕌"/>
- <entity name="uparrow" value="↑"/>
- <entity name="Uparrow" value="⇑"/>
- <entity name="UpArrow" value="↑"/>
- <entity name="UpArrowBar" value="⤒"/>
- <entity name="UpArrowDownArrow" value="⇅"/>
- <entity name="updownarrow" value="↕"/>
- <entity name="Updownarrow" value="⇕"/>
- <entity name="UpDownArrow" value="↕"/>
- <entity name="UpEquilibrium" value="⥮"/>
- <entity name="upharpoonleft" value="↿"/>
- <entity name="upharpoonright" value="↾"/>
- <entity name="uplus" value="⊎"/>
- <entity name="UpperLeftArrow" value="↖"/>
- <entity name="UpperRightArrow" value="↗"/>
- <entity name="upsi" value="υ"/>
- <entity name="Upsi" value="ϒ"/>
- <entity name="upsilon" value="υ"/>
- <entity name="Upsilon" value="ϒ"/>
- <entity name="UpTee" value="⊥"/>
- <entity name="UpTeeArrow" value="↥"/>
- <entity name="upuparrows" value="⇈"/>
- <entity name="urcorn" value="⌝"/>
- <entity name="urcorner" value="⌝"/>
- <entity name="urcrop" value="⌎"/>
- <entity name="uring" value="ů"/>
- <entity name="Uring" value="Ů"/>
- <entity name="urtri" value="◹"/>
- <entity name="uscr" value="𝓊"/>
- <entity name="Uscr" value="𝒰"/>
- <entity name="utdot" value="⋰"/>
- <entity name="utilde" value="ũ"/>
- <entity name="Utilde" value="Ũ"/>
- <entity name="utri" value="▵"/>
- <entity name="utrif" value="▴"/>
- <entity name="uuarr" value="⇈"/>
- <entity name="uuml" value="ü"/>
- <entity name="Uuml" value="Ü"/>
- <entity name="uwangle" value="⦧"/>
- <entity name="vangrt" value="⊾"/>
- <entity name="varepsilon" value="ɛ"/>
- <entity name="varkappa" value="ϰ"/>
- <entity name="varnothing" value="∅"/>
- <entity name="varphi" value="ϕ"/>
- <entity name="varpi" value="ϖ"/>
- <entity name="varpropto" value="∝"/>
- <entity name="varr" value="↕"/>
- <entity name="vArr" value="⇕"/>
- <entity name="varrho" value="ϱ"/>
- <entity name="varsigma" value="ς"/>
- <entity name="varsubsetneq" value="⊊︀"/>
- <entity name="varsubsetneqq" value="⊊︀"/>
- <entity name="varsupsetneq" value="⊋︀"/>
- <entity name="varsupsetneqq" value="⊋︀"/>
- <entity name="vartheta" value="ϑ"/>
- <entity name="vartriangleleft" value="⊲"/>
- <entity name="vartriangleright" value="⊳"/>
- <entity name="vBar" value="⫨"/>
- <entity name="Vbar" value="⫫"/>
- <entity name="vBarv" value="⫩"/>
- <entity name="vcy" value="в"/>
- <entity name="Vcy" value="В"/>
- <entity name="vdash" value="⊢"/>
- <entity name="vDash" value="⊨"/>
- <entity name="Vdash" value="⊩"/>
- <entity name="VDash" value="⊫"/>
- <entity name="Vdashl" value="⫦"/>
- <entity name="vee" value="∨"/>
- <entity name="Vee" value="⋁"/>
- <entity name="veebar" value="⊻"/>
- <entity name="veeeq" value="≚"/>
- <entity name="vellip" value="⋮"/>
- <entity name="verbar" value="|"/>
- <entity name="Verbar" value="‖"/>
- <entity name="vert" value="|"/>
- <entity name="Vert" value="‖"/>
- <entity name="VerticalBar" value="∣"/>
- <entity name="VerticalLine" value="|"/>
- <entity name="VerticalSeparator" value="❘"/>
- <entity name="VerticalTilde" value="≀"/>
- <entity name="VeryThinSpace" value=" "/>
- <entity name="vfr" value="𝔳"/>
- <entity name="Vfr" value="𝔙"/>
- <entity name="vltri" value="⊲"/>
- <entity name="vnsub" value="⊄"/>
- <entity name="vnsup" value="⊅"/>
- <entity name="vopf" value="𝕧"/>
- <entity name="Vopf" value="𝕍"/>
- <entity name="vprop" value="∝"/>
- <entity name="vrtri" value="⊳"/>
- <entity name="vscr" value="𝓋"/>
- <entity name="Vscr" value="𝒱"/>
- <entity name="vsubne" value="⊊︀"/>
- <entity name="vsubnE" value="⊊︀"/>
- <entity name="vsupne" value="⊋︀"/>
- <entity name="vsupnE" value="⊋︀"/>
- <entity name="Vvdash" value="⊪"/>
- <entity name="vzigzag" value="⦚"/>
- <entity name="wcirc" value="ŵ"/>
- <entity name="Wcirc" value="Ŵ"/>
- <entity name="wedbar" value="⩟"/>
- <entity name="wedge" value="∧"/>
- <entity name="Wedge" value="⋀"/>
- <entity name="wedgeq" value="≙"/>
- <entity name="weierp" value="℘"/>
- <entity name="wfr" value="𝔴"/>
- <entity name="Wfr" value="𝔚"/>
- <entity name="wopf" value="𝕨"/>
- <entity name="Wopf" value="𝕎"/>
- <entity name="wp" value="℘"/>
- <entity name="wr" value="≀"/>
- <entity name="wreath" value="≀"/>
- <entity name="wscr" value="𝓌"/>
- <entity name="Wscr" value="𝒲"/>
- <entity name="xcap" value="⋂"/>
- <entity name="xcirc" value="◯"/>
- <entity name="xcup" value="⋃"/>
- <entity name="xdtri" value="▽"/>
- <entity name="xfr" value="𝔵"/>
- <entity name="Xfr" value="𝔛"/>
- <entity name="xharr" value=""/>
- <entity name="xhArr" value=""/>
- <entity name="xi" value="ξ"/>
- <entity name="Xi" value="Ξ"/>
- <entity name="xlarr" value=""/>
- <entity name="xlArr" value=""/>
- <entity name="xmap" value=""/>
- <entity name="xnis" value="⋻"/>
- <entity name="xodot" value="⊙"/>
- <entity name="xopf" value="𝕩"/>
- <entity name="Xopf" value="𝕏"/>
- <entity name="xoplus" value="⊕"/>
- <entity name="xotime" value="⊗"/>
- <entity name="xrarr" value=""/>
- <entity name="xrArr" value=""/>
- <entity name="xscr" value="𝓍"/>
- <entity name="Xscr" value="𝒳"/>
- <entity name="xsqcup" value="⊔"/>
- <entity name="xuplus" value="⊎"/>
- <entity name="xutri" value="△"/>
- <entity name="xvee" value="⋁"/>
- <entity name="xwedge" value="⋀"/>
- <entity name="yacute" value="ý"/>
- <entity name="Yacute" value="Ý"/>
- <entity name="yacy" value="я"/>
- <entity name="YAcy" value="Я"/>
- <entity name="ycirc" value="ŷ"/>
- <entity name="Ycirc" value="Ŷ"/>
- <entity name="ycy" value="ы"/>
- <entity name="Ycy" value="Ы"/>
- <entity name="yen" value="¥"/>
- <entity name="yfr" value="𝔶"/>
- <entity name="Yfr" value="𝔜"/>
- <entity name="yicy" value="ї"/>
- <entity name="YIcy" value="Ї"/>
- <entity name="yopf" value="𝕪"/>
- <entity name="Yopf" value="𝕐"/>
- <entity name="yscr" value="𝓎"/>
- <entity name="Yscr" value="𝒴"/>
- <entity name="yucy" value="ю"/>
- <entity name="YUcy" value="Ю"/>
- <entity name="yuml" value="ÿ"/>
- <entity name="Yuml" value="Ÿ"/>
- <entity name="zacute" value="ź"/>
- <entity name="Zacute" value="Ź"/>
- <entity name="zcaron" value="ž"/>
- <entity name="Zcaron" value="Ž"/>
- <entity name="zcy" value="з"/>
- <entity name="Zcy" value="З"/>
- <entity name="zdot" value="ż"/>
- <entity name="Zdot" value="Ż"/>
- <entity name="zeetrf" value="ℨ"/>
- <entity name="ZeroWidthSpace" value="​"/>
- <entity name="zeta" value="ζ"/>
- <entity name="zfr" value="𝔷"/>
- <entity name="Zfr" value="ℨ"/>
- <entity name="zhcy" value="ж"/>
- <entity name="ZHcy" value="Ж"/>
- <entity name="zigrarr" value="⇝"/>
- <entity name="zopf" value="𝕫"/>
- <entity name="Zopf" value="ℤ"/>
- <entity name="zscr" value="𝓏"/>
- <entity name="Zscr" value="𝒵"/>
-</entities-table>
+++ /dev/null
-<?xml version="1.0"?>
-
-<entities-table>
- <entity name="def" value="≝"/> <!-- ≝ -->
- <entity name="neq" value="≠"/> <!-- ≠ -->
- <entity name="leq" value="≤"/> <!-- ≤ -->
- <entity name="geq" value="≥"/> <!-- ≥ -->
- <entity name="nleq" value="≰"/> <!-- ≰ -->
- <entity name="ngeq" value="≱"/> <!-- ≱ -->
- <entity name="to" value="→"/> <!-- → -->
- <entity name="divides" value="∣"/> <!-- ∣ -->
- <entity name="ndivides" value="∤"/> <!-- ∤ -->
- <entity name="circ" value="∘"/> <!-- ∤ -->
-</entities-table>
-
-<!-- vim: set encoding=utf8: -->
+++ /dev/null
-(* 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 ()
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* $Id$ *)
-
-prerr_endline <:unicode<lambda>>
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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"
+++ /dev/null
-whelp.cmo: whelp.cmi
-whelp.cmx: whelp.cmi
-fwdQueries.cmo: fwdQueries.cmi
-fwdQueries.cmx: fwdQueries.cmi
+++ /dev/null
-PACKAGE = whelp
-
-INTERFACE_FILES = \
- whelp.mli \
- fwdQueries.mli \
- $(NULL)
-
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-xml.cmo: xml.cmi
-xml.cmx: xml.cmi
-xmlPushParser.cmo: xmlPushParser.cmi
-xmlPushParser.cmx: xmlPushParser.cmi
+++ /dev/null
-PACKAGE = xml
-PREDICATES =
-
-INTERFACE_FILES = \
- xml.mli \
- xmlPushParser.mli
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-EXTRA_OBJECTS_TO_INSTALL =
-EXTRA_OBJECTS_TO_CLEAN =
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* $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*)
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* 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
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 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))
-
+++ /dev/null
-(* Copyright (C) 2004-2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 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
-
+++ /dev/null
-xmlDiff.cmo: xmlDiff.cmi
-xmlDiff.cmx: xmlDiff.cmi
+++ /dev/null
-PACKAGE = xmldiff
-PREDICATES =
-
-INTERFACE_FILES = xmlDiff.mli
-IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
-EXTRA_OBJECTS_TO_INSTALL =
-EXTRA_OBJECTS_TO_CLEAN =
-
-include ../../Makefile.defs
-include ../Makefile.common
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* $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
-;;
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val 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
--- /dev/null
+requires="helm-cic_acic"
+version="0.0.1"
+archive(byte)="acic_content.cma"
+archive(native)="acic_content.cmxa"
--- /dev/null
+requires="helm-urimanager helm-xml expat"
+version="0.0.1"
+archive(byte)="cic.cma"
+archive(native)="cic.cmxa"
+linkopts=""
--- /dev/null
+requires="helm-cic_proof_checking"
+version="0.0.1"
+archive(byte)="cic_acic.cma"
+archive(native)="cic_acic.cmxa"
--- /dev/null
+requires="helm-whelp helm-acic_content helm-cic_unification"
+version="0.0.1"
+archive(byte)="cic_disambiguation.cma"
+archive(native)="cic_disambiguation.cmxa"
--- /dev/null
+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=""
--- /dev/null
+requires="helm-cic_proof_checking helm-library"
+version="0.0.1"
+archive(byte)="cic_unification.cma"
+archive(native)="cic_unification.cmxa"
+linkopts=""
--- /dev/null
+requires="helm-acic_content helm-utf8_macros camlp4.gramlib ulex"
+version="0.0.1"
+archive(byte)="content_pres.cma"
+archive(native)="content_pres.cmxa"
--- /dev/null
+requires="unix camlp4.gramlib"
+version="0.0.1"
+archive(byte)="extlib.cma"
+archive(native)="extlib.cmxa"
+linkopts=""
--- /dev/null
+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=""
--- /dev/null
+requires="helm-cic"
+version="0.0.1"
+archive(byte)="grafite.cma"
+archive(native)="grafite.cmxa"
--- /dev/null
+requires="helm-library helm-grafite helm-tactics"
+version="0.0.1"
+archive(byte)="grafite_engine.cma"
+archive(native)="grafite_engine.cmxa"
+linkopts=""
--- /dev/null
+requires="helm-lexicon helm-grafite ulex"
+version="0.0.1"
+archive(byte)="grafite_parser.cma"
+archive(native)="grafite_parser.cmxa"
+linkopts=""
--- /dev/null
+requires="helm-xml gdome2"
+version="0.0.1"
+archive(byte)="hgdome.cma"
+archive(native)="hgdome.cmxa"
--- /dev/null
+requires="helm-registry mysql helm-extlib"
+version="0.0.1"
+archive(byte)="hmysql.cma"
+archive(native)="hmysql.cmxa"
--- /dev/null
+requires="helm-content_pres helm-cic_disambiguation camlp4.gramlib"
+version="0.0.1"
+archive(byte)="lexicon.cma"
+archive(native)="lexicon.cmxa"
--- /dev/null
+requires="helm-cic_acic helm-metadata"
+version="0.0.1"
+archive(byte)="library.cma"
+archive(native)="library.cmxa"
+linkopts=""
--- /dev/null
+requires=""
+version="0.0.1"
+archive(byte)="logger.cma"
+archive(native)="logger.cmxa"
+linkopts=""
--- /dev/null
+requires="helm-hmysql helm-cic_proof_checking"
+version="0.0.1"
+archive(byte)="metadata.cma"
+archive(native)="metadata.cmxa"
--- /dev/null
+requires="str netstring helm-xml"
+version="0.0.1"
+archive(byte)="registry.cma"
+archive(native)="registry.cmxa"
--- /dev/null
+requires="helm-cic_proof_checking helm-cic_unification helm-whelp"
+version="0.0.1"
+archive(byte)="tactics.cma"
+archive(native)="tactics.cmxa"
--- /dev/null
+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=""
--- /dev/null
+requires="str"
+version="0.0.1"
+archive(byte)="urimanager.cma"
+archive(native)="urimanager.cmxa"
+linkopts=""
--- /dev/null
+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=""
--- /dev/null
+requires="helm-metadata"
+version="0.0.1"
+archive(byte)="whelp.cma"
+archive(native)="whelp.cmxa"
--- /dev/null
+requires="zip expat helm-extlib"
+version="0.0.1"
+archive(byte)="xml.cma"
+archive(native)="xml.cmxa"
+linkopts=""
--- /dev/null
+requires="gdome2"
+version="0.0.1"
+archive(byte)="xmldiff.cma"
+archive(native)="xmldiff.cmxa"
--- /dev/null
+
+export SHELL=/bin/bash
+
+include ../Makefile.defs
+
+# Warning: the modules must be in compilation order
+NULL =
+MODULES = \
+ extlib \
+ xml \
+ hgdome \
+ registry \
+ hmysql \
+ utf8_macros \
+ thread \
+ xmldiff \
+ urimanager \
+ logger \
+ getter \
+ cic \
+ cic_proof_checking \
+ cic_acic \
+ acic_content \
+ content_pres \
+ grafite \
+ metadata \
+ library \
+ cic_unification \
+ whelp \
+ tactics \
+ cic_disambiguation \
+ lexicon \
+ grafite_engine \
+ grafite_parser \
+ tactics/paramodulation \
+ $(NULL)
+
+METAS = $(filter-out %/paramodulation,$(MODULES:%=METAS/META.helm-%))
+
+all: metas $(MODULES:%=%.all)
+opt: metas $(MODULES:%=%.opt)
+world: all opt
+depend: $(MODULES:%=%.depend)
+install: $(MODULES:%=%.install)
+uninstall: $(MODULES:%=%.uninstall)
+clean: $(MODULES:%=%.clean) clean_metas
+
+.stats: $(MODULES:%=%.stats)
+ (for m in $(MODULES); do echo -n "$$m:"; cat $$m/.stats; done) \
+ | sort -t : -k 2 -n -r > .stats
+
+EXTRA_DIST_CLEAN = \
+ libraries-clusters.ps \
+ libraries-clusters.pdf \
+ libraries-ext.ps \
+ libraries.ps \
+ .dep.dot \
+ .extdep.dot \
+ .clustersdep.dot \
+ $(NULL)
+
+distclean: clean clean_metas
+ rm -f $(METAS)
+ rm -f configure config.log config.cache config.status
+ rm -f $(EXTRA_DIST_CLEAN)
+
+.PHONY: all opt world metas depend install uninstall clean clean_metas distclean
+
+%.all:
+ $(MAKE) -C $* all
+%.opt:
+ $(MAKE) -C $* opt
+%.clean:
+ $(MAKE) -C $* clean
+%.depend:
+ $(MAKE) -C $* depend
+%.stats:
+ @$(MAKE) -C $* .stats
+%.install:
+ $(MAKE) -C $* install
+%.uninstall:
+ $(MAKE) -C $* uninstall
+
+METAS/META.helm-%: METAS/meta.helm-%.src
+ cp $< $@ && echo "directory=\"$(shell pwd)/$*\"" >> $@
+
+.PHONY: .dep.dot
+.dep.dot:
+ echo "digraph G {" > $@
+ echo " rankdir = TB ;" >> $@
+ for i in $(MODULES); do $(OCAMLFIND) query helm-$$i -recursive -p-format | grep helm | sed "s/^helm-/ \"$$i\" -> \"/g" | sed "s/$$/\";/g" >> $@ ; done
+ mv $@ $@.old ; ./simplify_deps/simplify_deps.opt < $@.old > $@ ; rm $@.old
+ echo "}" >> $@
+
+.PHONY: .alldep.dot
+.alldep.dot:
+ echo "digraph G {" > $@
+ echo " rankdir = TB ;" >> $@
+ for i in $(MODULES); do $(OCAMLFIND) query helm-$$i -recursive -p-format | grep -v "pxp-" | sed "s/^pxp/pxp[-*]/g" | sed "s/^/ \"helm-$$i\" -> \"/g" | sed "s/$$/\";/g" >> $@ ; done
+ mv $@ $@.old ; ./simplify_deps/simplify_deps.opt < $@.old > $@ ; rm $@.old
+ for i in $(MODULES); do echo "\"helm-$$i\" [shape=box,style=filled,fillcolor=yellow];" >> $@ ; done
+ echo "}" >> $@
+
+.extdep.dot: .dep.dot
+ STATS/patch_deps.sh $< $@
+.clustersdep.dot: .dep.dot
+ USE_CLUSTERS=yes STATS/patch_deps.sh $< $@
+
+libraries.ps: .dep.dot
+ dot -Tps -o $@ $<
+libraries-ext.ps: .extdep.dot
+ dot -Tps -o $@ $<
+libraries-clusters.ps: .clustersdep.dot
+ dot -Tps -o $@ $<
+libraries-complete.ps: .alldep.dot
+ dot -Tps -o $@ $<
+
+ps: libraries.ps libraries-ext.ps libraries-clusters.ps
+
+tags: TAGS
+.PHONY: TAGS
+TAGS:
+ otags -vi -r .
+
--- /dev/null
+H=@
+
+# This Makefile must be included by another one defining:
+# $PACKAGE
+# $PREDICATES
+# $INTERFACE_FILES
+# $IMPLEMENTATION_FILES
+# $EXTRA_OBJECTS_TO_INSTALL
+# $EXTRA_OBJECTS_TO_CLEAN
+# and put in a directory where there is a .depend file.
+
+# $OCAMLFIND must be set to a meaningful vaule, including OCAMLPATH=
+
+PREPROCOPTIONS = -pp camlp4o
+SYNTAXOPTIONS = -syntax camlp4o
+PREREQ =
+OCAMLOPTIONS = -package "$(REQUIRES)" -predicates "$(PREDICATES)" -thread
+OCAMLDEBUGOPTIONS = -g
+OCAMLARCHIVEOPTIONS =
+REQUIRES := $(shell $(OCAMLFIND) -query -format '%(requires)' helm-$(PACKAGE))
+OCAMLC = $(OCAMLFIND) ocamlc $(OCAMLDEBUGOPTIONS) $(OCAMLOPTIONS) $(PREPROCOPTIONS)
+OCAMLOPT = $(OCAMLFIND) opt $(OCAMLOPTIONS) $(PREPROCOPTIONS)
+OCAMLDEP = $(OCAMLFIND) ocamldep -package "camlp4 $(CAMLP4REQUIRES)" $(SYNTAXOPTIONS) $(OCAMLDEPOPTIONS)
+OCAMLLEX = ocamllex
+OCAMLYACC = ocamlyacc
+
+OCAMLC_P4 = $(OCAMLFIND) ocamlc $(OCAMLDEBUGOPTIONS) $(OCAMLOPTIONS) $(SYNTAXOPTIONS)
+OCAMLOPT_P4 = $(OCAMLFIND) opt $(OCAMLOPTIONS) $(SYNTAXOPTIONS)
+
+LIBRARIES = $(shell $(OCAMLFIND) query -recursive -predicates "byte $(PREDICATES)" -format "%d/%a" $(REQUIRES))
+LIBRARIES_OPT = $(shell $(OCAMLFIND) query -recursive -predicates "native $(PREDICATES)" -format "%d/%a" $(REQUIRES))
+LIBRARIES_DEPS := \
+ $(foreach X,$(filter-out /usr/lib/ocaml%,$(LIBRARIES)),\
+ $(wildcard \
+ $(shell dirname $(X))/*.mli \
+ $(shell dirname $(X))/*.ml \
+ $(shell dirname $(X))/paramodulation/*.ml \
+ $(shell dirname $(X))/paramodultation/*.mli))
+
+
+ARCHIVE = $(PACKAGE).cma
+ARCHIVE_OPT = $(PACKAGE).cmxa
+OBJECTS_TO_INSTALL = $(ARCHIVE) $(ARCHIVE_OPT) $(ARCHIVE_OPT:%.cmxa=%.a) \
+ $(INTERFACE_FILES) $(INTERFACE_FILES:%.mli=%.cmi) \
+ $(EXTRA_OBJECTS_TO_INSTALL)
+DEPEND_FILES = $(INTERFACE_FILES) $(IMPLEMENTATION_FILES)
+
+$(ARCHIVE): $(IMPLEMENTATION_FILES:%.ml=%.cmo) $(LIBRARIES)
+ $(H)if [ $(PACKAGE) != dummy ]; then \
+ echo " OCAMLC -a $@";\
+ $(OCAMLC) $(OCAMLARCHIVEOPTIONS) -a -o $@ \
+ $(IMPLEMENTATION_FILES:%.ml=%.cmo); fi
+
+$(ARCHIVE_OPT): $(IMPLEMENTATION_FILES:%.ml=%.cmx) $(LIBRARIES_OPT)
+ $(H)if [ $(PACKAGE) != dummy ]; then \
+ echo " OCAMLOPT -a $@";\
+ $(OCAMLOPT) $(OCAMLARCHIVEOPTIONS) -a -o $@ \
+ $(IMPLEMENTATION_FILES:%.ml=%.cmx); fi
+
+prereq: $(PREREQ)
+all: prereq $(IMPLEMENTATION_FILES:%.ml=%.cmo) $(ARCHIVE)
+ @echo -n
+opt: prereq $(IMPLEMENTATION_FILES:%.ml=%.cmx) $(ARCHIVE_OPT)
+ @echo -n
+world: all opt
+test: test.ml $(ARCHIVE)
+ $(OCAMLC) $(ARCHIVE) -linkpkg -o $@ $<
+test.opt: test.ml $(ARCHIVE_OPT)
+ $(OCAMLOPT) $(ARCHIVE_OPT) -linkpkg -o $@ $<
+install:
+uninstall:
+
+depend: $(DEPEND_FILES)
+ $(OCAMLDEP) $(INTERFACE_FILES) $(IMPLEMENTATION_FILES) > .depend
+
+$(PACKAGE).ps: .dep.dot
+ dot -Tps -o $@ $<
+
+.dep.dot: .depend
+ ocamldot < .depend > $@
+
+%.cmi: %.mli
+ @echo " OCAMLC $<"
+ $(H)$(OCAMLC) -c $<
+%.cmo %.cmi: %.ml
+ @echo " OCAMLC $<"
+ $(H)$(OCAMLC) -c $<
+%.cmx: %.ml
+ @echo " OCAMLOPT $<"
+ $(H)$(OCAMLOPT) -c $<
+%.annot: %.ml
+ $(OCAMLC) -dtypes $(PKGS) -c $<
+%.ml %.mli: %.mly
+ $(OCAMLYACC) $<
+%.ml: %.mll
+ $(OCAMLLEX) $<
+
+ifneq ($(MAKECMDGOALS), clean)
+$(IMPLEMENTATION_FILES:%.ml=%.cmo): $(LIBRARIES)
+$(IMPLEMENTATION_FILES:%.ml=%.cmi): $(LIBRARIES_DEPS)
+$(IMPLEMENTATION_FILES:%.ml=%.cmx): $(LIBRARIES_OPT)
+endif
+
+clean:
+ rm -f *.cm[ioax] *.cmxa *.o *.a *.annot $(EXTRA_OBJECTS_TO_CLEAN)
+ if [ -f test ]; then rm -f test; else true; fi
+ if [ -f test.opt ]; then rm -f test.opt; else true; fi
+
+backup:
+ cd ..; tar cvzf $(PACKAGE)_$(shell date +%s).tar.gz $(PACKAGE)
+
+ocamlinit:
+ echo "#use \"topfind\";;" > .ocamlinit
+ echo "#thread;;" >> .ocamlinit
+ for p in $(REQUIRES); do echo "#require \"$$p\";;" >> .ocamlinit; done
+ echo "#load \"$(PACKAGE).cma\";;" >> .ocamlinit
+
+# $(STATS_EXCLUDE) may be defined in libraries' Makefile to exclude some file
+# from statistics collection
+STATS_FILES = \
+ $(shell find . -maxdepth 1 -type f -name \*.ml $(foreach f,$(STATS_EXCLUDE),-not -name $(f))) \
+ $(shell find . -maxdepth 1 -type f -name \*.mli $(foreach f,$(STATS_EXCLUDE),-not -name $(f)))
+.stats: $(STATS_FILES)
+ rm -f .stats
+ echo -n "LOC:" >> .stats
+ wc -l $(STATS_FILES) | tail -1 | awk '{ print $$1 }' >> .stats
+
+.PHONY: all opt world backup depend install uninstall clean ocamlinit
+
+ifneq ($(MAKECMDGOALS), depend)
+ include .depend
+endif
+
+NULL =
+
--- /dev/null
+// clusterrank = none;
+ fillcolor = "gray93";
+ fontsize = 24;
+ node [fontsize = 24];
+ /* libs clusters */
+ subgraph cluster_presentation {
+ label = "Terms at the content and presentation level";
+ labelloc = "b";
+ labeljust = "r";
+ style = "filled";
+ color = "white"
+ acic_content;
+ cic_disambiguation;
+ content_pres;
+ grafite_parser;
+ lexicon;
+ }
+ subgraph cluster_partially {
+ label = "Partially specified terms";
+ labelloc = "t";
+ labeljust = "l";
+ style = "filled";
+ color = "white"
+ cic_unification;
+ tactics;
+ grafite;
+ grafite_engine;
+ }
+ subgraph cluster_fully {
+ label = "Fully specified terms";
+ labelloc = "b";
+ labeljust = "l";
+ style = "filled";
+ color = "white"
+ cic;
+ cic_proof_checking;
+ getter;
+ metadata;
+ urimanager;
+ whelp;
+ library;
+ cic_acic;
+ }
+ subgraph cluster_utilities {
+ label = "Utilities";
+ labelloc = "b";
+ labeljust = "r";
+ style = "filled";
+ color = "white"
+ extlib;
+ hgdome;
+ hmysql;
+ registry;
+ utf8_macros;
+ xml;
+ logger;
+ }
--- /dev/null
+ /* apps */
+ subgraph applications {
+ node [shape=plaintext,style=filled,fillcolor=slategray2];
+ DependencyAnalyzer [label="Dependency\nAnalyzer\n .3 klocs"];
+ Getter [label="Getter\n .3 klocs"];
+ Matita [label="Matita\n 6.7 klocs"];
+ ProofChecker [label="Proof Checker\n .1 klocs"];
+ Uwobo [label="Uwobo\n 2.1 klocs"];
+ Whelp [label="Whelp\n .6 klocs"];
+ }
+ /* apps dep */
+ DependencyAnalyzer -> metadata;
+ Getter -> getter;
+ Matita -> grafite_engine;
+ Matita -> grafite_parser;
+ Matita -> hgdome;
+ ProofChecker -> cic_proof_checking;
+ Uwobo -> content_pres;
+ Whelp -> grafite_parser;
--- /dev/null
+--- .clustersdep.dot 2006-01-26 10:10:46.000000000 +0100
++++ .clustersdep.new 2006-01-26 10:10:44.000000000 +0100
+@@ -1,11 +1,8 @@
+ digraph G {
+ xml [label="xml\n.5 klocs"];
+- xmldiff [label="xmldiff\n.3 klocs"];
+ whelp [label="whelp\n.3 klocs"];
+ utf8_macros [label="utf8_macros\n.2 klocs"];
+ urimanager [label="urimanager\n.2 klocs"];
+- thread [label="thread\n.2 klocs"];
+- paramodulation [label="paramodulation\n5.9 klocs"];
+ tactics [label="tactics\n10.0 klocs"];
+ registry [label="registry\n.6 klocs"];
+ metadata [label="metadata\n1.9 klocs"];
+@@ -42,7 +39,7 @@
+ "cic_unification" -> "library";
+ "library" -> "metadata";
+ "library" -> "cic_acic";
+-"metadata" -> "cic_proof_checking";
++"metadata" -> "cic";
+ "metadata" -> "hmysql";
+ "grafite" -> "cic";
+ "content_pres" -> "utf8_macros";
--- /dev/null
+#!/bin/sh
+# script args: source_file target_file
+
+use_clusters='no'
+if [ ! -z "$USE_CLUSTERS" ]; then
+ use_clusters=$USE_CLUSTERS
+fi
+
+# args: file snippet
+# file will be modified in place
+include_dot_snippet ()
+{
+ echo "Adding to $1 graphviz snippet $2 ..."
+ sed -i "/digraph/r $2" $1
+}
+
+# args: stats file
+# file will be modified in place
+include_loc_stats ()
+{
+ echo "Adding to $1 KLOCs stats from $2 ..."
+ tmp=`mktemp tmp.stats.XXXXXX`
+ for l in `cat $2`; do
+ module=$(basename $(echo $l | cut -d : -f 1))
+ stat=$(echo $l | cut -d : -f 2)
+ if [ "$stat" = "LOC" ]; then
+ locs=$(echo $l | cut -d : -f 3)
+ klocs=$(echo "scale=1; $locs / 1000" | bc)
+ if [ "$klocs" = "0" ]; then klocs=".1"; fi
+ printf ' %s [label="%s\\n%s klocs"];\n' $module $module $klocs >> $tmp
+ fi
+ done
+ include_dot_snippet $1 $tmp
+ rm $tmp
+}
+
+# args: file patch
+apply_patch ()
+{
+ if [ -f "$2" ]; then
+ echo "Applying to $1 patch $2 ..."
+ patch $1 $2
+ fi
+}
+
+cp $1 $2
+include_loc_stats $2 .stats
+apply_patch $2 STATS/deps.patch
+include_dot_snippet $2 STATS/daemons.dot
+if [ "$use_clusters" = "yes" ]; then
+ include_dot_snippet $2 STATS/clusters.dot
+fi
+
--- /dev/null
+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
--- /dev/null
+PACKAGE = acic_content
+PREDICATES =
+
+INTERFACE_FILES = \
+ content.mli \
+ contentPp.mli \
+ acic2content.mli \
+ content2cic.mli \
+ cicNotationUtil.mli \
+ cicNotationEnv.mli \
+ cicNotationPp.mli \
+ acic2astMatcher.mli \
+ termAcicContent.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = \
+ cicNotationPt.ml \
+ $(INTERFACE_FILES:%.mli=%.ml)
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(**************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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 context,term =
+ (match
+ build_subproofs_and_args
+ seed ~ids_to_inner_types ~ids_to_inner_sorts [te]
+ with
+ l,[t] -> l,t
+ | _ -> assert false) in
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [];
+ K.proof_apply_context = serialize seed context;
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "Case";
+ K.conclude_args =
+ (K.Aux (UriManager.string_of_uri uri))::
+ (K.Aux (string_of_int typeno))::(K.Term ty)::term::pp;
+ K.conclude_conclusion =
+ try Some
+ (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found -> None
+ }
+ }
+ | C.AFix (id, no, funs) ->
+ let proofs =
+ List.map
+ (function (_,name,_,_,bo) -> `Proof (aux ~name bo)) funs in
+ let fun_name =
+ List.nth (List.map (fun (_,name,_,_,_) -> name) funs) no
+ in
+ let decreasing_args =
+ List.map (function (_,_,n,_,_) -> n) funs in
+ let jo =
+ { K.joint_id = gen_id joint_prefix seed;
+ K.joint_kind = `Recursive decreasing_args;
+ K.joint_defs = proofs
+ }
+ in
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [`Joint jo];
+ K.proof_apply_context = [];
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "Exact";
+ K.conclude_args =
+ [ K.Premise
+ { K.premise_id = gen_id premise_prefix seed;
+ K.premise_xref = jo.K.joint_id;
+ K.premise_binder = Some fun_name;
+ K.premise_n = Some no;
+ }
+ ];
+ K.conclude_conclusion =
+ try Some
+ (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found -> None
+ }
+ }
+ | C.ACoFix (id,no,funs) ->
+ let proofs =
+ List.map
+ (function (_,name,_,bo) -> `Proof (aux ~name bo)) funs in
+ let jo =
+ { K.joint_id = gen_id joint_prefix seed;
+ K.joint_kind = `CoRecursive;
+ K.joint_defs = proofs
+ }
+ in
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [`Joint jo];
+ K.proof_apply_context = [];
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "Exact";
+ K.conclude_args =
+ [ K.Premise
+ { K.premise_id = gen_id premise_prefix seed;
+ K.premise_xref = jo.K.joint_id;
+ K.premise_binder = Some "tiralo fuori";
+ K.premise_n = Some no;
+ }
+ ];
+ K.conclude_conclusion =
+ try Some
+ (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found -> None
+ };
+ }
+ in
+ let id = get_id t in
+ generate_conversion seed false id t1 ~ids_to_inner_types
+in aux ?name t
+
+and inductive seed name id li ~ids_to_inner_types ~ids_to_inner_sorts =
+ let aux ?name = acic2content seed ~ids_to_inner_types ~ids_to_inner_sorts in
+ let module C2A = Cic2acic in
+ let module K = Content in
+ let module C = Cic in
+ match li with
+ C.AConst (idc,uri,exp_named_subst)::args ->
+ let uri_str = UriManager.string_of_uri uri in
+ let suffix = Str.regexp_string "_ind.con" in
+ let len = String.length uri_str in
+ let n = (try (Str.search_backward suffix uri_str len)
+ with Not_found -> -1) in
+ if n<0 then raise NotApplicable
+ else
+ let method_name =
+ if UriManager.eq uri HelmLibraryObjects.Logic.ex_ind_URI then "Exists"
+ else if UriManager.eq uri HelmLibraryObjects.Logic.and_ind_URI then "AndInd"
+ else if UriManager.eq uri HelmLibraryObjects.Logic.false_ind_URI then "FalseInd"
+ else "ByInduction" in
+ let prefix = String.sub uri_str 0 n in
+ let ind_str = (prefix ^ ".ind") in
+ let ind_uri = UriManager.uri_of_string ind_str in
+ let inductive_types,noparams =
+ (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph ind_uri in
+ match o with
+ | Cic.InductiveDefinition (l,_,n,_) -> (l,n)
+ | _ -> assert false
+ ) in
+ let rec split n l =
+ if n = 0 then ([],l) else
+ let p,a = split (n-1) (List.tl l) in
+ ((List.hd l::p),a) in
+ let params_and_IP,tail_args = split (noparams+1) args in
+ let constructors =
+ (match inductive_types with
+ [(_,_,_,l)] -> l
+ | _ -> raise NotApplicable) (* don't care for mutual ind *) in
+ let constructors1 =
+ let rec clean_up n t =
+ if n = 0 then t else
+ (match t with
+ (label,Cic.Prod (_,_,t)) -> clean_up (n-1) (label,t)
+ | _ -> assert false) in
+ List.map (clean_up noparams) constructors in
+ let no_constructors= List.length constructors in
+ let args_for_cases, other_args =
+ split no_constructors tail_args in
+ let subproofs,other_method_args =
+ build_subproofs_and_args seed other_args
+ ~ids_to_inner_types ~ids_to_inner_sorts in
+ let method_args=
+ let rec build_method_args =
+ function
+ [],_-> [] (* extra args are ignored ???? *)
+ | (name,ty)::tlc,arg::tla ->
+ let idarg = get_id arg in
+ let sortarg =
+ (try (Hashtbl.find ids_to_inner_sorts idarg)
+ with Not_found -> `Type (CicUniv.fresh())) in
+ let hdarg =
+ if sortarg = `Prop then
+ let (co,bo) =
+ let rec bc =
+ function
+ Cic.Prod (_,s,t),Cic.ALambda(idl,n,s1,t1) ->
+ let ce =
+ build_decl_item
+ seed idl n s1 ~ids_to_inner_sorts in
+ if (occur ind_uri s) then
+ ( match t1 with
+ Cic.ALambda(id2,n2,s2,t2) ->
+ let inductive_hyp =
+ `Hypothesis
+ { K.dec_name = name_of n2;
+ K.dec_id =
+ gen_id declaration_prefix seed;
+ K.dec_inductive = true;
+ K.dec_aref = id2;
+ K.dec_type = s2
+ } in
+ let (context,body) = bc (t,t2) in
+ (ce::inductive_hyp::context,body)
+ | _ -> assert false)
+ else
+ (
+ let (context,body) = bc (t,t1) in
+ (ce::context,body))
+ | _ , t -> ([],aux t) in
+ bc (ty,arg) in
+ K.ArgProof
+ { bo with
+ K.proof_name = Some name;
+ K.proof_context = co;
+ };
+ else (K.Term arg) in
+ hdarg::(build_method_args (tlc,tla))
+ | _ -> assert false in
+ build_method_args (constructors1,args_for_cases) in
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [];
+ K.proof_apply_context = serialize seed subproofs;
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = method_name;
+ K.conclude_args =
+ K.Aux (string_of_int no_constructors)
+ ::K.Term (C.AAppl(id,((C.AConst(idc,uri,exp_named_subst))::params_and_IP)))
+ ::method_args@other_method_args;
+ K.conclude_conclusion =
+ try Some
+ (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found -> None
+ }
+ }
+ | _ -> raise NotApplicable
+
+and rewrite seed name id li ~ids_to_inner_types ~ids_to_inner_sorts =
+ let aux ?name = acic2content seed ~ids_to_inner_types ~ids_to_inner_sorts in
+ let module C2A = Cic2acic in
+ let module K = Content in
+ let module C = Cic in
+ match li with
+ C.AConst (sid,uri,exp_named_subst)::args ->
+ if UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_URI or
+ UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_r_URI or
+ LibraryObjects.is_eq_ind_URI uri or
+ LibraryObjects.is_eq_ind_r_URI uri then
+ let subproofs,arg =
+ (match
+ build_subproofs_and_args
+ seed ~ids_to_inner_types ~ids_to_inner_sorts [List.nth args 3]
+ with
+ l,[p] -> l,p
+ | _,_ -> assert false) in
+ let method_args =
+ let rec ma_aux n = function
+ [] -> []
+ | a::tl ->
+ let hd =
+ if n = 0 then arg
+ else
+ let aid = get_id a in
+ let asort = (try (Hashtbl.find ids_to_inner_sorts aid)
+ with Not_found -> `Type (CicUniv.fresh())) in
+ if asort = `Prop then
+ K.ArgProof (aux a)
+ else K.Term a in
+ hd::(ma_aux (n-1) tl) in
+ (ma_aux 3 args) in
+ { K.proof_name = name;
+ K.proof_id = gen_id proof_prefix seed;
+ K.proof_context = [];
+ K.proof_apply_context = serialize seed subproofs;
+ K.proof_conclude =
+ { K.conclude_id = gen_id conclude_prefix seed;
+ K.conclude_aref = id;
+ K.conclude_method = "Rewrite";
+ K.conclude_args =
+ K.Term (C.AConst (sid,uri,exp_named_subst))::method_args;
+ K.conclude_conclusion =
+ try Some
+ (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized
+ with Not_found -> None
+ }
+ }
+ else raise NotApplicable
+ | _ -> raise NotApplicable
+;;
+
+let map_conjectures
+ seed ~ids_to_inner_sorts ~ids_to_inner_types (id,n,context,ty)
+=
+ let module K = Content in
+ let context' =
+ List.map
+ (function
+ (id,None) -> None
+ | (id,Some (name,Cic.ADecl t)) ->
+ Some
+ (* We should call build_decl_item, but we have not computed *)
+ (* the inner-types ==> we always produce a declaration *)
+ (`Declaration
+ { K.dec_name = name_of name;
+ K.dec_id = gen_id declaration_prefix seed;
+ K.dec_inductive = false;
+ K.dec_aref = get_id t;
+ K.dec_type = t
+ })
+ | (id,Some (name,Cic.ADef t)) ->
+ Some
+ (* We should call build_def_item, but we have not computed *)
+ (* the inner-types ==> we always produce a declaration *)
+ (`Definition
+ { K.def_name = name_of name;
+ K.def_id = gen_id definition_prefix seed;
+ K.def_aref = get_id t;
+ K.def_term = t
+ })
+ ) context
+ in
+ (id,n,context',ty)
+;;
+
+(* map_sequent is similar to map_conjectures, but the for the hid
+of the hypothesis, which are preserved instead of generating
+fresh ones. We shall have to adopt a uniform policy, soon or later *)
+
+let map_sequent ((id,n,context,ty):Cic.annconjecture) =
+ let module K = Content in
+ let context' =
+ List.map
+ (function
+ (id,None) -> None
+ | (id,Some (name,Cic.ADecl t)) ->
+ Some
+ (* We should call build_decl_item, but we have not computed *)
+ (* the inner-types ==> we always produce a declaration *)
+ (`Declaration
+ { K.dec_name = name_of name;
+ K.dec_id = id;
+ K.dec_inductive = false;
+ K.dec_aref = get_id t;
+ K.dec_type = t
+ })
+ | (id,Some (name,Cic.ADef t)) ->
+ Some
+ (* We should call build_def_item, but we have not computed *)
+ (* the inner-types ==> we always produce a declaration *)
+ (`Definition
+ { K.def_name = name_of name;
+ K.def_id = id;
+ K.def_aref = get_id t;
+ K.def_term = t
+ })
+ ) context
+ in
+ (id,n,context',ty)
+;;
+
+let rec annobj2content ~ids_to_inner_sorts ~ids_to_inner_types =
+ let module C = Cic in
+ let module K = Content in
+ let module C2A = Cic2acic in
+ let seed = ref 0 in
+ function
+ C.ACurrentProof (_,_,n,conjectures,bo,ty,params,_) ->
+ (gen_id object_prefix seed, params,
+ Some
+ (List.map
+ (map_conjectures seed ~ids_to_inner_sorts ~ids_to_inner_types)
+ conjectures),
+ `Def (K.Const,ty,
+ build_def_item seed (get_id bo) (C.Name n) bo
+ ~ids_to_inner_sorts ~ids_to_inner_types))
+ | C.AConstant (_,_,n,Some bo,ty,params,_) ->
+ (gen_id object_prefix seed, params, None,
+ `Def (K.Const,ty,
+ build_def_item seed (get_id bo) (C.Name n) bo
+ ~ids_to_inner_sorts ~ids_to_inner_types))
+ | C.AConstant (id,_,n,None,ty,params,_) ->
+ (gen_id object_prefix seed, params, None,
+ `Decl (K.Const,
+ build_decl_item seed id (C.Name n) ty
+ ~ids_to_inner_sorts))
+ | C.AVariable (_,n,Some bo,ty,params,_) ->
+ (gen_id object_prefix seed, params, None,
+ `Def (K.Var,ty,
+ build_def_item seed (get_id bo) (C.Name n) bo
+ ~ids_to_inner_sorts ~ids_to_inner_types))
+ | C.AVariable (id,n,None,ty,params,_) ->
+ (gen_id object_prefix seed, params, None,
+ `Decl (K.Var,
+ build_decl_item seed id (C.Name n) ty
+ ~ids_to_inner_sorts))
+ | C.AInductiveDefinition (id,l,params,nparams,_) ->
+ (gen_id object_prefix seed, params, None,
+ `Joint
+ { K.joint_id = gen_id joint_prefix seed;
+ K.joint_kind = `Inductive nparams;
+ K.joint_defs = List.map (build_inductive seed) l
+ })
+
+and
+ build_inductive seed =
+ let module K = Content in
+ fun (_,n,b,ty,l) ->
+ `Inductive
+ { K.inductive_id = gen_id inductive_prefix seed;
+ K.inductive_name = n;
+ K.inductive_kind = b;
+ K.inductive_type = ty;
+ K.inductive_constructors = build_constructors seed l
+ }
+
+and
+ build_constructors seed l =
+ let module K = Content in
+ List.map
+ (fun (n,t) ->
+ { K.dec_name = Some n;
+ K.dec_id = gen_id declaration_prefix seed;
+ K.dec_inductive = false;
+ K.dec_aref = "";
+ K.dec_type = t
+ }) l
+;;
+
+(*
+and 'term cinductiveType =
+ id * string * bool * 'term * (* typename, inductive, arity *)
+ 'term cconstructor list (* constructors *)
+
+and 'term cconstructor =
+ string * 'term
+*)
+
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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))
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(**************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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 *)
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+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 *)
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(***************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(**************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti <asperti@cs.unibo.it> *)
+(* 27/6/2003 *)
+(* *)
+(**************************************************************************)
+
+val cobj2obj : Cic.annterm Content.cobj -> Cic.obj
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(***************************************************************************)
+(* *)
+(* 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
+;;
+
+
+
+
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val print_proof: Cic.annterm Content.proof -> unit
+
+val print_obj: Cic.annterm Content.cobj -> unit
+
+val parg: int -> Cic.annterm Content.arg ->unit
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+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
--- /dev/null
+PACKAGE = cic
+PREDICATES =
+
+INTERFACE_FILES = \
+ unshare.mli \
+ cicUniv.mli \
+ deannotate.mli \
+ cicParser.mli \
+ cicUtil.mli \
+ helmLibraryObjects.mli \
+ libraryObjects.mli \
+ discrimination_tree.mli \
+ path_indexing.mli
+IMPLEMENTATION_FILES = \
+ cic.ml $(INTERFACE_FILES:%.mli=%.ml)
+EXTRA_OBJECTS_TO_INSTALL = cic.ml cic.cmi
+EXTRA_OBJECTS_TO_CLEAN =
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*****************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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)
+;;
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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,obj_attributes)
+ | _ ->
+ raise (Parser_failure (sprintf "no constant found in %s, %s"
+ filename filenamebody)))
+
+let obj_of_xml uri filename filenamebody =
+ Deannotate.deannotate_obj (annobj_of_xml uri filename filenamebody)
--- /dev/null
+(* 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
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*****************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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
+
+(*****************************************************************************)
+(** Benchmarking **)
+(*****************************************************************************)
+let time_spent = ref 0.0;;
+let partial = ref 0.0 ;;
+
+let reset_spent_time () = time_spent := 0.0;;
+let get_spent_time () = !time_spent ;;
+let begin_spending () =
+ (*assert (!partial = 0.0);*)
+ partial := Unix.gettimeofday ()
+;;
+
+let end_spending () =
+ assert (!partial > 0.0);
+ let interval = (Unix.gettimeofday ()) -. !partial in
+ partial := 0.0;
+ time_spent := !time_spent +. interval
+;;
+
+
+(*****************************************************************************)
+(** Helpers **)
+(*****************************************************************************)
+
+(* find the repr *)
+let repr u m =
+ try
+ MAL.find u m
+ with
+ Not_found -> empty_entry
+
+(* FIXME: May be faster if we make it by hand *)
+let merge_closures f nodes m =
+ SOF.fold (fun x i -> SOF.union (f (repr x m)) i ) nodes SOF.empty
+
+\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, already_contained) l uri =
+ let fill_empty_universe u =
+ match u with
+ (i,None) -> (i,Some uri)
+ | (i,Some _) as u -> u
+ in
+ let fill_empty_set s =
+ SOF.fold (fun e s -> SOF.add (fill_empty_universe e) s) s SOF.empty
+ in
+ let fill_empty_entry e = {
+ eq_closure = (fill_empty_set e.eq_closure) ;
+ ge_closure = (fill_empty_set e.ge_closure) ;
+ gt_closure = (fill_empty_set e.gt_closure) ;
+ in_gegt_of = (fill_empty_set e.in_gegt_of) ;
+ one_s_eq = (fill_empty_set e.one_s_eq) ;
+ one_s_ge = (fill_empty_set e.one_s_ge) ;
+ one_s_gt = (fill_empty_set e.one_s_gt) ;
+ } in
+ let m = g in
+ let m' = MAL.fold (
+ fun k v m ->
+ MAL.add (fill_empty_universe k) (fill_empty_entry v) m) m MAL.empty
+ in
+ let l' = List.map fill_empty_universe l in
+ (m', already_contained),l'
+
+
+(*****************************************************************************)
+(** World interface **)
+(*****************************************************************************)
+
+type universe_graph = bag * UriManager.UriSet.t
+(* the graph , the cache of already merged ugraphs *)
+
+let empty_ugraph = empty_bag, UriManager.UriSet.empty
+
+let current_index_anon = ref (-1)
+let current_index_named = ref (-1)
+
+let restart_numbering () = current_index_named := (-1)
+
+let fresh ?uri ?id () =
+ let i =
+ match uri,id with
+ | None,None ->
+ current_index_anon := !current_index_anon + 1;
+ !current_index_anon
+ | None, Some _ -> assert false
+ | Some _, None ->
+ current_index_named := !current_index_named + 1;
+ !current_index_named
+ | Some _, Some id -> id
+ in
+ (i,uri)
+
+let name_universe u uri =
+ match u with
+ | (i, None) -> (i, Some uri)
+ | _ -> u
+
+let print_ugraph (g, _) =
+ prerr_endline (string_of_bag g)
+
+let add_eq ?(fast=(!fast_implementation)) u v b =
+ (* should we check to no add twice the same?? *)
+ let m = b in
+ let ru = repr u m in
+ if SOF.mem v ru.gt_closure then
+ error ("EQ",u,v) v "GT" u ru.gt_closure
+ else
+ begin
+ let rv = repr v m in
+ if SOF.mem u rv.gt_closure then
+ error ("EQ",u,v) u "GT" v rv.gt_closure
+ else
+ add_eq fast u v b
+ end
+
+let add_ge ?(fast=(!fast_implementation)) u v b =
+ (* should we check to no add twice the same?? *)
+ let m = b in
+ let rv = repr v m in
+ if SOF.mem u rv.gt_closure then
+ error ("GE",u,v) u "GT" v rv.gt_closure
+ else
+ add_ge fast u v b
+
+let add_gt ?(fast=(!fast_implementation)) u v b =
+ (* should we check to no add twice the same?? *)
+ (*
+ FIXME : check the thesis... no need to check GT and EQ closure since the
+ GE is a superset of both
+ *)
+ let m = b in
+ let rv = repr v m in
+
+ if u = v then
+ error ("GT",u,v) u "==" v SOF.empty
+ else
+
+ (*if SOF.mem u rv.gt_closure then
+ error ("GT",u,v) u "GT" v rv.gt_closure
+ else
+ begin*)
+ if SOF.mem u rv.ge_closure then
+ error ("GT",u,v) u "GE" v rv.ge_closure
+ else
+(* begin
+ if SOF.mem u rv.eq_closure then
+ error ("GT",u,v) u "EQ" v rv.eq_closure
+ else*)
+ add_gt fast u v b
+(* end
+ end*)
+
+(*****************************************************************************)
+(** START: Decomment this for performance comparisons **)
+(*****************************************************************************)
+
+let add_eq ?(fast=(!fast_implementation)) u v (b,already_contained) =
+ (*prerr_endline "add_eq";*)
+ begin_spending ();
+ let rc = add_eq ~fast u v b in
+ end_spending ();
+ rc,already_contained
+
+let add_ge ?(fast=(!fast_implementation)) u v (b,already_contained) =
+(* prerr_endline "add_ge"; *)
+ begin_spending ();
+ let rc = add_ge ~fast u v b in
+ end_spending ();
+ rc,already_contained
+
+let add_gt ?(fast=(!fast_implementation)) u v (b,already_contained) =
+(* prerr_endline "add_gt"; *)
+ begin_spending ();
+ let rc = add_gt ~fast u v b in
+ end_spending ();
+ rc,already_contained
+
+let profiler_eq = HExtlib.profile "CicUniv.add_eq"
+let profiler_ge = HExtlib.profile "CicUniv.add_ge"
+let profiler_gt = HExtlib.profile "CicUniv.add_gt"
+let add_gt ?fast u v b =
+ profiler_gt.HExtlib.profile (fun _ -> add_gt ?fast u v b) ()
+let add_ge ?fast u v b =
+ profiler_ge.HExtlib.profile (fun _ -> add_ge ?fast u v b) ()
+let add_eq ?fast u v b =
+ profiler_eq.HExtlib.profile (fun _ -> add_eq ?fast u v b) ()
+
+(*****************************************************************************)
+(** END: Decomment this for performance comparisons **)
+(*****************************************************************************)
+
+let merge_ugraphs ~base_ugraph ~increment:(increment, uri_of_increment) =
+ let merge_brutal (u,_) v =
+ let m1 = u in
+ let m2 = v in
+ MAL.fold (
+ fun k v x ->
+ (SOF.fold (
+ fun u x ->
+ let m = add_gt k u x in m)
+ (SOF.union v.one_s_gt v.gt_closure)
+ (SOF.fold (
+ fun u x ->
+ let m = add_ge k u x in m)
+ (SOF.union v.one_s_ge v.ge_closure)
+ (SOF.fold (
+ fun u x ->
+ let m = add_eq k u x in m)
+ (SOF.union v.one_s_eq v.eq_closure) x)))
+ ) m1 m2
+ in
+ let base, already_contained = base_ugraph in
+ if MAL.is_empty base then
+ increment
+ else if
+ MAL.is_empty (fst increment) ||
+ UriManager.UriSet.mem uri_of_increment already_contained
+ then
+ base_ugraph
+ else
+ fst (merge_brutal increment base_ugraph),
+ UriManager.UriSet.add uri_of_increment already_contained
+
+let profiler_merge = HExtlib.profile "CicUniv.merge_graphs"
+let merge_ugraphs ~base_ugraph ~increment =
+ profiler_merge.HExtlib.profile
+ (fun _ -> merge_ugraphs ~base_ugraph ~increment) ()
+
+(*****************************************************************************)
+(** Xml sesialization and parsing **)
+(*****************************************************************************)
+
+let xml_of_universe name u =
+ match u with
+ | (i,Some u) ->
+ Xml.xml_empty name [
+ None,"id",(string_of_int i) ;
+ None,"uri",(UriManager.string_of_uri u)]
+ | (_,None) ->
+ raise (Failure "we can serialize only universes with uri")
+
+let xml_of_set s =
+ let l =
+ List.map (xml_of_universe "node") (SOF.elements s)
+ in
+ List.fold_left (fun s x -> [< s ; x >] ) [<>] l
+
+let xml_of_entry_content e =
+ let stream_of_field f name =
+ let eq_c = xml_of_set f in
+ if eq_c != [<>] then
+ Xml.xml_nempty name [] eq_c
+ else
+ [<>]
+ in
+ [<
+ (stream_of_field e.eq_closure "eq_closure");
+ (stream_of_field e.gt_closure "gt_closure");
+ (stream_of_field e.ge_closure "ge_closure");
+ (stream_of_field e.in_gegt_of "in_gegt_of");
+ (stream_of_field e.one_s_eq "one_s_eq");
+ (stream_of_field e.one_s_gt "one_s_gt");
+ (stream_of_field e.one_s_ge "one_s_ge")
+ >]
+
+let xml_of_entry u e =
+ let (i,u') = u in
+ let u'' =
+ match u' with
+ Some x -> x
+ | None ->
+ raise (Failure "we can serialize only universes (entry) with uri")
+ in
+ let ent = Xml.xml_nempty "entry" [
+ None,"id",(string_of_int i) ;
+ None,"uri",(UriManager.string_of_uri u'')] in
+ let content = xml_of_entry_content e in
+ ent content
+
+let write_xml_of_ugraph filename (m,_) l =
+ let tokens =
+ [<
+ Xml.xml_cdata "<?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,already_contained) f =
+ let m' =
+ MAL.fold (fun k v x -> if (f k) then MAL.add k v x else x ) m MAL.empty in
+ let m'' = MAL.fold (fun k v x ->
+ let v' = {
+ eq_closure = SOF.filter f v.eq_closure;
+ ge_closure = SOF.filter f v.ge_closure;
+ gt_closure = SOF.filter f v.gt_closure;
+ in_gegt_of = SOF.filter f v.in_gegt_of;
+ one_s_eq = SOF.filter f v.one_s_eq;
+ one_s_ge = SOF.filter f v.one_s_ge;
+ one_s_gt = SOF.filter f v.one_s_gt
+ } in
+ MAL.add k v' x ) m' MAL.empty in
+ let e_l =
+ MAL.fold (fun k v l -> if v = empty_entry && not(f k) then
+ begin
+ k::l end else l) m'' []
+ in
+ if e_l != [] then
+ clean_ugraph
+ (m'', already_contained) (fun u -> (f u) && not (List.mem u e_l))
+ else
+ MAL.fold
+ (fun k v x -> if v <> empty_entry then MAL.add k v x else x)
+ m'' MAL.empty,
+ already_contained
+
+let clean_ugraph g l =
+ clean_ugraph g (fun u -> List.mem u l)
+
+let assigner_of =
+ function
+ "ge_closure" -> (fun e u->{e with ge_closure=SOF.add u e.ge_closure})
+ | "gt_closure" -> (fun e u->{e with gt_closure=SOF.add u e.gt_closure})
+ | "eq_closure" -> (fun e u->{e with eq_closure=SOF.add u e.eq_closure})
+ | "in_gegt_of" -> (fun e u->{e with in_gegt_of =SOF.add u e.in_gegt_of})
+ | "one_s_ge" -> (fun e u->{e with one_s_ge =SOF.add u e.one_s_ge})
+ | "one_s_gt" -> (fun e u->{e with one_s_gt =SOF.add u e.one_s_gt})
+ | "one_s_eq" -> (fun e u->{e with one_s_eq =SOF.add u e.one_s_eq})
+ | s -> raise (Failure ("unsupported tag " ^ s))
+;;
+
+let cb_factory m l =
+ let module XPP = XmlPushParser in
+ let current_node = ref (0,None) in
+ let current_entry = ref empty_entry in
+ let current_assign = ref (assigner_of "in_gegt_of") in
+ { XPP.default_callbacks with
+ XPP.end_element = Some( fun name ->
+ match name with
+ | "entry" ->
+ m := MAL.add !current_node !current_entry !m;
+ current_entry := empty_entry
+ | _ -> ()
+ );
+ XPP.start_element = Some( fun name attlist ->
+ match name with
+ | "ugraph" -> ()
+ | "entry" ->
+ let id = List.assoc "id" attlist in
+ let uri = List.assoc "uri" attlist in
+ current_node := (int_of_string id,Some (UriManager.uri_of_string uri))
+ | "node" ->
+ let id = int_of_string (List.assoc "id" attlist) in
+ let uri = List.assoc "uri" attlist in
+ current_entry := !current_assign !current_entry
+ (id,Some (UriManager.uri_of_string uri))
+ | "owned_node" ->
+ let id = int_of_string (List.assoc "id" attlist) in
+ let uri = List.assoc "uri" attlist in
+ l := (id,Some (UriManager.uri_of_string uri)) :: !l
+ | s -> current_assign := assigner_of s
+ )
+ }
+;;
+
+let ugraph_and_univlist_of_xml filename =
+ let module XPP = XmlPushParser in
+ let result_map = ref MAL.empty in
+ let result_list = ref [] in
+ let cb = cb_factory result_map result_list in
+ let xml_parser = XPP.create_parser cb in
+ let xml_source = `Gzip_file filename in
+ (try XPP.parse xml_parser xml_source
+ with (XPP.Parse_error err) as exn -> raise exn);
+ (!result_map,UriManager.UriSet.empty), !result_list
+
+\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,uriset) =
+ MAL.fold
+ (fun universe entry map ->
+ MAL.add (recons_univ universe) (recons_entry entry) map)
+ graph
+ MAL.empty,
+ UriManager.UriSet.fold
+ (fun u acc ->
+ UriManager.UriSet.add
+ (UriManager.uri_of_string (UriManager.string_of_uri u)) acc)
+ uriset UriManager.UriSet.empty
+
+let assert_univ u =
+ match u with
+ | (_,None) -> raise (UniverseInconsistency "This universe graph has a hole")
+ | _ -> ()
+
+let assert_univs_have_uri (graph,_) univlist =
+ let assert_set s =
+ SOF.iter (fun u -> assert_univ u) s
+ in
+ let assert_entry e =
+ assert_set e.eq_closure;
+ assert_set e.ge_closure;
+ assert_set e.gt_closure;
+ assert_set e.in_gegt_of;
+ assert_set e.one_s_eq;
+ assert_set e.one_s_ge;
+ assert_set e.one_s_gt;
+ in
+ MAL.iter (fun k v -> assert_univ k; assert_entry v)graph;
+ List.iter assert_univ univlist
+
+let eq u1 u2 =
+ match u1,u2 with
+ | (id1, Some uri1),(id2, Some uri2) ->
+ id1 = id2 && UriManager.eq uri1 uri2
+ | (id1, None),(id2, None) -> id1 = id2
+ | _ -> false
+
+let compare (id1, uri1) (id2, uri2) =
+ let cmp = id1 - id2 in
+ if cmp = 0 then
+ match uri1,uri2 with
+ | None, None -> 0
+ | Some _, None -> 1
+ | None, Some _ -> ~-1
+ | Some uri1, Some uri2 -> UriManager.compare uri1 uri2
+ else
+ cmp
+
+(* EOF *)
--- /dev/null
+(* Copyright (C) 2004, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+
+(*
+ The strings contains an unreadable message
+*)
+exception UniverseInconsistency of string
+
+(*
+ Cic.Type of universe
+*)
+type universe
+
+(*
+ Opaque data structure you will use to store constraints
+*)
+type universe_graph
+
+(*
+ returns a fresh universe
+*)
+val fresh:
+ ?uri:UriManager.uri ->
+ ?id:int ->
+ unit ->
+ universe
+
+ (* names a universe if unnamed *)
+val name_universe: universe -> UriManager.uri -> universe
+
+(*
+ really useful at the begin and in all the functions that don't care
+ of universes
+*)
+val empty_ugraph: universe_graph
+
+(*
+ These are the real functions to add eq/ge/gt constraints
+ to the passed graph, returning an updated graph or raising
+ UniverseInconsistency
+*)
+val add_eq:
+ ?fast:bool -> universe -> universe -> universe_graph -> universe_graph
+val add_ge:
+ ?fast:bool -> universe -> universe -> universe_graph -> universe_graph
+val add_gt:
+ ?fast:bool -> universe -> universe -> universe_graph -> universe_graph
+
+(*
+ debug function to print the graph to standard error
+*)
+val print_ugraph:
+ universe_graph -> unit
+
+(*
+ does what expected, but I don't remember why this was exported
+*)
+val string_of_universe:
+ universe -> string
+
+(*
+ given the list of visible universes (see universes_of_obj) returns a
+ cleaned graph (cleaned from the not visible nodes)
+*)
+val clean_ugraph:
+ universe_graph -> universe list -> universe_graph
+
+(*
+ Since fresh() can't add the right uri to each node, you
+ must fill empty nodes with the uri before you serialize the graph to xml
+
+ these empty nodes are also filled in the universe list
+*)
+val fill_empty_nodes_with_uri:
+ universe_graph -> universe list -> UriManager.uri ->
+ universe_graph * universe list
+
+(*
+ makes a union.
+ TODO:
+ - remember already merged uri so that we completely skip already merged
+ graphs, this may include a dependecy graph (not merge a subpart of an
+ already merged graph)
+*)
+val merge_ugraphs:
+ base_ugraph:universe_graph ->
+ increment:(universe_graph * UriManager.uri) -> universe_graph
+
+(*
+ ugraph to xml file and viceversa
+*)
+val write_xml_of_ugraph:
+ string -> universe_graph -> universe list -> unit
+
+(*
+ given a filename parses the xml and returns the data structure
+*)
+val ugraph_and_univlist_of_xml:
+ string -> universe_graph * universe list
+val restart_numbering:
+ unit -> unit
+
+(*
+ returns the universe number (used to save it do xml)
+*)
+val univno: universe -> int
+
+ (** re-hash-cons URIs contained in the given universe so that phisicaly
+ * equality could be enforced. Mainly used by
+ * CicEnvironment.restore_from_channel *)
+val recons_graph: universe_graph -> universe_graph
+
+ (** re-hash-cons a single universe *)
+val recons_univ: universe -> universe
+
+ (** consistency chek that should be done before committin the graph to the
+ * cache *)
+val assert_univs_have_uri: universe_graph -> universe list-> unit
+
+ (** asserts the universe is named *)
+val assert_univ: universe -> unit
+
+val compare: universe -> universe -> int
+val eq: universe -> universe -> bool
+
+(*
+ Benchmarking stuff
+*)
+val get_spent_time: unit -> float
+val reset_spent_time: unit -> unit
+
--- /dev/null
+(* 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)
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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)
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 29/11/2000 *)
+(* *)
+(******************************************************************************)
+
+val deannotate_term : Cic.annterm -> Cic.term
+val deannotate_obj : Cic.annobj -> Cic.obj
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+module DiscriminationTreeIndexing =
+ functor (A:Set.S) ->
+ struct
+
+ type path_string_elem = Cic.term;;
+ type path_string = path_string_elem list;;
+
+
+ (* needed by the retrieve_* functions, to know the arities of the "functions" *)
+
+ let arities = Hashtbl.create 11;;
+
+
+ let rec path_string_of_term = function
+ | Cic.Meta _ -> [Cic.Implicit None]
+ | Cic.Appl ((hd::tl) as l) ->
+ if not (Hashtbl.mem arities hd) then
+ Hashtbl.add arities hd (List.length tl);
+ List.concat (List.map path_string_of_term l)
+ | term -> [term]
+ ;;
+
+
+ module OrderedPathStringElement = struct
+ type t = path_string_elem
+
+ let compare = Pervasives.compare
+ end
+
+ module PSMap = Map.Make(OrderedPathStringElement);;
+
+ type key = PSMap.key
+
+ module DiscriminationTree = Trie.Make(PSMap);;
+
+ type t = A.t DiscriminationTree.t
+ let empty = DiscriminationTree.empty
+
+(*
+ module OrderedPosEquality = struct
+ type t = Utils.pos * Inference.equality
+ let compare = Pervasives.compare
+ end
+
+ module PosEqSet = Set.Make(OrderedPosEquality);;
+
+ let string_of_discrimination_tree tree =
+ let rec to_string level = function
+ | DiscriminationTree.Node (value, map) ->
+ let s =
+ match value with
+ | Some v ->
+ (String.make (2 * level) ' ') ^
+ "{" ^ (String.concat "; "
+ (List.map
+ (fun (p, e) ->
+ "(" ^ (Utils.string_of_pos p) ^ ", " ^
+ (Inference.string_of_equality e) ^ ")")
+ (PosEqSet.elements v))) ^ "}"
+ | None -> ""
+ in
+ let rest =
+ String.concat "\n"
+ (PSMap.fold
+ (fun k v s ->
+ let ks = CicPp.ppterm k in
+ let rs = to_string (level+1) v in
+ ((String.make (2 * level) ' ') ^ ks ^ "\n" ^ rs)::s)
+ map [])
+ in
+ s ^ rest
+ in
+ to_string 0 tree
+ ;;
+*)
+
+ let index tree term info =
+ let ps = path_string_of_term term in
+ let ps_set =
+ try DiscriminationTree.find ps tree
+ with Not_found -> A.empty in
+ let tree =
+ DiscriminationTree.add ps (A.add info ps_set) tree in
+ tree
+
+(*
+ let index tree equality =
+ let _, _, (_, l, r, ordering), _, _ = equality in
+ let psl = path_string_of_term l
+ and psr = path_string_of_term r in
+ let index pos tree ps =
+ let ps_set =
+ try DiscriminationTree.find ps tree with Not_found -> PosEqSet.empty in
+ let tree =
+ DiscriminationTree.add ps (PosEqSet.add (pos, equality) ps_set) tree in
+ tree
+ in
+ match ordering with
+ | Utils.Gt -> index Utils.Left tree psl
+ | Utils.Lt -> index Utils.Right tree psr
+ | _ ->
+ let tree = index Utils.Left tree psl in
+ index Utils.Right tree psr
+ ;;
+*)
+
+ let remove_index tree term info =
+ let ps = path_string_of_term term in
+ try
+ let ps_set =
+ A.remove info (DiscriminationTree.find ps tree) in
+ if A.is_empty ps_set then
+ DiscriminationTree.remove ps tree
+ else
+ DiscriminationTree.add ps ps_set tree
+ with Not_found ->
+ tree
+
+(*
+let remove_index tree equality =
+ let _, _, (_, l, r, ordering), _, _ = equality in
+ let psl = path_string_of_term l
+ and psr = path_string_of_term r in
+ let remove_index pos tree ps =
+ try
+ let ps_set =
+ PosEqSet.remove (pos, equality) (DiscriminationTree.find ps tree) in
+ if PosEqSet.is_empty ps_set then
+ DiscriminationTree.remove ps tree
+ else
+ DiscriminationTree.add ps ps_set tree
+ with Not_found ->
+ tree
+ in
+ match ordering with
+ | Utils.Gt -> remove_index Utils.Left tree psl
+ | Utils.Lt -> remove_index Utils.Right tree psr
+ | _ ->
+ let tree = remove_index Utils.Left tree psl in
+ remove_index Utils.Right tree psr
+;;
+*)
+
+
+ let in_index tree term test =
+ let ps = path_string_of_term term in
+ try
+ let ps_set = DiscriminationTree.find ps tree in
+ A.exists test ps_set
+ with Not_found ->
+ false
+
+(*
+ let in_index tree equality =
+ let _, _, (_, l, r, ordering), _, _ = equality in
+ let psl = path_string_of_term l
+ and psr = path_string_of_term r in
+ let meta_convertibility = Inference.meta_convertibility_eq equality in
+ let ok ps =
+ try
+ let set = DiscriminationTree.find ps tree in
+ PosEqSet.exists (fun (p, e) -> meta_convertibility e) set
+ with Not_found ->
+ false
+ in
+ (ok psl) || (ok psr)
+;;
+*)
+
+
+ let head_of_term = function
+ | Cic.Appl (hd::tl) -> hd
+ | term -> term
+ ;;
+
+
+ let rec subterm_at_pos pos term =
+ match pos with
+ | [] -> term
+ | index::pos ->
+ match term with
+ | Cic.Appl l ->
+ (try subterm_at_pos pos (List.nth l index)
+ with Failure _ -> raise Not_found)
+ | _ -> raise Not_found
+ ;;
+
+
+ let rec after_t pos term =
+ let pos' =
+ match pos with
+ | [] -> raise Not_found
+ | pos -> List.fold_right (fun i r -> if r = [] then [i+1] else i::r) pos []
+ in
+ try
+ ignore(subterm_at_pos pos' term ); pos'
+ with Not_found ->
+ let pos, _ =
+ List.fold_right
+ (fun i (r, b) -> if b then (i::r, true) else (r, true)) pos ([], false)
+ in
+ after_t pos term
+ ;;
+
+
+ let next_t pos term =
+ let t = subterm_at_pos pos term in
+ try
+ let _ = subterm_at_pos [1] t in
+ pos @ [1]
+ with Not_found ->
+ match pos with
+ | [] -> [1]
+ | pos -> after_t pos term
+ ;;
+
+
+ let retrieve_generalizations tree term =
+ let rec retrieve tree term pos =
+ match tree with
+ | DiscriminationTree.Node (Some s, _) when pos = [] -> s
+ | DiscriminationTree.Node (_, map) ->
+ let res =
+ try
+ let hd_term = head_of_term (subterm_at_pos pos term) in
+ let n = PSMap.find hd_term map in
+ match n with
+ | DiscriminationTree.Node (Some s, _) -> s
+ | DiscriminationTree.Node (None, _) ->
+ let newpos = try next_t pos term with Not_found -> [] in
+ retrieve n term newpos
+ with Not_found ->
+ A.empty
+ in
+ try
+ let n = PSMap.find (Cic.Implicit None) map in
+ let newpos = try after_t pos term with Not_found -> [-1] in
+ if newpos = [-1] then
+ match n with
+ | DiscriminationTree.Node (Some s, _) -> A.union s res
+ | _ -> res
+ else
+ A.union res (retrieve n term newpos)
+ with Not_found ->
+ res
+ in
+ retrieve tree term []
+ ;;
+
+
+ let jump_list = function
+ | DiscriminationTree.Node (value, map) ->
+ let rec get n tree =
+ match tree with
+ | DiscriminationTree.Node (v, m) ->
+ if n = 0 then
+ [tree]
+ else
+ PSMap.fold
+ (fun k v res ->
+ let a = try Hashtbl.find arities k with Not_found -> 0 in
+ (get (n-1 + a) v) @ res) m []
+ in
+ PSMap.fold
+ (fun k v res ->
+ let arity = try Hashtbl.find arities k with Not_found -> 0 in
+ (get arity v) @ res)
+ map []
+ ;;
+
+
+ let retrieve_unifiables tree term =
+ let rec retrieve tree term pos =
+ match tree with
+ | DiscriminationTree.Node (Some s, _) when pos = [] -> s
+ | DiscriminationTree.Node (_, map) ->
+ let subterm =
+ try Some (subterm_at_pos pos term) with Not_found -> None
+ in
+ match subterm with
+ | None -> A.empty
+ | Some (Cic.Meta _) ->
+ let newpos = try next_t pos term with Not_found -> [] in
+ let jl = jump_list tree in
+ List.fold_left
+ (fun r s -> A.union r s)
+ A.empty
+ (List.map (fun t -> retrieve t term newpos) jl)
+ | Some subterm ->
+ let res =
+ try
+ let hd_term = head_of_term subterm in
+ let n = PSMap.find hd_term map in
+ match n with
+ | DiscriminationTree.Node (Some s, _) -> s
+ | DiscriminationTree.Node (None, _) ->
+ retrieve n term (next_t pos term)
+ with Not_found ->
+ A.empty
+ in
+ try
+ let n = PSMap.find (Cic.Implicit None) map in
+ let newpos = try after_t pos term with Not_found -> [-1] in
+ if newpos = [-1] then
+ match n with
+ | DiscriminationTree.Node (Some s, _) -> A.union s res
+ | _ -> res
+ else
+ A.union res (retrieve n term newpos)
+ with Not_found ->
+ res
+ in
+ retrieve tree term []
+ end
+;;
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+(**** TABLES ****)
+
+let default_eq_URIs =
+ [HelmLibraryObjects.Logic.eq_URI,
+ HelmLibraryObjects.Logic.sym_eq_URI,
+ HelmLibraryObjects.Logic.trans_eq_URI,
+ HelmLibraryObjects.Logic.eq_ind_URI,
+ HelmLibraryObjects.Logic.eq_ind_r_URI];;
+
+let default_true_URIs = [HelmLibraryObjects.Logic.true_URI]
+let default_false_URIs = [HelmLibraryObjects.Logic.false_URI]
+let default_absurd_URIs = [HelmLibraryObjects.Logic.absurd_URI]
+
+(* eq, sym_eq, trans_eq, eq_ind, eq_ind_R *)
+let eq_URIs_ref =
+ ref [HelmLibraryObjects.Logic.eq_URI,
+ HelmLibraryObjects.Logic.sym_eq_URI,
+ HelmLibraryObjects.Logic.trans_eq_URI,
+ HelmLibraryObjects.Logic.eq_ind_URI,
+ HelmLibraryObjects.Logic.eq_ind_r_URI];;
+
+let true_URIs_ref = ref [HelmLibraryObjects.Logic.true_URI]
+let false_URIs_ref = ref [HelmLibraryObjects.Logic.false_URI]
+let absurd_URIs_ref = ref [HelmLibraryObjects.Logic.absurd_URI]
+
+
+(**** SET_DEFAULT ****)
+
+exception NotRecognized;;
+
+(* insert an element in front of the list, removing from the list all the
+ previous elements with the same key associated *)
+let insert_unique e extract l =
+ let uri = extract e in
+ let l' =
+ List.filter (fun x -> let uri' = extract x in not (UriManager.eq uri uri')) l
+ in
+ e :: l'
+
+let set_default what l =
+ match what,l with
+ "equality",[eq_URI;sym_eq_URI;trans_eq_URI;eq_ind_URI;eq_ind_r_URI] ->
+ eq_URIs_ref :=
+ insert_unique (eq_URI,sym_eq_URI,trans_eq_URI,eq_ind_URI,eq_ind_r_URI)
+ (fun x,_,_,_,_ -> x) !eq_URIs_ref
+ | "true",[true_URI] ->
+ true_URIs_ref := insert_unique true_URI (fun x -> x) !true_URIs_ref
+ | "false",[false_URI] ->
+ false_URIs_ref := insert_unique false_URI (fun x -> x) !false_URIs_ref
+ | "absurd",[absurd_URI] ->
+ absurd_URIs_ref := insert_unique absurd_URI (fun x -> x) !absurd_URIs_ref
+ | _,_ -> raise NotRecognized
+
+let reset_defaults () =
+ eq_URIs_ref := default_eq_URIs;
+ true_URIs_ref := default_true_URIs;
+ false_URIs_ref := default_false_URIs;
+ absurd_URIs_ref := default_absurd_URIs
+
+(**** LOOKUP FUNCTIONS ****)
+
+let eq_URI () = let eq,_,_,_,_ = List.hd !eq_URIs_ref in eq
+
+let is_eq_URI uri =
+ List.exists (fun (eq,_,_,_,_) -> UriManager.eq eq uri) !eq_URIs_ref
+
+let is_eq_ind_URI uri =
+ List.exists (fun (_,_,_,eq_ind,_) -> UriManager.eq eq_ind uri) !eq_URIs_ref
+
+let is_eq_ind_r_URI uri =
+ List.exists (fun (_,_,_,_,eq_ind_r) -> UriManager.eq eq_ind_r uri) !eq_URIs_ref
+
+let sym_eq_URI ~eq:uri =
+ try
+ let _,x,_,_,_ = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x
+ with Not_found -> raise NotRecognized
+
+let trans_eq_URI ~eq:uri =
+ try
+ let _,_,x,_,_ = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x
+ with Not_found -> raise NotRecognized
+
+let eq_ind_URI ~eq:uri =
+ try
+ let _,_,_,x,_ = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x
+ with Not_found -> raise NotRecognized
+
+let eq_ind_r_URI ~eq:uri =
+ try
+ let _,_,_,_,x = List.find (fun eq,_,_,_,_ -> UriManager.eq eq uri) !eq_URIs_ref in x
+ with Not_found -> raise NotRecognized
+
+let true_URI () = List.hd !true_URIs_ref
+let false_URI () = List.hd !false_URIs_ref
+let absurd_URI () = List.hd !absurd_URIs_ref
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+val set_default : string -> UriManager.uri list -> unit
+val reset_defaults : unit -> unit
+
+val eq_URI : unit -> UriManager.uri
+
+val is_eq_URI : UriManager.uri -> bool
+val is_eq_ind_URI : UriManager.uri -> bool
+val is_eq_ind_r_URI : UriManager.uri -> bool
+
+exception NotRecognized;;
+
+val eq_ind_URI : eq:UriManager.uri -> UriManager.uri
+val eq_ind_r_URI : eq:UriManager.uri -> UriManager.uri
+val trans_eq_URI : eq:UriManager.uri -> UriManager.uri
+val sym_eq_URI : eq:UriManager.uri -> UriManager.uri
+
+
+val false_URI : unit -> UriManager.uri
+val true_URI : unit -> UriManager.uri
+val absurd_URI : unit -> UriManager.uri
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 -> ()
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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)
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val unshare : Cic.term -> Cic.term
--- /dev/null
+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
--- /dev/null
+PACKAGE = cic_acic
+PREDICATES =
+
+INTERFACE_FILES = \
+ eta_fixing.mli \
+ doubleTypeInference.mli \
+ cic2acic.mli \
+ cic2Xml.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* 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 [<>]
+ )
+ >]
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception 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
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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)
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception 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
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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
+;;
--- /dev/null
+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
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val eta_fix : Cic.metasenv -> Cic.context -> Cic.term -> Cic.term
+
+
--- /dev/null
+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
--- /dev/null
+
+PACKAGE = cic_disambiguation
+NOTATIONS = number
+INTERFACE_FILES = \
+ disambiguateTypes.mli \
+ disambiguateChoices.mli \
+ disambiguate.mli
+IMPLEMENTATION_FILES = \
+ $(patsubst %.mli, %.ml, $(INTERFACE_FILES)) \
+ $(patsubst %,%_notation.ml,$(NOTATIONS))
+
+all:
+
+clean:
+distclean:
+ rm -f macro_table.dump
+
+include ../../Makefile.defs
+include ../Makefile.common
+
+OCAMLARCHIVEOPTIONS += -linkall
+
+disambiguateTypes.cmi: disambiguateTypes.mli
+ @echo " OCAMLC -rectypes $<"
+ @$(OCAMLC) -c -rectypes $<
+disambiguateTypes.cmo: disambiguateTypes.ml disambiguateTypes.cmi
+ @echo " OCAMLC -rectypes $<"
+ @$(OCAMLC) -c -rectypes $<
+disambiguateTypes.cmx: disambiguateTypes.ml disambiguateTypes.cmi
+ @echo " OCAMLOPT -rectypes $<"
+ @$(OCAMLOPT) -c -rectypes $<
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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)))
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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)
--- /dev/null
+(* 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
+*)
--- /dev/null
+
+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)
+
--- /dev/null
+(* 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))
+
--- /dev/null
+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"
--- /dev/null
+\forall n. \forall m. n + m = n
--- /dev/null
+[\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 []
+
--- /dev/null
+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
--- /dev/null
+
+PACKAGE = cic_proof_checking
+PREDICATES =
+
+REDUCTION_IMPLEMENTATION = cicReductionMachine.ml
+
+INTERFACE_FILES = \
+ cicLogger.mli \
+ cicEnvironment.mli \
+ cicPp.mli \
+ cicUnivUtils.mli \
+ cicSubstitution.mli \
+ cicMiniReduction.mli \
+ cicReduction.mli \
+ cicTypeChecker.mli \
+ freshNamesGenerator.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+
+# Metadata tools only need zeta-reduction
+EXTRA_OBJECTS_TO_INSTALL = \
+ cicSubstitution.cmo cicSubstitution.cmx cicSubstitution.o \
+ cicMiniReduction.cmo cicMiniReduction.cmx cicMiniReduction.o
+EXTRA_OBJECTS_TO_CLEAN =
+
+include ../../Makefile.defs
+include ../Makefile.common
+
+cicReduction.cmo: OCAMLOPTIONS+=-rectypes
+cicReduction.cmx: OCAMLOPTIONS+=-rectypes
+
+all: all_utilities
+opt: opt_utilities
+
+all_utilities:
+ @$(MAKE) -C utilities/ all
+opt_utilities:
+ @$(MAKE) -C utilities/ opt
+
+clean: clean_utilities
+clean_utilities:
+ @$(MAKE) -C utilities/ clean
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*****************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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_ugraph uri =
+ try
+ (* the object should be in the cacheOfCookedObjects *)
+ let o,u,l = Cache.find_cooked uri in
+ o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)),l
+ with Not_found ->
+ (* this should be an error case, but if we trust the uri... *)
+ if trust && trust_obj uri then
+ (* trusting means that we will fetch cook it on the fly *)
+ let o,u,l = add_trusted_uri_to_cache uri in
+ o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)),l
+ else
+ (* we don't trust the uri, so we fail *)
+ begin
+ debug_print (lazy ("CACHE MISS: " ^ (UriManager.string_of_uri uri)));
+ raise Not_found
+ end
+
+let get_cooked_obj ?trust base_ugraph uri =
+ let o,g,_ = get_cooked_obj_with_univlist ?trust base_ugraph uri in
+ o,g
+
+(* This has not the old semantic :( but is what the name suggests
+ *
+ * let is_type_checked ?(trust=true) uri =
+ * try
+ * let _ = Cache.find_cooked uri in
+ * true
+ * with
+ * Not_found ->
+ * trust && trust_obj uri
+ * ;;
+ *
+ * as the get_cooked_obj but returns a type_checked_obj
+ *
+ *)
+let is_type_checked ?(trust=true) base_ugraph uri =
+ try
+ let o,u,_ = Cache.find_cooked uri in
+ CheckedObj (o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri)))
+ with Not_found ->
+ (* this should return UncheckedObj *)
+ if trust && trust_obj uri then
+ (* trusting means that we will fetch cook it on the fly *)
+ let o,u,_ = add_trusted_uri_to_cache uri in
+ CheckedObj ( o, CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri))
+ else
+ let o,u,_ = find_or_add_to_unchecked uri in
+ Cache.unchecked_to_frozen uri;
+ UncheckedObj o
+;;
+
+(* as the get cooked, but if not present the object is only fetched,
+ * not unfreezed and committed
+ *)
+let get_obj base_ugraph uri =
+ try
+ (* the object should be in the cacheOfCookedObjects *)
+ let o,u,_ = Cache.find_cooked uri in
+ o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri))
+ with Not_found ->
+ (* this should be an error case, but if we trust the uri... *)
+ let o,u,_ = find_or_add_to_unchecked uri in
+ o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri))
+;;
+
+let in_cache uri =
+ Cache.is_in_cooked uri || Cache.is_in_frozen uri || Cache.is_in_unchecked uri
+
+let add_type_checked_obj uri (obj,ugraph,univlist) =
+ Cache.add_cooked ~key:uri (obj,ugraph,univlist)
+
+let in_library uri = in_cache uri || Http_getter.exists' uri
+
+let remove_obj = Cache.remove
+
+let list_uri () =
+ Cache.list_all_cooked_uris ()
+;;
+
+let list_obj () =
+ try
+ List.map (fun u ->
+ let o,ug = get_obj CicUniv.empty_ugraph u in
+ (u,o,ug))
+ (list_uri ())
+ with
+ Not_found ->
+ debug_print (lazy "Who has removed the uri in the meanwhile?");
+ raise Not_found
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(****************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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 *)
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+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
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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)
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val letin_nf : Cic.term -> Cic.term
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*****************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* This module implements a very simple Coq-like pretty printer that, given *)
+(* an object of cic (internal representation) returns a string describing *)
+(* the object in a syntax similar to that of coq *)
+(* *)
+(* It also contains the utility functions to check a name w.r.t the Matita *)
+(* naming policy *)
+(* *)
+(*****************************************************************************)
+
+(* $Id$ *)
+
+exception CicPpInternalError;;
+exception NotEnoughElements;;
+
+(* Utility functions *)
+
+let ppname =
+ function
+ Cic.Name s -> s
+ | Cic.Anonymous -> "_"
+;;
+
+(* get_nth l n returns the nth element of the list l if it exists or *)
+(* raises NotEnoughElements if l has less than n elements *)
+let rec get_nth l n =
+ match (n,l) with
+ (1, he::_) -> he
+ | (n, he::tail) when n > 1 -> get_nth tail (n-1)
+ | (_,_) -> raise NotEnoughElements
+;;
+
+(* pp t l *)
+(* pretty-prints a term t of cic in an environment l where l is a list of *)
+(* identifier names used to resolve DeBrujin indexes. The head of l is the *)
+(* name associated to the greatest DeBrujin index in t *)
+let rec pp t l =
+ let module C = Cic in
+ match t with
+ C.Rel n ->
+ begin
+ try
+ (match get_nth l n with
+ Some (C.Name s) -> s
+ | Some C.Anonymous -> "__" ^ string_of_int n
+ | None -> "_hidden_" ^ string_of_int n
+ )
+ with
+ NotEnoughElements -> string_of_int (List.length l - n)
+ end
+ | C.Var (uri,exp_named_subst) ->
+ UriManager.string_of_uri (*UriManager.name_of_uri*) uri ^ pp_exp_named_subst exp_named_subst l
+ | C.Meta (n,l1) ->
+ "?" ^ (string_of_int n) ^ "[" ^
+ String.concat " ; "
+ (List.rev_map (function None -> "_" | Some t -> pp t l) l1) ^
+ "]"
+ | C.Sort s ->
+ (match s with
+ C.Prop -> "Prop"
+ | C.Set -> "Set"
+ | C.Type _ -> "Type"
+ (*| C.Type u -> ("Type" ^ CicUniv.string_of_universe u)*)
+ | C.CProp -> "CProp"
+ )
+ | C.Implicit (Some `Hole) -> "%"
+ | C.Implicit _ -> "?"
+ | C.Prod (b,s,t) ->
+ (match b with
+ C.Name n -> "(" ^ n ^ ":" ^ pp s l ^ ")" ^ pp t ((Some b)::l)
+ | C.Anonymous -> "(" ^ pp s l ^ "->" ^ pp t ((Some b)::l) ^ ")"
+ )
+ | C.Cast (v,t) -> "(" ^ pp v l ^ ":" ^ pp t l ^ ")"
+ | C.Lambda (b,s,t) ->
+ "(\\lambda " ^ ppname b ^ ":" ^ pp s l ^ "." ^ pp t ((Some b)::l) ^ ")"
+ | C.LetIn (b,s,t) ->
+ "[" ^ ppname b ^ ":=" ^ pp s l ^ "]" ^ pp t ((Some b)::l)
+ | C.Appl li ->
+ "(" ^
+ (List.fold_right
+ (fun x i -> pp x l ^ (match i with "" -> "" | _ -> " ") ^ i)
+ li ""
+ ) ^ ")"
+ | C.Const (uri,exp_named_subst) ->
+ UriManager.name_of_uri uri ^ pp_exp_named_subst exp_named_subst l
+ | C.MutInd (uri,n,exp_named_subst) ->
+ (try
+ match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with
+ C.InductiveDefinition (dl,_,_,_) ->
+ let (name,_,_,_) = get_nth dl (n+1) in
+ name ^ pp_exp_named_subst exp_named_subst l
+ | _ -> raise CicPpInternalError
+ with
+ _ -> UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n + 1)
+ )
+ | C.MutConstruct (uri,n1,n2,exp_named_subst) ->
+ (try
+ match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with
+ C.InductiveDefinition (dl,_,_,_) ->
+ let (_,_,_,cons) = get_nth dl (n1+1) in
+ let (id,_) = get_nth cons n2 in
+ id ^ pp_exp_named_subst exp_named_subst l
+ | _ -> raise CicPpInternalError
+ with
+ _ ->
+ UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n1 + 1) ^ "/" ^
+ string_of_int n2
+ )
+ | C.MutCase (uri,n1,ty,te,patterns) ->
+ let connames =
+ (match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with
+ C.InductiveDefinition (dl,_,_,_) ->
+ let (_,_,_,cons) = get_nth dl (n1+1) in
+ List.map (fun (id,_) -> id) cons
+ | _ -> raise CicPpInternalError
+ )
+ in
+ let connames_and_patterns =
+ let rec combine =
+ function
+ [],[] -> []
+ | [],l -> List.map (fun x -> "???",Some x) l
+ | l,[] -> List.map (fun x -> x,None) l
+ | x::tlx,y::tly -> (x,Some y)::(combine (tlx,tly))
+ in
+ combine (connames,patterns)
+ in
+ "\n<" ^ pp ty l ^ ">Cases " ^ pp te l ^ " of " ^
+ List.fold_right
+ (fun (x,y) i -> "\n " ^ x ^ " => " ^
+ (match y with None -> "" | Some y -> pp y l) ^ i)
+ connames_and_patterns "" ^
+ "\nend"
+ | C.Fix (no, funs) ->
+ let snames = List.map (fun (name,_,_,_) -> name) funs in
+ let names =
+ List.rev (List.map (function name -> Some (C.Name name)) snames)
+ in
+ "\nFix " ^ get_nth snames (no + 1) ^ " {" ^
+ List.fold_right
+ (fun (name,ind,ty,bo) i -> "\n" ^ name ^ " / " ^ string_of_int ind ^
+ " : " ^ pp ty l ^ " := \n" ^
+ pp bo (names@l) ^ i)
+ funs "" ^
+ "}\n"
+ | C.CoFix (no,funs) ->
+ let snames = List.map (fun (name,_,_) -> name) funs in
+ let names =
+ List.rev (List.map (function name -> Some (C.Name name)) snames)
+ in
+ "\nCoFix " ^ get_nth snames (no + 1) ^ " {" ^
+ List.fold_right
+ (fun (name,ty,bo) i -> "\n" ^ name ^
+ " : " ^ pp ty l ^ " := \n" ^
+ pp bo (names@l) ^ i)
+ funs "" ^
+ "}\n"
+and pp_exp_named_subst exp_named_subst l =
+ if exp_named_subst = [] then "" else
+ "\\subst[" ^
+ String.concat " ; " (
+ List.map
+ (function (uri,t) -> UriManager.name_of_uri uri ^ " \\Assign " ^ pp t l)
+ exp_named_subst
+ ) ^ "]"
+;;
+
+let ppterm t =
+ pp t []
+;;
+
+(* ppinductiveType (typename, inductive, arity, cons) *)
+(* pretty-prints a single inductive definition *)
+(* (typename, inductive, arity, cons) *)
+let ppinductiveType (typename, inductive, arity, cons) =
+ (if inductive then "\nInductive " else "\nCoInductive ") ^ typename ^ ": " ^
+ pp arity [] ^ " =\n " ^
+ List.fold_right
+ (fun (id,ty) i -> id ^ " : " ^ pp ty [] ^
+ (if i = "" then "\n" else "\n | ") ^ i)
+ cons ""
+;;
+
+let ppcontext ?(sep = "\n") context =
+ let separate s = if s = "" then "" else s ^ sep in
+ fst (List.fold_right
+ (fun context_entry (i,name_context) ->
+ match context_entry with
+ Some (n,Cic.Decl t) ->
+ Printf.sprintf "%s%s : %s" (separate i) (ppname n)
+ (pp t name_context), (Some n)::name_context
+ | Some (n,Cic.Def (bo,ty)) ->
+ Printf.sprintf "%s%s : %s := %s" (separate i) (ppname n)
+ (match ty with
+ None -> "_"
+ | Some ty -> pp ty name_context)
+ (pp bo name_context), (Some n)::name_context
+ | None ->
+ Printf.sprintf "%s_ :? _" (separate i), None::name_context
+ ) context ("",[]))
+
+(* ppobj obj returns a string with describing the cic object obj in a syntax *)
+(* similar to the one used by Coq *)
+let ppobj obj =
+ let module C = Cic in
+ let module U = UriManager in
+ match obj with
+ C.Constant (name, Some t1, t2, params, _) ->
+ "Definition of " ^ name ^
+ "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^
+ ")" ^ ":\n" ^ pp t1 [] ^ " : " ^ pp t2 []
+ | C.Constant (name, None, ty, params, _) ->
+ "Axiom " ^ name ^
+ "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^
+ "):\n" ^ pp ty []
+ | C.Variable (name, bo, ty, params, _) ->
+ "Variable " ^ name ^
+ "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^
+ ")" ^ ":\n" ^
+ pp ty [] ^ "\n" ^
+ (match bo with None -> "" | Some bo -> ":= " ^ pp bo [])
+ | C.CurrentProof (name, conjectures, value, ty, params, _) ->
+ "Current Proof of " ^ name ^
+ "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^
+ ")" ^ ":\n" ^
+ let separate s = if s = "" then "" else s ^ " ; " in
+ List.fold_right
+ (fun (n, context, t) i ->
+ let conjectures',name_context =
+ List.fold_right
+ (fun context_entry (i,name_context) ->
+ (match context_entry with
+ Some (n,C.Decl at) ->
+ (separate i) ^
+ ppname n ^ ":" ^ pp at name_context ^ " ",
+ (Some n)::name_context
+ | Some (n,C.Def (at,None)) ->
+ (separate i) ^
+ ppname n ^ ":= " ^ pp at name_context ^ " ",
+ (Some n)::name_context
+ | None ->
+ (separate i) ^ "_ :? _ ", None::name_context
+ | _ -> assert false)
+ ) context ("",[])
+ in
+ conjectures' ^ " |- " ^ "?" ^ (string_of_int n) ^ ": " ^
+ pp t name_context ^ "\n" ^ i
+ ) conjectures "" ^
+ "\n" ^ pp value [] ^ " : " ^ pp ty []
+ | C.InductiveDefinition (l, params, nparams, _) ->
+ "Parameters = " ^
+ String.concat ";" (List.map UriManager.string_of_uri params) ^ "\n" ^
+ "NParams = " ^ string_of_int nparams ^ "\n" ^
+ List.fold_right (fun x i -> ppinductiveType x ^ i) l ""
+;;
+
+let ppsort = function
+ | Cic.Prop -> "Prop"
+ | Cic.Set -> "Set"
+ | Cic.Type _ -> "Type"
+ | Cic.CProp -> "CProp"
+
+
+(* MATITA NAMING CONVENTION *)
+
+let is_prefix prefix string =
+ let len = String.length prefix in
+ let len1 = String.length string in
+ if len <= len1 then
+ begin
+ let head = String.sub string 0 len in
+ if
+ (String.compare (String.lowercase head) (String.lowercase prefix)=0) then
+ begin
+ let diff = len1-len in
+ let tail = String.sub string len diff in
+ if ((diff > 0) && (String.rcontains_from tail 0 '_')) then
+ Some (String.sub tail 1 (diff-1))
+ else Some tail
+ end
+ else None
+ end
+ else None
+
+let remove_prefix prefix (last,string) =
+ if prefix="append" then
+ begin
+ prerr_endline last;
+ prerr_endline string;
+ end;
+ if string = "" then (last,string)
+ else
+ match is_prefix prefix string with
+ None ->
+ if last <> "" then
+ match is_prefix last prefix with
+ None -> (last,string)
+ | Some _ ->
+ (match is_prefix prefix (last^string) with
+ None -> (last,string)
+ | Some tail -> (prefix,tail))
+ else (last,string)
+ | Some tail -> (prefix, tail)
+
+let legal_suffix string =
+ if string = "" then true else
+ begin
+ let legal_s = Str.regexp "_?\\([0-9]+\\|r\\|l\\|'\\|\"\\)" in
+ (Str.string_match legal_s string 0) && (Str.matched_string string = string)
+ end
+
+(** check if a prefix of string_name is legal for term and returns the tail.
+ chec_rec cannot fail: at worst it return string_name.
+ The algorithm is greedy, but last contains the last name matched, providing
+ a one slot buffer.
+ string_name is here a pair (last,string_name).*)
+
+let rec check_rec ctx string_name =
+ function
+ | Cic.Rel m ->
+ (match List.nth ctx (m-1) with
+ Cic.Name name ->
+ remove_prefix name string_name
+ | Cic.Anonymous -> string_name)
+ | Cic.Meta _ -> string_name
+ | Cic.Sort sort -> remove_prefix (ppsort sort) string_name
+ | Cic.Implicit _ -> string_name
+ | Cic.Cast (te,ty) -> check_rec ctx string_name te
+ | Cic.Prod (name,so,dest) ->
+ let l_string_name = check_rec ctx string_name so in
+ check_rec (name::ctx) string_name dest
+ | Cic.Lambda (name,so,dest) ->
+ let string_name =
+ match name with
+ Cic.Anonymous -> string_name
+ | Cic.Name name -> remove_prefix name string_name in
+ let l_string_name = check_rec ctx string_name so in
+ check_rec (name::ctx) l_string_name dest
+ | Cic.LetIn (name,so,dest) ->
+ let string_name = check_rec ctx string_name so in
+ check_rec (name::ctx) string_name dest
+ | Cic.Appl l ->
+ List.fold_left (check_rec ctx) string_name l
+ | Cic.Var (uri,exp_named_subst) ->
+ let name = UriManager.name_of_uri uri in
+ remove_prefix name string_name
+ | Cic.Const (uri,exp_named_subst) ->
+ let name = UriManager.name_of_uri uri in
+ remove_prefix name string_name
+ | Cic.MutInd (uri,_,exp_named_subst) ->
+ let name = UriManager.name_of_uri uri in
+ remove_prefix name string_name
+ | Cic.MutConstruct (uri,n,m,exp_named_subst) ->
+ let name =
+ (match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with
+ Cic.InductiveDefinition (dl,_,_,_) ->
+ let (_,_,_,cons) = get_nth dl (n+1) in
+ let (id,_) = get_nth cons m in
+ id
+ | _ -> assert false) in
+ remove_prefix name string_name
+ | Cic.MutCase (_,_,_,te,pl) ->
+ let strig_name = remove_prefix "match" string_name in
+ let string_name = check_rec ctx string_name te in
+ List.fold_right (fun t s -> check_rec ctx s t) pl string_name
+ | Cic.Fix (_,fl) ->
+ let strig_name = remove_prefix "fix" string_name in
+ let names = List.map (fun (name,_,_,_) -> name) fl in
+ let onames =
+ List.rev (List.map (function name -> Cic.Name name) names)
+ in
+ List.fold_right
+ (fun (_,_,_,bo) s -> check_rec (onames@ctx) s bo) fl string_name
+ | Cic.CoFix (_,fl) ->
+ let strig_name = remove_prefix "cofix" string_name in
+ let names = List.map (fun (name,_,_) -> name) fl in
+ let onames =
+ List.rev (List.map (function name -> Cic.Name name) names)
+ in
+ List.fold_right
+ (fun (_,_,bo) s -> check_rec (onames@ctx) s bo) fl string_name
+
+let check_name ?(allow_suffix=false) ctx name term =
+ let (_,tail) = check_rec ctx ("",name) term in
+ if (not allow_suffix) then (String.length tail = 0)
+ else legal_suffix tail
+
+let check_elim ctx conclusion_name =
+ let elim = Str.regexp "_elim\\|_case" in
+ if (Str.string_match elim conclusion_name 0) then
+ let len = String.length conclusion_name in
+ let tail = String.sub conclusion_name 5 (len-5) in
+ legal_suffix tail
+ else false
+
+let rec check_names ctx hyp_names conclusion_name t =
+ match t with
+ | Cic.Prod (name,s,t) ->
+ (match hyp_names with
+ [] -> check_names (name::ctx) hyp_names conclusion_name t
+ | hd::tl ->
+ if check_name ctx hd s then
+ check_names (name::ctx) tl conclusion_name t
+ else
+ check_names (name::ctx) hyp_names conclusion_name t)
+ | Cic.Appl ((Cic.Rel n)::args) ->
+ (match hyp_names with
+ | [] ->
+ (check_name ~allow_suffix:true ctx conclusion_name t) ||
+ (check_elim ctx conclusion_name)
+ | [what_to_elim] ->
+ (* what to elim could be an argument
+ of the predicate: e.g. leb_elim *)
+ let (last,tail) =
+ List.fold_left (check_rec ctx) ("",what_to_elim) args in
+ (tail = "" && check_elim ctx conclusion_name)
+ | _ -> false)
+ | Cic.MutCase (_,_,Cic.Lambda(name,so,ty),te,_) ->
+ (match hyp_names with
+ | [] ->
+ (match is_prefix "match" conclusion_name with
+ None -> check_name ~allow_suffix:true ctx conclusion_name t
+ | Some tail -> check_name ~allow_suffix:true ctx tail t)
+ | [what_to_match] ->
+ (* what to match could be the term te or its type so; in this case the
+ conclusion name should match ty *)
+ check_name ~allow_suffix:true (name::ctx) conclusion_name ty &&
+ (check_name ctx what_to_match te || check_name ctx what_to_match so)
+ | _ -> false)
+ | _ ->
+ hyp_names=[] && check_name ~allow_suffix:true ctx conclusion_name t
+
+let check name term =
+(* prerr_endline name;
+ prerr_endline (ppterm term); *)
+ let names = Str.split (Str.regexp_string "_to_") name in
+ let hyp_names,conclusion_name =
+ match List.rev names with
+ [] -> assert false
+ | hd::tl ->
+ let elim = Str.regexp "_elim\\|_case" in
+ let len = String.length hd in
+ try
+ let pos = Str.search_backward elim hd len in
+ let hyp = String.sub hd 0 pos in
+ let concl = String.sub hd pos (len-pos) in
+ List.rev (hyp::tl),concl
+ with Not_found -> (List.rev tl),hd in
+ check_names [] hyp_names conclusion_name term
+;;
+
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*****************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+(* TODO unify exceptions *)
+
+exception WrongUriToInductiveDefinition;;
+exception Impossible of int;;
+exception ReferenceToConstant;;
+exception ReferenceToVariable;;
+exception ReferenceToCurrentProof;;
+exception ReferenceToInductiveDefinition;;
+
+let debug = false
+let profile = false
+let debug_print s = if debug then prerr_endline (Lazy.force s)
+
+let fdebug = ref 1;;
+let debug t env s =
+ let rec debug_aux t i =
+ let module C = Cic in
+ let module U = UriManager in
+ CicPp.ppobj (C.Variable ("DEBUG", None, t, [], [])) ^ "\n" ^ i
+ in
+ if !fdebug = 0 then
+ debug_print (lazy (s ^ "\n" ^ List.fold_right debug_aux (t::env) ""))
+;;
+
+module type Strategy =
+ sig
+ type stack_term
+ type env_term
+ type ens_term
+ type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
+ val to_env : config -> env_term
+ val to_ens : config -> ens_term
+ val from_stack : stack_term -> config
+ val from_stack_list_for_unwind :
+ unwind: (config -> Cic.term) ->
+ stack_term list -> Cic.term list
+ val from_env : env_term -> config
+ val from_env_for_unwind :
+ unwind: (config -> Cic.term) ->
+ env_term -> Cic.term
+ val from_ens : ens_term -> config
+ val from_ens_for_unwind :
+ unwind: (config -> Cic.term) ->
+ ens_term -> Cic.term
+ val stack_to_env :
+ reduce: (config -> config) ->
+ unwind: (config -> Cic.term) ->
+ stack_term -> env_term
+ val compute_to_env :
+ reduce: (config -> config) ->
+ unwind: (config -> Cic.term) ->
+ int -> env_term list -> ens_term Cic.explicit_named_substitution ->
+ Cic.term -> env_term
+ val compute_to_stack :
+ reduce: (config -> config) ->
+ unwind: (config -> Cic.term) ->
+ config -> stack_term
+ end
+;;
+
+module CallByValueByNameForUnwind =
+ struct
+ type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
+ and stack_term = config
+ and env_term = config * config (* cbv, cbn *)
+ and ens_term = config * config (* cbv, cbn *)
+
+ let to_env c = c,c
+ let to_ens c = c,c
+ let from_stack config = config
+ let from_stack_list_for_unwind ~unwind l = List.map unwind l
+ let from_env (c,_) = c
+ let from_ens (c,_) = c
+ let from_env_for_unwind ~unwind (_,c) = unwind c
+ let from_ens_for_unwind ~unwind (_,c) = unwind c
+ let stack_to_env ~reduce ~unwind config = reduce config, (0,[],[],unwind config,[])
+ let compute_to_env ~reduce ~unwind k e ens t = (k,e,ens,t,[]), (k,e,ens,t,[])
+ let compute_to_stack ~reduce ~unwind config = config
+ end
+;;
+
+
+module CallByNameStrategy =
+ struct
+ type stack_term = Cic.term
+ type env_term = Cic.term
+ type ens_term = Cic.term
+ type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
+ let to_env v = v
+ let to_ens v = v
+ let from_stack ~unwind v = v
+ let from_stack_list ~unwind l = l
+ let from_env v = v
+ let from_ens v = v
+ let from_env_for_unwind ~unwind v = v
+ let from_ens_for_unwind ~unwind v = v
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens t = unwind k e ens t
+ let compute_to_env ~reduce ~unwind k e ens t = unwind k e ens t
+ end
+;;
+
+module CallByValueStrategy =
+ struct
+ type stack_term = Cic.term
+ type env_term = Cic.term
+ type ens_term = Cic.term
+ type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
+ let to_env v = v
+ let to_ens v = v
+ let from_stack ~unwind v = v
+ let from_stack_list ~unwind l = l
+ let from_env v = v
+ let from_ens v = v
+ let from_env_for_unwind ~unwind v = v
+ let from_ens_for_unwind ~unwind v = v
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens t = reduce (k,e,ens,t,[])
+ let compute_to_env ~reduce ~unwind k e ens t = reduce (k,e,ens,t,[])
+ end
+;;
+
+module CallByValueStrategyByNameOnConstants =
+ struct
+ type stack_term = Cic.term
+ type env_term = Cic.term
+ type ens_term = Cic.term
+ type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
+ let to_env v = v
+ let to_ens v = v
+ let from_stack ~unwind v = v
+ let from_stack_list ~unwind l = l
+ let from_env v = v
+ let from_ens v = v
+ let from_env_for_unwind ~unwind v = v
+ let from_ens_for_unwind ~unwind v = v
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens =
+ function
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[])
+ let compute_to_env ~reduce ~unwind k e ens =
+ function
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[])
+ end
+;;
+
+module LazyCallByValueStrategy =
+ struct
+ type stack_term = Cic.term lazy_t
+ type env_term = Cic.term lazy_t
+ type ens_term = Cic.term lazy_t
+ type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
+ let to_env v = lazy v
+ let to_ens v = lazy v
+ let from_stack ~unwind v = Lazy.force v
+ let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
+ let from_env v = Lazy.force v
+ let from_ens v = Lazy.force v
+ let from_env_for_unwind ~unwind v = Lazy.force v
+ let from_ens_for_unwind ~unwind v = Lazy.force v
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens t = lazy (reduce (k,e,ens,t,[]))
+ let compute_to_env ~reduce ~unwind k e ens t = lazy (reduce (k,e,ens,t,[]))
+ end
+;;
+
+module LazyCallByValueStrategyByNameOnConstants =
+ struct
+ type stack_term = Cic.term lazy_t
+ type env_term = Cic.term lazy_t
+ type ens_term = Cic.term lazy_t
+ type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
+ let to_env v = lazy v
+ let to_ens v = lazy v
+ let from_stack ~unwind v = Lazy.force v
+ let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
+ let from_env v = Lazy.force v
+ let from_ens v = Lazy.force v
+ let from_env_for_unwind ~unwind v = Lazy.force v
+ let from_ens_for_unwind ~unwind v = Lazy.force v
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens t =
+ lazy (
+ match t with
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[]))
+ let compute_to_env ~reduce ~unwind k e ens t =
+ lazy (
+ match t with
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[]))
+ end
+;;
+
+module LazyCallByNameStrategy =
+ struct
+ type stack_term = Cic.term lazy_t
+ type env_term = Cic.term lazy_t
+ type ens_term = Cic.term lazy_t
+ type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
+ let to_env v = lazy v
+ let to_ens v = lazy v
+ let from_stack ~unwind v = Lazy.force v
+ let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
+ let from_env v = Lazy.force v
+ let from_ens v = Lazy.force v
+ let from_env_for_unwind ~unwind v = Lazy.force v
+ let from_ens_for_unwind ~unwind v = Lazy.force v
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens t = lazy (unwind k e ens t)
+ let compute_to_env ~reduce ~unwind k e ens t = lazy (unwind k e ens t)
+ end
+;;
+
+module
+ LazyCallByValueByNameOnConstantsWhenFromStack_ByNameStrategyWhenFromEnvOrEns
+=
+ struct
+ type stack_term = reduce:bool -> Cic.term
+ type env_term = reduce:bool -> Cic.term
+ type ens_term = reduce:bool -> Cic.term
+ type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
+ let to_env v =
+ let value = lazy v in
+ fun ~reduce -> Lazy.force value
+ let to_ens v =
+ let value = lazy v in
+ fun ~reduce -> Lazy.force value
+ let from_stack ~unwind v = (v ~reduce:false)
+ let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
+ let from_env v = (v ~reduce:true)
+ let from_ens v = (v ~reduce:true)
+ let from_env_for_unwind ~unwind v = (v ~reduce:true)
+ let from_ens_for_unwind ~unwind v = (v ~reduce:true)
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens t =
+ let svalue =
+ lazy (
+ match t with
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[])
+ ) in
+ let lvalue =
+ lazy (unwind k e ens t)
+ in
+ fun ~reduce ->
+ if reduce then Lazy.force svalue else Lazy.force lvalue
+ let compute_to_env ~reduce ~unwind k e ens t =
+ let svalue =
+ lazy (
+ match t with
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[])
+ ) in
+ let lvalue =
+ lazy (unwind k e ens t)
+ in
+ fun ~reduce ->
+ if reduce then Lazy.force svalue else Lazy.force lvalue
+ end
+;;
+
+module ClosuresOnStackByValueFromEnvOrEnsStrategy =
+ struct
+ type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
+ and stack_term = config
+ and env_term = config
+ and ens_term = config
+
+ let to_env config = config
+ let to_ens config = config
+ let from_stack config = config
+ let from_stack_list_for_unwind ~unwind l = List.map unwind l
+ let from_env v = v
+ let from_ens v = v
+ let from_env_for_unwind ~unwind config = unwind config
+ let from_ens_for_unwind ~unwind config = unwind config
+ let stack_to_env ~reduce ~unwind config = reduce config
+ let compute_to_env ~reduce ~unwind k e ens t = (k,e,ens,t,[])
+ let compute_to_stack ~reduce ~unwind config = config
+ end
+;;
+
+module ClosuresOnStackByValueFromEnvOrEnsByNameOnConstantsStrategy =
+ struct
+ type stack_term =
+ int * Cic.term list * Cic.term Cic.explicit_named_substitution * Cic.term
+ type env_term = Cic.term
+ type ens_term = Cic.term
+ type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list
+ let to_env v = v
+ let to_ens v = v
+ let from_stack ~unwind (k,e,ens,t) = unwind k e ens t
+ let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
+ let from_env v = v
+ let from_ens v = v
+ let from_env_for_unwind ~unwind v = v
+ let from_ens_for_unwind ~unwind v = v
+ let stack_to_env ~reduce ~unwind (k,e,ens,t) =
+ match t with
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[])
+ let compute_to_env ~reduce ~unwind k e ens t =
+ unwind k e ens t
+ let compute_to_stack ~reduce ~unwind k e ens t = (k,e,ens,t)
+ end
+;;
+
+module Reduction(RS : Strategy) =
+ struct
+ type env = RS.env_term list
+ type ens = RS.ens_term Cic.explicit_named_substitution
+ type stack = RS.stack_term list
+ type config = int * env * ens * Cic.term * stack
+
+ (* k is the length of the environment e *)
+ (* m is the current depth inside the term *)
+ let rec unwind' m k e ens t =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ if k = 0 && ens = [] then
+ t
+ else
+ let rec unwind_aux m =
+ function
+ C.Rel n as t ->
+ if n <= m then t else
+ let d =
+ try
+ Some (RS.from_env_for_unwind ~unwind (List.nth e (n-m-1)))
+ with _ -> None
+ in
+ (match d with
+ Some t' ->
+ if m = 0 then t' else S.lift m t'
+ | None -> C.Rel (n-k)
+ )
+ | C.Var (uri,exp_named_subst) ->
+(*
+debug_print (lazy ("%%%%%UWVAR " ^ String.concat " ; " (List.map (function (uri,t) -> UriManager.string_of_uri uri ^ " := " ^ CicPp.ppterm t) ens))) ;
+*)
+ if List.exists (function (uri',_) -> UriManager.eq uri' uri) ens then
+ CicSubstitution.lift m (RS.from_ens_for_unwind ~unwind (List.assq uri ens))
+ else
+ let params =
+ let o,_ =
+ CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
+ in
+ (match o with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.Variable (_,_,_,params,_) -> params
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ in
+ let exp_named_subst' =
+ substaux_in_exp_named_subst params exp_named_subst m
+ in
+ C.Var (uri,exp_named_subst')
+ | C.Meta (i,l) ->
+ let l' =
+ List.map
+ (function
+ None -> None
+ | Some t -> Some (unwind_aux m t)
+ ) l
+ in
+ C.Meta (i, l')
+ | C.Sort _ as t -> t
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) -> C.Cast (unwind_aux m te, unwind_aux m ty) (*CSC ???*)
+ | C.Prod (n,s,t) -> C.Prod (n, unwind_aux m s, unwind_aux (m + 1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, unwind_aux m s, unwind_aux (m + 1) t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, unwind_aux m s, unwind_aux (m + 1) t)
+ | C.Appl l -> C.Appl (List.map (unwind_aux m) l)
+ | C.Const (uri,exp_named_subst) ->
+ let params =
+ let o,_ =
+ CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
+ in
+ (match o with
+ C.Constant (_,_,_,params,_) -> params
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof (_,_,_,_,params,_) -> params
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ in
+ let exp_named_subst' =
+ substaux_in_exp_named_subst params exp_named_subst m
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let params =
+ let o,_ =
+ CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
+ in
+ (match o with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition (_,params,_,_) -> params
+ )
+ in
+ let exp_named_subst' =
+ substaux_in_exp_named_subst params exp_named_subst m
+ in
+ C.MutInd (uri,i,exp_named_subst')
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let params =
+ let o,_ =
+ CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
+ in
+ (match o with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition (_,params,_,_) -> params
+ )
+ in
+ let exp_named_subst' =
+ substaux_in_exp_named_subst params exp_named_subst m
+ in
+ C.MutConstruct (uri,i,j,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,unwind_aux m outt, unwind_aux m t,
+ List.map (unwind_aux m) pl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) ->
+ (name, i, unwind_aux m ty, unwind_aux (m+len) bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) -> (name, unwind_aux m ty, unwind_aux (m+len) bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ and substaux_in_exp_named_subst params exp_named_subst' m =
+ (*CSC: Idea di Andrea di ordinare compatibilmente con l'ordine dei params
+ let ens' =
+ List.map (function (uri,t) -> uri, unwind_aux m t) exp_named_subst' @
+ (*CSC: qui liftiamo tutti gli ens anche se magari me ne servono la meta'!!! *)
+ List.map (function (uri,t) -> uri, CicSubstitution.lift m t) ens
+ in
+ let rec filter_and_lift =
+ function
+ [] -> []
+ | uri::tl ->
+ let r = filter_and_lift tl in
+ (try
+ (uri,(List.assq uri ens'))::r
+ with
+ Not_found -> r
+ )
+ in
+ filter_and_lift params
+ *)
+
+ (*CSC: invece di concatenare sarebbe meglio rispettare l'ordine dei params *)
+ (*CSC: e' vero???? una veloce prova non sembra confermare la teoria *)
+
+ (*CSC: codice copiato e modificato dalla cicSubstitution.subst_vars *)
+ (*CSC: codice altamente inefficiente *)
+ let rec filter_and_lift already_instantiated =
+ function
+ [] -> []
+ | (uri,t)::tl when
+ List.for_all
+ (function (uri',_)-> not (UriManager.eq uri uri')) exp_named_subst'
+ &&
+ not (List.mem uri already_instantiated)
+ &&
+ List.mem uri params
+ ->
+ (uri,CicSubstitution.lift m (RS.from_ens_for_unwind ~unwind t)) ::
+ (filter_and_lift (uri::already_instantiated) tl)
+ | _::tl -> filter_and_lift already_instantiated tl
+(*
+ | (uri,_)::tl ->
+debug_print (lazy ("---- SKIPPO " ^ UriManager.string_of_uri uri)) ;
+if List.for_all (function (uri',_) -> not (UriManager.eq uri uri'))
+exp_named_subst' then debug_print (lazy "---- OK1") ;
+debug_print (lazy ("++++ uri " ^ UriManager.string_of_uri uri ^ " not in " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ;
+if List.mem uri params then debug_print (lazy "---- OK2") ;
+ filter_and_lift tl
+*)
+ in
+ List.map (function (uri,t) -> uri, unwind_aux m t) exp_named_subst' @
+ (filter_and_lift [] (List.rev ens))
+ in
+ unwind_aux m t
+
+ and unwind (k,e,ens,t,s) =
+ let t' = unwind' 0 k e ens t in
+ if s = [] then t' else Cic.Appl (t'::(RS.from_stack_list_for_unwind ~unwind s))
+ ;;
+
+(*
+ let unwind =
+ let profiler_unwind = HExtlib.profile ~enable:profile "are_convertible.unwind" in
+ fun k e ens t ->
+ profiler_unwind.HExtlib.profile (unwind k e ens) t
+ ;;
+*)
+
+ let reduce ~delta ?(subst = []) context : config -> config =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let rec reduce =
+ function
+ (k, e, _, C.Rel n, s) as config ->
+ let config' =
+ try
+ Some (RS.from_env (List.nth e (n-1)))
+ with
+ Failure _ ->
+ try
+ begin
+ match List.nth context (n - 1 - k) with
+ None -> assert false
+ | Some (_,C.Decl _) -> None
+ | Some (_,C.Def (x,_)) -> Some (0,[],[],S.lift (n - k) x,[])
+ end
+ with
+ Failure _ -> None
+ in
+ (match config' with
+ Some (k',e',ens',t',s') -> reduce (k',e',ens',t',s'@s)
+ | None -> config)
+ | (k, e, ens, C.Var (uri,exp_named_subst), s) as config ->
+ if List.exists (function (uri',_) -> UriManager.eq uri' uri) ens then
+ let (k',e',ens',t',s') = RS.from_ens (List.assq uri ens) in
+ reduce (k',e',ens',t',s'@s)
+ else
+ ( let o,_ =
+ CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
+ in
+ match o with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ | C.Variable (_,None,_,_,_) -> config
+ | C.Variable (_,Some body,_,_,_) ->
+ let ens' = push_exp_named_subst k e ens exp_named_subst in
+ reduce (0, [], ens', body, s)
+ )
+ | (k, e, ens, C.Meta (n,l), s) as config ->
+ (try
+ let (_, term,_) = CicUtil.lookup_subst n subst in
+ reduce (k, e, ens,CicSubstitution.subst_meta l term,s)
+ with CicUtil.Subst_not_found _ -> config)
+ | (_, _, _, C.Sort _, _)
+ | (_, _, _, C.Implicit _, _) as config -> config
+ | (k, e, ens, C.Cast (te,ty), s) ->
+ reduce (k, e, ens, te, s)
+ | (_, _, _, C.Prod _, _) as config -> config
+ | (_, _, _, C.Lambda _, []) as config -> config
+ | (k, e, ens, C.Lambda (_,_,t), p::s) ->
+ reduce (k+1, (RS.stack_to_env ~reduce ~unwind p)::e, ens, t,s)
+ | (k, e, ens, C.LetIn (_,m,t), s) ->
+ let m' = RS.compute_to_env ~reduce ~unwind k e ens m in
+ reduce (k+1, m'::e, ens, t, s)
+ | (_, _, _, C.Appl [], _) -> assert false
+ | (k, e, ens, C.Appl (he::tl), s) ->
+ let tl' =
+ List.map
+ (function t -> RS.compute_to_stack ~reduce ~unwind (k,e,ens,t,[])) tl
+ in
+ reduce (k, e, ens, he, (List.append tl') s)
+ | (_, _, _, C.Const _, _) as config when delta=false-> config
+ | (k, e, ens, C.Const (uri,exp_named_subst), s) as config ->
+ (let o,_ =
+ CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
+ in
+ match o with
+ C.Constant (_,Some body,_,_,_) ->
+ let ens' = push_exp_named_subst k e ens exp_named_subst in
+ (* constants are closed *)
+ reduce (0, [], ens', body, s)
+ | C.Constant (_,None,_,_,_) -> config
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof (_,_,body,_,_,_) ->
+ let ens' = push_exp_named_subst k e ens exp_named_subst in
+ (* constants are closed *)
+ reduce (0, [], ens', body, s)
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ | (_, _, _, C.MutInd _, _)
+ | (_, _, _, C.MutConstruct _, _) as config -> config
+ | (k, e, ens, C.MutCase (mutind,i,outty,term,pl),s) as config ->
+ let decofix =
+ function
+ (k, e, ens, C.CoFix (i,fl), s) ->
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ reduce (k,e,ens,body',s)
+ | config -> config
+ in
+ (match decofix (reduce (k,e,ens,term,[])) with
+ (k', e', ens', C.MutConstruct (_,_,j,_), []) ->
+ reduce (k, e, ens, (List.nth pl (j-1)), [])
+ | (k', e', ens', C.MutConstruct (_,_,j,_), s') ->
+ let (arity, r) =
+ let o,_ =
+ CicEnvironment.get_cooked_obj CicUniv.empty_ugraph mutind
+ in
+ match o with
+ C.InductiveDefinition (s,ingredients,r,_) ->
+ let (_,_,arity,_) = List.nth s i in
+ (arity,r)
+ | _ -> raise WrongUriToInductiveDefinition
+ in
+ let ts =
+ let num_to_eat = r in
+ let rec eat_first =
+ function
+ (0,l) -> l
+ | (n,he::s) when n > 0 -> eat_first (n - 1, s)
+ | _ -> raise (Impossible 5)
+ in
+ eat_first (num_to_eat,s')
+ in
+ reduce (k, e, ens, (List.nth pl (j-1)), ts@s)
+ | (_, _, _, C.Cast _, _)
+ | (_, _, _, C.Implicit _, _) ->
+ raise (Impossible 2) (* we don't trust our whd ;-) *)
+ | config' ->
+ (*CSC: here I am unwinding the configuration and for sure I
+ will do it twice; to avoid this unwinding I should push the
+ "match [] with _" continuation on the stack;
+ another possibility is to just return the original configuration,
+ partially undoing the weak-head computation *)
+ (*this code is uncorrect since term' lives in e' <> e
+ let term' = unwind config' in
+ (k, e, ens, C.MutCase (mutind,i,outty,term',pl),s)
+ *)
+ config)
+ | (k, e, ens, C.Fix (i,fl), s) as config ->
+ let (_,recindex,_,body) = List.nth fl i in
+ let recparam =
+ try
+ Some (RS.from_stack (List.nth s recindex))
+ with
+ _ -> None
+ in
+ (match recparam with
+ Some recparam ->
+ (match reduce recparam with
+ (_,_,_,C.MutConstruct _,_) as config ->
+ let leng = List.length fl in
+ let new_env =
+ let counter = ref 0 in
+ let rec build_env e =
+ if !counter = leng then e
+ else
+ (incr counter ;
+ build_env
+ ((RS.to_env (k,e,ens,C.Fix (!counter -1, fl),[]))::e))
+ in
+ build_env e
+ in
+ let rec replace i s t =
+ match i,s with
+ 0,_::tl -> t::tl
+ | n,he::tl -> he::(replace (n - 1) tl t)
+ | _,_ -> assert false in
+ let new_s =
+ replace recindex s (RS.compute_to_stack ~reduce ~unwind config)
+ in
+ reduce (k+leng, new_env, ens, body, new_s)
+ | _ -> config)
+ | None -> config
+ )
+ | (_,_,_,C.CoFix _,_) as config -> config
+ and push_exp_named_subst k e ens =
+ function
+ [] -> ens
+ | (uri,t)::tl ->
+ push_exp_named_subst k e ((uri,RS.to_ens (k,e,ens,t,[]))::ens) tl
+ in
+ reduce
+ ;;
+
+ let whd ?(delta=true) ?(subst=[]) context t =
+ unwind (reduce ~delta ~subst context (0, [], [], t, []))
+ ;;
+
+ end
+;;
+
+
+(* ROTTO = rompe l'unificazione poiche' riduce gli argomenti di un'applicazione
+ senza ridurre la testa
+module R = Reduction CallByNameStrategy;; OK 56.368s
+module R = Reduction CallByValueStrategy;; ROTTO
+module R = Reduction CallByValueStrategyByNameOnConstants;; ROTTO
+module R = Reduction LazyCallByValueStrategy;; ROTTO
+module R = Reduction LazyCallByValueStrategyByNameOnConstants;; ROTTO
+module R = Reduction LazyCallByNameStrategy;; OK 0m56.398s
+module R = Reduction
+ LazyCallByValueByNameOnConstantsWhenFromStack_ByNameStrategyWhenFromEnvOrEns;;
+ OK 59.058s
+module R = Reduction ClosuresOnStackByValueFromEnvOrEnsStrategy;; OK 58.583s
+module R = Reduction
+ ClosuresOnStackByValueFromEnvOrEnsByNameOnConstantsStrategy;; OK 58.094s
+module R = Reduction(ClosuresOnStackByValueFromEnvOrEnsStrategy);; OK 58.127s
+*)
+module R = Reduction(CallByValueByNameForUnwind);;
+(*module R = Reduction(ClosuresOnStackByValueFromEnvOrEnsStrategy);;*)
+module U = UriManager;;
+
+let whd = R.whd
+
+(*
+let whd =
+ let profiler_whd = HExtlib.profile ~enable:profile "are_convertible.whd" in
+ fun ?(delta=true) ?(subst=[]) context t ->
+ profiler_whd.HExtlib.profile (whd ~delta ~subst context) t
+*)
+
+ (* mimic ocaml (<< 3.08) "=" behaviour. Tests physical equality first then
+ * fallbacks to structural equality *)
+let (===) x y =
+ Pervasives.compare x y = 0
+
+(* t1, t2 must be well-typed *)
+let are_convertible whd ?(subst=[]) ?(metasenv=[]) =
+ let rec aux test_equality_only context t1 t2 ugraph =
+ let aux2 test_equality_only t1 t2 ugraph =
+
+ (* this trivial euristic cuts down the total time of about five times ;-) *)
+ (* this because most of the time t1 and t2 are "sintactically" the same *)
+ if t1 === t2 then
+ true,ugraph
+ else
+ begin
+ let module C = Cic in
+ match (t1,t2) with
+ (C.Rel n1, C.Rel n2) -> (n1 = n2),ugraph
+ | (C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2)) ->
+ if U.eq uri1 uri2 then
+ (try
+ List.fold_right2
+ (fun (uri1,x) (uri2,y) (b,ugraph) ->
+ let b',ugraph' = aux test_equality_only context x y ugraph in
+ (U.eq uri1 uri2 && b' && b),ugraph'
+ ) exp_named_subst1 exp_named_subst2 (true,ugraph)
+ with
+ Invalid_argument _ -> false,ugraph
+ )
+ else
+ false,ugraph
+ | (C.Meta (n1,l1), C.Meta (n2,l2)) ->
+ if n1 = n2 then
+ let b2, ugraph1 =
+ let l1 = CicUtil.clean_up_local_context subst metasenv n1 l1 in
+ let l2 = CicUtil.clean_up_local_context subst metasenv n2 l2 in
+ List.fold_left2
+ (fun (b,ugraph) t1 t2 ->
+ if b then
+ match t1,t2 with
+ None,_
+ | _,None -> true,ugraph
+ | Some t1',Some t2' ->
+ aux test_equality_only context t1' t2' ugraph
+ else
+ false,ugraph
+ ) (true,ugraph) l1 l2
+ in
+ if b2 then true,ugraph1 else false,ugraph
+ else
+ false,ugraph
+ (* TASSI: CONSTRAINTS *)
+ | (C.Sort (C.Type t1), C.Sort (C.Type t2)) when test_equality_only ->
+ true,(CicUniv.add_eq t2 t1 ugraph)
+ (* TASSI: CONSTRAINTS *)
+ | (C.Sort (C.Type t1), C.Sort (C.Type t2)) ->
+ true,(CicUniv.add_ge t2 t1 ugraph)
+ (* TASSI: CONSTRAINTS *)
+ | (C.Sort s1, C.Sort (C.Type _)) -> (not test_equality_only),ugraph
+ (* TASSI: CONSTRAINTS *)
+ | (C.Sort s1, C.Sort s2) -> (s1 = s2),ugraph
+ | (C.Prod (name1,s1,t1), C.Prod(_,s2,t2)) ->
+ let b',ugraph' = aux true context s1 s2 ugraph in
+ if b' then
+ aux test_equality_only ((Some (name1, (C.Decl s1)))::context)
+ t1 t2 ugraph'
+ else
+ false,ugraph
+ | (C.Lambda (name1,s1,t1), C.Lambda(_,s2,t2)) ->
+ let b',ugraph' = aux test_equality_only context s1 s2 ugraph in
+ if b' then
+ aux test_equality_only ((Some (name1, (C.Decl s1)))::context)
+ t1 t2 ugraph'
+ else
+ false,ugraph
+ | (C.LetIn (name1,s1,t1), C.LetIn(_,s2,t2)) ->
+ let b',ugraph' = aux test_equality_only context s1 s2 ugraph in
+ if b' then
+ aux test_equality_only
+ ((Some (name1, (C.Def (s1,None))))::context) t1 t2 ugraph'
+ else
+ false,ugraph
+ | (C.Appl l1, C.Appl l2) ->
+ (try
+ List.fold_right2
+ (fun x y (b,ugraph) ->
+ if b then
+ aux test_equality_only context x y ugraph
+ else
+ false,ugraph) l1 l2 (true,ugraph)
+ with
+ Invalid_argument _ -> false,ugraph
+ )
+ | (C.Const (uri1,exp_named_subst1), C.Const (uri2,exp_named_subst2)) ->
+ let b' = U.eq uri1 uri2 in
+ if b' then
+ (try
+ List.fold_right2
+ (fun (uri1,x) (uri2,y) (b,ugraph) ->
+ if b && U.eq uri1 uri2 then
+ aux test_equality_only context x y ugraph
+ else
+ false,ugraph
+ ) exp_named_subst1 exp_named_subst2 (true,ugraph)
+ with
+ Invalid_argument _ -> false,ugraph
+ )
+ else
+ false,ugraph
+ | (C.MutInd (uri1,i1,exp_named_subst1),
+ C.MutInd (uri2,i2,exp_named_subst2)
+ ) ->
+ let b' = U.eq uri1 uri2 && i1 = i2 in
+ if b' then
+ (try
+ List.fold_right2
+ (fun (uri1,x) (uri2,y) (b,ugraph) ->
+ if b && U.eq uri1 uri2 then
+ aux test_equality_only context x y ugraph
+ else
+ false,ugraph
+ ) exp_named_subst1 exp_named_subst2 (true,ugraph)
+ with
+ Invalid_argument _ -> false,ugraph
+ )
+ else
+ false,ugraph
+ | (C.MutConstruct (uri1,i1,j1,exp_named_subst1),
+ C.MutConstruct (uri2,i2,j2,exp_named_subst2)
+ ) ->
+ let b' = U.eq uri1 uri2 && i1 = i2 && j1 = j2 in
+ if b' then
+ (try
+ List.fold_right2
+ (fun (uri1,x) (uri2,y) (b,ugraph) ->
+ if b && U.eq uri1 uri2 then
+ aux test_equality_only context x y ugraph
+ else
+ false,ugraph
+ ) exp_named_subst1 exp_named_subst2 (true,ugraph)
+ with
+ Invalid_argument _ -> false,ugraph
+ )
+ else
+ false,ugraph
+ | (C.MutCase (uri1,i1,outtype1,term1,pl1),
+ C.MutCase (uri2,i2,outtype2,term2,pl2)) ->
+ let b' = U.eq uri1 uri2 && i1 = i2 in
+ if b' then
+ let b'',ugraph''=aux test_equality_only context
+ outtype1 outtype2 ugraph in
+ if b'' then
+ let b''',ugraph'''= aux test_equality_only context
+ term1 term2 ugraph'' in
+ List.fold_right2
+ (fun x y (b,ugraph) ->
+ if b then
+ aux test_equality_only context x y ugraph
+ else
+ false,ugraph)
+ pl1 pl2 (b''',ugraph''')
+ else
+ false,ugraph
+ else
+ false,ugraph
+ | (C.Fix (i1,fl1), C.Fix (i2,fl2)) ->
+ let tys =
+ List.map (function (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl1
+ in
+ if i1 = i2 then
+ List.fold_right2
+ (fun (_,recindex1,ty1,bo1) (_,recindex2,ty2,bo2) (b,ugraph) ->
+ if b && recindex1 = recindex2 then
+ let b',ugraph' = aux test_equality_only context ty1 ty2
+ ugraph in
+ if b' then
+ aux test_equality_only (tys@context) bo1 bo2 ugraph'
+ else
+ false,ugraph
+ else
+ false,ugraph)
+ fl1 fl2 (true,ugraph)
+ else
+ false,ugraph
+ | (C.CoFix (i1,fl1), C.CoFix (i2,fl2)) ->
+ let tys =
+ List.map (function (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl1
+ in
+ if i1 = i2 then
+ List.fold_right2
+ (fun (_,ty1,bo1) (_,ty2,bo2) (b,ugraph) ->
+ if b then
+ let b',ugraph' = aux test_equality_only context ty1 ty2
+ ugraph in
+ if b' then
+ aux test_equality_only (tys@context) bo1 bo2 ugraph'
+ else
+ false,ugraph
+ else
+ false,ugraph)
+ fl1 fl2 (true,ugraph)
+ else
+ false,ugraph
+ | (C.Cast _, _) | (_, C.Cast _)
+ | (C.Implicit _, _) | (_, C.Implicit _) -> assert false
+ | (_,_) -> false,ugraph
+ end
+ in
+ debug t1 [t2] "PREWHD";
+ let t1' = whd ?delta:(Some true) ?subst:(Some subst) context t1 in
+ let t2' = whd ?delta:(Some true) ?subst:(Some subst) context t2 in
+ debug t1' [t2'] "POSTWHD";
+ aux2 test_equality_only t1' t2' ugraph
+ in
+ aux false (*c t1 t2 ugraph *)
+;;
+
+(* DEBUGGING ONLY
+let whd ?(delta=true) ?(subst=[]) context t =
+ let res = whd ~delta ~subst context t in
+ let rescsc = CicReductionNaif.whd ~delta ~subst context t in
+ if not (fst (are_convertible CicReductionNaif.whd ~subst context res rescsc CicUniv.empty_ugraph)) then
+ begin
+ debug_print (lazy ("PRIMA: " ^ CicPp.ppterm t)) ;
+ flush stderr ;
+ debug_print (lazy ("DOPO: " ^ CicPp.ppterm res)) ;
+ flush stderr ;
+ debug_print (lazy ("CSC: " ^ CicPp.ppterm rescsc)) ;
+ flush stderr ;
+fdebug := 0 ;
+let _ = are_convertible CicReductionNaif.whd ~subst context res rescsc CicUniv.empty_ugraph in
+ assert false ;
+ end
+ else
+ res
+;;
+*)
+
+let are_convertible = are_convertible whd
+
+let whd = R.whd
+
+(*
+let profiler_other_whd = HExtlib.profile ~enable:profile "~are_convertible.whd"
+let whd ?(delta=true) ?(subst=[]) context t =
+ let foo () =
+ whd ~delta ~subst context t
+ in
+ profiler_other_whd.HExtlib.profile foo ()
+*)
+
+let rec normalize ?(delta=true) ?(subst=[]) ctx term =
+ let module C = Cic in
+ let t = whd ~delta ~subst ctx term in
+ let aux = normalize ~delta ~subst in
+ let decl name t = Some (name, C.Decl t) in
+ match t with
+ | C.Rel n -> t
+ | C.Var (uri,exp_named_subst) ->
+ C.Var (uri, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst)
+ | C.Meta (i,l) ->
+ C.Meta (i,List.map (function Some t -> Some (aux ctx t) | None -> None) l)
+ | C.Sort _ -> t
+ | C.Implicit _ -> t
+ | C.Cast (te,ty) -> C.Cast (aux ctx te, aux ctx ty)
+ | C.Prod (n,s,t) ->
+ let s' = aux ctx s in
+ C.Prod (n, s', aux ((decl n s')::ctx) t)
+ | C.Lambda (n,s,t) ->
+ let s' = aux ctx s in
+ C.Lambda (n, s', aux ((decl n s')::ctx) t)
+ | C.LetIn (n,s,t) ->
+ (* the term is already in weak head normal form *)
+ assert false
+ | C.Appl (h::l) -> C.Appl (h::(List.map (aux ctx) l))
+ | C.Appl [] -> assert false
+ | C.Const (uri,exp_named_subst) ->
+ C.Const (uri, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst)
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ C.MutInd (uri,typeno, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst)
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ C.MutConstruct (uri, typeno, consno,
+ List.map (fun (n,t) -> n,aux ctx t) exp_named_subst)
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i, aux ctx outt, aux ctx t, List.map (aux ctx) pl)
+(*CSC: to be completed, I suppose *)
+ | C.Fix _ -> t
+ | C.CoFix _ -> t
+
+let normalize ?delta ?subst ctx term =
+(* prerr_endline ("NORMALIZE:" ^ CicPp.ppterm term); *)
+ let t = normalize ?delta ?subst ctx term in
+(* prerr_endline ("NORMALIZED:" ^ CicPp.ppterm t); *)
+ t
+
+
+(* performs an head beta/cast reduction *)
+let rec head_beta_reduce =
+ function
+ (Cic.Appl (Cic.Lambda (_,_,t)::he'::tl')) ->
+ let he'' = CicSubstitution.subst he' t in
+ if tl' = [] then
+ he''
+ else
+ let he''' =
+ match he'' with
+ Cic.Appl l -> Cic.Appl (l@tl')
+ | _ -> Cic.Appl (he''::tl')
+ in
+ head_beta_reduce he'''
+ | Cic.Cast (te,_) -> head_beta_reduce te
+ | t -> t
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception 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
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+exception CannotSubstInMeta;;
+exception RelToHiddenHypothesis;;
+exception ReferenceToVariable;;
+exception ReferenceToConstant;;
+exception ReferenceToCurrentProof;;
+exception ReferenceToInductiveDefinition;;
+
+let debug_print = fun _ -> ()
+
+let lift_from k n =
+ let rec liftaux k =
+ let module C = Cic in
+ function
+ C.Rel m ->
+ if m < k then
+ C.Rel m
+ else
+ C.Rel (m + n)
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
+ | C.Meta (i,l) ->
+ let l' =
+ List.map
+ (function
+ None -> None
+ | Some t -> Some (liftaux k t)
+ ) l
+ in
+ C.Meta(i,l')
+ | C.Sort _ as t -> t
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) -> C.Cast (liftaux k te, liftaux k ty)
+ | C.Prod (n,s,t) -> C.Prod (n, liftaux k s, liftaux (k+1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, liftaux k s, liftaux (k+1) t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, liftaux k s, liftaux (k+1) t)
+ | C.Appl l -> C.Appl (List.map (liftaux k) l)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,tyno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
+ in
+ C.MutInd (uri,tyno,exp_named_subst')
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
+ in
+ C.MutConstruct (uri,tyno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outty,t,pl) ->
+ C.MutCase (sp, i, liftaux k outty, liftaux k t,
+ List.map (liftaux k) pl)
+ | C.Fix (i, fl) ->
+ let len = List.length fl in
+ let liftedfl =
+ List.map
+ (fun (name, i, ty, bo) -> (name, i, liftaux k ty, liftaux (k+len) bo))
+ fl
+ in
+ C.Fix (i, liftedfl)
+ | C.CoFix (i, fl) ->
+ let len = List.length fl in
+ let liftedfl =
+ List.map
+ (fun (name, ty, bo) -> (name, liftaux k ty, liftaux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, liftedfl)
+ in
+ liftaux k
+
+let lift n t =
+ if n = 0 then
+ t
+ else
+ lift_from 1 n t
+;;
+
+let subst arg =
+ let rec substaux k =
+ let module C = Cic in
+ function
+ C.Rel n as t ->
+ (match n with
+ n when n = k -> lift (k - 1) arg
+ | n when n < k -> t
+ | _ -> C.Rel (n - 1)
+ )
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
+ | C.Meta (i, l) ->
+ let l' =
+ List.map
+ (function
+ None -> None
+ | Some t -> Some (substaux k t)
+ ) l
+ in
+ C.Meta(i,l')
+ | C.Sort _ as t -> t
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
+ | C.Prod (n,s,t) -> C.Prod (n, substaux k s, substaux (k + 1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, substaux k s, substaux (k + 1) t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, substaux k s, substaux (k + 1) t)
+ | C.Appl (he::tl) ->
+ (* Invariant: no Appl applied to another Appl *)
+ let tl' = List.map (substaux k) tl in
+ begin
+ match substaux k he with
+ C.Appl l -> C.Appl (l@tl')
+ | _ as he' -> C.Appl (he'::tl')
+ end
+ | C.Appl _ -> assert false
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst
+ in
+ C.MutInd (uri,typeno,exp_named_subst')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,substaux k outt, substaux k t,
+ List.map (substaux k) pl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) -> (name, i, substaux k ty, substaux (k+len) bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) -> (name, substaux k ty, substaux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ in
+ substaux 1
+;;
+
+(*CSC: i controlli di tipo debbono essere svolti da destra a *)
+(*CSC: sinistra: i{B/A;b/a} ==> a{B/A;b/a} ==> a{b/a{B/A}} ==> b *)
+(*CSC: la sostituzione ora e' implementata in maniera simultanea, ma *)
+(*CSC: dovrebbe diventare da sinistra verso destra: *)
+(*CSC: t{a=a/A;b/a} ==> \H:a=a.H{b/a} ==> \H:b=b.H *)
+(*CSC: per la roba che proviene da Coq questo non serve! *)
+let subst_vars exp_named_subst t =
+(*
+debug_print (lazy ("@@@POSSIBLE BUG: SUBSTITUTION IS NOT SIMULTANEOUS")) ;
+*)
+ let rec substaux k =
+ let module C = Cic in
+ function
+ C.Rel _ as t -> t
+ | C.Var (uri,exp_named_subst') ->
+ (try
+ let (_,arg) =
+ List.find
+ (function (varuri,_) -> UriManager.eq uri varuri) exp_named_subst
+ in
+ lift (k -1) arg
+ with
+ Not_found ->
+ let params =
+ let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ (match obj with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.Variable (_,_,_,params,_) -> params
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ in
+(*
+debug_print (lazy "\n\n---- BEGIN ") ;
+debug_print (lazy ("----params: " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ;
+debug_print (lazy ("----S(" ^ UriManager.string_of_uri uri ^ "): " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst))) ;
+debug_print (lazy ("----P: " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst'))) ;
+*)
+ let exp_named_subst'' =
+ substaux_in_exp_named_subst uri k exp_named_subst' params
+ in
+(*
+debug_print (lazy ("----D: " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst''))) ;
+debug_print (lazy "---- END\n\n ") ;
+*)
+ C.Var (uri,exp_named_subst'')
+ )
+ | C.Meta (i, l) ->
+ let l' =
+ List.map
+ (function
+ None -> None
+ | Some t -> Some (substaux k t)
+ ) l
+ in
+ C.Meta(i,l')
+ | C.Sort _ as t -> t
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
+ | C.Prod (n,s,t) -> C.Prod (n, substaux k s, substaux (k + 1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, substaux k s, substaux (k + 1) t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, substaux k s, substaux (k + 1) t)
+ | C.Appl (he::tl) ->
+ (* Invariant: no Appl applied to another Appl *)
+ let tl' = List.map (substaux k) tl in
+ begin
+ match substaux k he with
+ C.Appl l -> C.Appl (l@tl')
+ | _ as he' -> C.Appl (he'::tl')
+ end
+ | C.Appl _ -> assert false
+ | C.Const (uri,exp_named_subst') ->
+ let params =
+ let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ (match obj with
+ C.Constant (_,_,_,params,_) -> params
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof (_,_,_,_,params,_) -> params
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ in
+ let exp_named_subst'' =
+ substaux_in_exp_named_subst uri k exp_named_subst' params
+ in
+ C.Const (uri,exp_named_subst'')
+ | C.MutInd (uri,typeno,exp_named_subst') ->
+ let params =
+ let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ (match obj with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition (_,params,_,_) -> params
+ )
+ in
+ let exp_named_subst'' =
+ substaux_in_exp_named_subst uri k exp_named_subst' params
+ in
+ C.MutInd (uri,typeno,exp_named_subst'')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst') ->
+ let params =
+ let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ (match obj with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition (_,params,_,_) -> params
+ )
+ in
+ let exp_named_subst'' =
+ substaux_in_exp_named_subst uri k exp_named_subst' params
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst'')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,substaux k outt, substaux k t,
+ List.map (substaux k) pl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) -> (name, i, substaux k ty, substaux (k+len) bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) -> (name, substaux k ty, substaux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ and substaux_in_exp_named_subst uri k exp_named_subst' params =
+(*CSC: invece di concatenare sarebbe meglio rispettare l'ordine dei params *)
+(*CSC: e' vero???? una veloce prova non sembra confermare la teoria *)
+ let rec filter_and_lift =
+ function
+ [] -> []
+ | (uri,t)::tl when
+ List.for_all
+ (function (uri',_) -> not (UriManager.eq uri uri')) exp_named_subst'
+ &&
+ List.mem uri params
+ ->
+ (uri,lift (k-1) t)::(filter_and_lift tl)
+ | _::tl -> filter_and_lift tl
+(*
+ | (uri,_)::tl ->
+debug_print (lazy ("---- SKIPPO " ^ UriManager.string_of_uri uri)) ;
+if List.for_all (function (uri',_) -> not (UriManager.eq uri uri'))
+exp_named_subst' then debug_print (lazy "---- OK1") ;
+debug_print (lazy ("++++ uri " ^ UriManager.string_of_uri uri ^ " not in " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ;
+if List.mem uri params then debug_print (lazy "---- OK2") ;
+ filter_and_lift tl
+*)
+ in
+ List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst' @
+ (filter_and_lift exp_named_subst)
+ in
+ if exp_named_subst = [] then t
+ else substaux 1 t
+;;
+
+(* subst_meta [t_1 ; ... ; t_n] t *)
+(* returns the term [t] where [Rel i] is substituted with [t_i] *)
+(* [t_i] is lifted as usual when it crosses an abstraction *)
+let subst_meta l t =
+ let module C = Cic in
+ if l = [] then t else
+ let rec aux k = function
+ C.Rel n as t ->
+ if n <= k then t else
+ (try
+ match List.nth l (n-k-1) with
+ None -> raise RelToHiddenHypothesis
+ | Some t -> lift k t
+ with
+ (Failure _) -> assert false
+ )
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
+ | C.Meta (i,l) ->
+ let l' =
+ List.map
+ (function
+ None -> None
+ | Some t ->
+ try
+ Some (aux k t)
+ with
+ RelToHiddenHypothesis -> None
+ ) l
+ in
+ C.Meta(i,l')
+ | C.Sort _ as t -> t
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty) (*CSC ??? *)
+ | C.Prod (n,s,t) -> C.Prod (n, aux k s, aux (k + 1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, aux k s, aux (k + 1) t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, aux k s, aux (k + 1) t)
+ | C.Appl l -> C.Appl (List.map (aux k) l)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.MutInd (uri,typeno,exp_named_subst')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,aux k outt, aux k t, List.map (aux k) pl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) -> (name, i, aux k ty, aux (k+len) bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) -> (name, aux k ty, aux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ in
+ aux 0 t
+;;
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception 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
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+(* TODO factorize functions to frequent errors (e.g. "Unknwon mutual inductive
+ * ...") *)
+
+open Printf
+
+exception AssertFailure of string Lazy.t;;
+exception TypeCheckerFailure of string Lazy.t;;
+
+let fdebug = ref 0;;
+let debug t context =
+ let rec debug_aux t i =
+ let module C = Cic in
+ let module U = UriManager in
+ CicPp.ppobj (C.Variable ("DEBUG", None, t, [], [])) ^ "\n" ^ i
+ in
+ if !fdebug = 0 then
+ raise (TypeCheckerFailure (lazy (List.fold_right debug_aux (t::context) "")))
+;;
+
+let debug_print = fun _ -> ();;
+
+let rec split l n =
+ match (l,n) with
+ (l,0) -> ([], l)
+ | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2)
+ | (_,_) ->
+ raise (TypeCheckerFailure (lazy "Parameters number < left parameters number"))
+;;
+
+let debrujin_constructor ?(cb=fun _ _ -> ()) uri number_of_types =
+ let rec aux k t =
+ let module C = Cic in
+ let res =
+ match t with
+ C.Rel n as t when n <= k -> t
+ | C.Rel _ ->
+ raise (TypeCheckerFailure (lazy "unbound variable found in constructor type"))
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
+ | C.Meta (i,l) ->
+ let l' = List.map (function None -> None | Some t -> Some (aux k t)) l in
+ C.Meta (i,l')
+ | C.Sort _
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty)
+ | C.Prod (n,s,t) -> C.Prod (n, aux k s, aux (k+1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, aux k s, aux (k+1) t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, aux k s, aux (k+1) t)
+ | C.Appl l -> C.Appl (List.map (aux k) l)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri',tyno,exp_named_subst) when UriManager.eq uri uri' ->
+ if exp_named_subst != [] then
+ raise (TypeCheckerFailure
+ (lazy ("non-empty explicit named substitution is applied to "^
+ "a mutual inductive type which is being defined"))) ;
+ C.Rel (k + number_of_types - tyno) ;
+ | C.MutInd (uri',tyno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.MutInd (uri',tyno,exp_named_subst')
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.MutConstruct (uri,tyno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outty,t,pl) ->
+ C.MutCase (sp, i, aux k outty, aux k t,
+ List.map (aux k) pl)
+ | C.Fix (i, fl) ->
+ let len = List.length fl in
+ let liftedfl =
+ List.map
+ (fun (name, i, ty, bo) -> (name, i, aux k ty, aux (k+len) bo))
+ fl
+ in
+ C.Fix (i, liftedfl)
+ | C.CoFix (i, fl) ->
+ let len = List.length fl in
+ let liftedfl =
+ List.map
+ (fun (name, ty, bo) -> (name, aux k ty, aux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, liftedfl)
+ in
+ cb t res;
+ res
+ in
+ aux 0
+;;
+
+exception CicEnvironmentError;;
+
+let rec type_of_constant ~logger uri ugraph =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let cobj,ugraph =
+ match CicEnvironment.is_type_checked ~trust:true ugraph uri with
+ CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph'
+ | CicEnvironment.UncheckedObj uobj ->
+ logger#log (`Start_type_checking uri) ;
+ (* let's typecheck the uncooked obj *)
+
+(****************************************************************
+ TASSI: FIXME qui e' inutile ricordarselo,
+ tanto poi lo richiediamo alla cache che da quello su disco
+*****************************************************************)
+
+ let ugraph_dust =
+ (match uobj with
+ C.Constant (_,Some te,ty,_,_) ->
+ let _,ugraph = type_of ~logger ty ugraph in
+ let type_of_te,ugraph' = type_of ~logger te ugraph in
+ let b',ugraph'' = (R.are_convertible [] type_of_te ty ugraph') in
+ if not b' then
+ raise (TypeCheckerFailure (lazy (sprintf
+ "the constant %s is not well typed because the type %s of the body is not convertible to the declared type %s"
+ (U.string_of_uri uri) (CicPp.ppterm type_of_te)
+ (CicPp.ppterm ty))))
+ else
+ ugraph'
+ | C.Constant (_,None,ty,_,_) ->
+ (* only to check that ty is well-typed *)
+ let _,ugraph' = type_of ~logger ty ugraph in
+ ugraph'
+ | C.CurrentProof (_,conjs,te,ty,_,_) ->
+ let _,ugraph1 =
+ List.fold_left
+ (fun (metasenv,ugraph) ((_,context,ty) as conj) ->
+ let _,ugraph' =
+ type_of_aux' ~logger metasenv context ty ugraph
+ in
+ (metasenv @ [conj],ugraph')
+ ) ([],ugraph) conjs
+ in
+ let _,ugraph2 = type_of_aux' ~logger conjs [] ty ugraph1 in
+ let type_of_te,ugraph3 =
+ type_of_aux' ~logger conjs [] te ugraph2
+ in
+ let b,ugraph4 = (R.are_convertible [] type_of_te ty ugraph3) in
+ if not b then
+ raise (TypeCheckerFailure (lazy (sprintf
+ "the current proof %s is not well typed because the type %s of the body is not convertible to the declared type %s"
+ (U.string_of_uri uri) (CicPp.ppterm type_of_te)
+ (CicPp.ppterm ty))))
+ else
+ ugraph4
+ | _ ->
+ raise
+ (TypeCheckerFailure (lazy ("Unknown constant:" ^ U.string_of_uri uri))))
+ in
+ try
+ CicEnvironment.set_type_checking_info uri;
+ logger#log (`Type_checking_completed uri) ;
+ match CicEnvironment.is_type_checked ~trust:false ugraph uri with
+ CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph'
+ | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError
+ with Invalid_argument s ->
+ (*debug_print (lazy s);*)
+ uobj,ugraph_dust
+ in
+ match cobj,ugraph with
+ (C.Constant (_,_,ty,_,_)),g -> ty,g
+ | (C.CurrentProof (_,_,_,ty,_,_)),g -> ty,g
+ | _ ->
+ raise (TypeCheckerFailure (lazy ("Unknown constant:" ^ U.string_of_uri uri)))
+
+and type_of_variable ~logger uri ugraph =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ (* 0 because a variable is never cooked => no partial cooking at one level *)
+ match CicEnvironment.is_type_checked ~trust:true ugraph uri with
+ CicEnvironment.CheckedObj ((C.Variable (_,_,ty,_,_)),ugraph') -> ty,ugraph'
+ | CicEnvironment.UncheckedObj (C.Variable (_,bo,ty,_,_)) ->
+ logger#log (`Start_type_checking uri) ;
+ (* only to check that ty is well-typed *)
+ let _,ugraph1 = type_of ~logger ty ugraph in
+ let ugraph2 =
+ (match bo with
+ None -> ugraph
+ | Some bo ->
+ let ty_bo,ugraph' = type_of ~logger bo ugraph1 in
+ let b,ugraph'' = (R.are_convertible [] ty_bo ty ugraph') in
+ if not b then
+ raise (TypeCheckerFailure
+ (lazy ("Unknown variable:" ^ U.string_of_uri uri)))
+ else
+ ugraph'')
+ in
+ (try
+ CicEnvironment.set_type_checking_info uri ;
+ logger#log (`Type_checking_completed uri) ;
+ match CicEnvironment.is_type_checked ~trust:false ugraph uri with
+ CicEnvironment.CheckedObj ((C.Variable (_,_,ty,_,_)),ugraph') ->
+ ty,ugraph'
+ | CicEnvironment.CheckedObj _
+ | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError
+ with Invalid_argument s ->
+ (*debug_print (lazy s);*)
+ ty,ugraph2)
+ | _ ->
+ raise (TypeCheckerFailure (lazy ("Unknown variable:" ^ U.string_of_uri uri)))
+
+and does_not_occur ?(subst=[]) context n nn te =
+ let module C = Cic in
+ (*CSC: whd sembra essere superflua perche' un caso in cui l'occorrenza *)
+ (*CSC: venga mangiata durante la whd sembra presentare problemi di *)
+ (*CSC: universi *)
+ match CicReduction.whd ~subst context te with
+ C.Rel m when m > n && m <= nn -> false
+ | C.Rel _
+ | C.Sort _
+ | C.Implicit _ -> true
+ | C.Meta (_,l) ->
+ List.fold_right
+ (fun x i ->
+ match x with
+ None -> i
+ | Some x -> i && does_not_occur ~subst context n nn x) l true
+ | C.Cast (te,ty) ->
+ does_not_occur ~subst context n nn te && does_not_occur ~subst context n nn ty
+ | C.Prod (name,so,dest) ->
+ does_not_occur ~subst context n nn so &&
+ does_not_occur ~subst ((Some (name,(C.Decl so)))::context) (n + 1)
+ (nn + 1) dest
+ | C.Lambda (name,so,dest) ->
+ does_not_occur ~subst context n nn so &&
+ does_not_occur ~subst ((Some (name,(C.Decl so)))::context) (n + 1) (nn + 1)
+ dest
+ | C.LetIn (name,so,dest) ->
+ does_not_occur ~subst context n nn so &&
+ does_not_occur ~subst ((Some (name,(C.Def (so,None))))::context)
+ (n + 1) (nn + 1) dest
+ | C.Appl l ->
+ List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) l true
+ | C.Var (_,exp_named_subst)
+ | C.Const (_,exp_named_subst)
+ | C.MutInd (_,_,exp_named_subst)
+ | C.MutConstruct (_,_,_,exp_named_subst) ->
+ List.fold_right (fun (_,x) i -> i && does_not_occur ~subst context n nn x)
+ exp_named_subst true
+ | C.MutCase (_,_,out,te,pl) ->
+ does_not_occur ~subst context n nn out && does_not_occur ~subst context n nn te &&
+ List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) pl true
+ | C.Fix (_,fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len in
+ let nn_plus_len = nn + len in
+ let tys =
+ List.map (fun (n,_,ty,_) -> Some (C.Name n,(Cic.Decl ty))) fl
+ in
+ List.fold_right
+ (fun (_,_,ty,bo) i ->
+ i && does_not_occur ~subst context n nn ty &&
+ does_not_occur ~subst (tys @ context) n_plus_len nn_plus_len bo
+ ) fl true
+ | C.CoFix (_,fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len in
+ let nn_plus_len = nn + len in
+ let tys =
+ List.map (fun (n,ty,_) -> Some (C.Name n,(Cic.Decl ty))) fl
+ in
+ List.fold_right
+ (fun (_,ty,bo) i ->
+ i && does_not_occur ~subst context n nn ty &&
+ does_not_occur ~subst (tys @ context) n_plus_len nn_plus_len bo
+ ) fl true
+
+(*CSC l'indice x dei tipi induttivi e' t.c. n < x <= nn *)
+(*CSC questa funzione e' simile alla are_all_occurrences_positive, ma fa *)
+(*CSC dei controlli leggermente diversi. Viene invocata solamente dalla *)
+(*CSC strictly_positive *)
+(*CSC definizione (giusta???) tratta dalla mail di Hugo ;-) *)
+and weakly_positive context n nn uri te =
+ let module C = Cic in
+(*CSC: Che schifo! Bisogna capire meglio e trovare una soluzione ragionevole!*)
+ let dummy_mutind =
+ C.MutInd (HelmLibraryObjects.Datatypes.nat_URI,0,[])
+ in
+ (*CSC: mettere in cicSubstitution *)
+ let rec subst_inductive_type_with_dummy_mutind =
+ function
+ C.MutInd (uri',0,_) when UriManager.eq uri' uri ->
+ dummy_mutind
+ | C.Appl ((C.MutInd (uri',0,_))::tl) when UriManager.eq uri' uri ->
+ dummy_mutind
+ | C.Cast (te,ty) -> subst_inductive_type_with_dummy_mutind te
+ | C.Prod (name,so,ta) ->
+ C.Prod (name, subst_inductive_type_with_dummy_mutind so,
+ subst_inductive_type_with_dummy_mutind ta)
+ | C.Lambda (name,so,ta) ->
+ C.Lambda (name, subst_inductive_type_with_dummy_mutind so,
+ subst_inductive_type_with_dummy_mutind ta)
+ | C.Appl tl ->
+ C.Appl (List.map subst_inductive_type_with_dummy_mutind tl)
+ | C.MutCase (uri,i,outtype,term,pl) ->
+ C.MutCase (uri,i,
+ subst_inductive_type_with_dummy_mutind outtype,
+ subst_inductive_type_with_dummy_mutind term,
+ List.map subst_inductive_type_with_dummy_mutind pl)
+ | C.Fix (i,fl) ->
+ C.Fix (i,List.map (fun (name,i,ty,bo) -> (name,i,
+ subst_inductive_type_with_dummy_mutind ty,
+ subst_inductive_type_with_dummy_mutind bo)) fl)
+ | C.CoFix (i,fl) ->
+ C.CoFix (i,List.map (fun (name,ty,bo) -> (name,
+ subst_inductive_type_with_dummy_mutind ty,
+ subst_inductive_type_with_dummy_mutind bo)) fl)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map
+ (function (uri,t) -> (uri,subst_inductive_type_with_dummy_mutind t))
+ exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map
+ (function (uri,t) -> (uri,subst_inductive_type_with_dummy_mutind t))
+ exp_named_subst
+ in
+ C.MutInd (uri,typeno,exp_named_subst')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map
+ (function (uri,t) -> (uri,subst_inductive_type_with_dummy_mutind t))
+ exp_named_subst
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst')
+ | t -> t
+ in
+ match CicReduction.whd context te with
+ C.Appl ((C.MutInd (uri',0,_))::tl) when UriManager.eq uri' uri -> true
+ | C.MutInd (uri',0,_) when UriManager.eq uri' uri -> true
+ | C.Prod (C.Anonymous,source,dest) ->
+ strictly_positive context n nn
+ (subst_inductive_type_with_dummy_mutind source) &&
+ weakly_positive ((Some (C.Anonymous,(C.Decl source)))::context)
+ (n + 1) (nn + 1) uri dest
+ | C.Prod (name,source,dest) when
+ does_not_occur ((Some (name,(C.Decl source)))::context) 0 n dest ->
+ (* dummy abstraction, so we behave as in the anonimous case *)
+ strictly_positive context n nn
+ (subst_inductive_type_with_dummy_mutind source) &&
+ weakly_positive ((Some (name,(C.Decl source)))::context)
+ (n + 1) (nn + 1) uri dest
+ | C.Prod (name,source,dest) ->
+ does_not_occur context n nn
+ (subst_inductive_type_with_dummy_mutind source)&&
+ weakly_positive ((Some (name,(C.Decl source)))::context)
+ (n + 1) (nn + 1) uri dest
+ | _ ->
+ raise (TypeCheckerFailure (lazy "Malformed inductive constructor type"))
+
+(* instantiate_parameters ps (x1:T1)...(xn:Tn)C *)
+(* returns ((x_|ps|:T_|ps|)...(xn:Tn)C){ps_1 / x1 ; ... ; ps_|ps| / x_|ps|} *)
+and instantiate_parameters params c =
+ let module C = Cic in
+ match (c,params) with
+ (c,[]) -> c
+ | (C.Prod (_,_,ta), he::tl) ->
+ instantiate_parameters tl
+ (CicSubstitution.subst he ta)
+ | (C.Cast (te,_), _) -> instantiate_parameters params te
+ | (t,l) -> raise (AssertFailure (lazy "1"))
+
+and strictly_positive context n nn te =
+ let module C = Cic in
+ let module U = UriManager in
+ match CicReduction.whd context te with
+ C.Rel _ -> true
+ | C.Cast (te,ty) ->
+ (*CSC: bisogna controllare ty????*)
+ strictly_positive context n nn te
+ | C.Prod (name,so,ta) ->
+ does_not_occur context n nn so &&
+ strictly_positive ((Some (name,(C.Decl so)))::context) (n+1) (nn+1) ta
+ | C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
+ List.fold_right (fun x i -> i && does_not_occur context n nn x) tl true
+ | C.Appl ((C.MutInd (uri,i,exp_named_subst))::tl) ->
+ let (ok,paramsno,ity,cl,name) =
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ C.InductiveDefinition (tl,_,paramsno,_) ->
+ let (name,_,ity,cl) = List.nth tl i in
+ (List.length tl = 1, paramsno, ity, cl, name)
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown inductive type:" ^ U.string_of_uri uri)))
+ in
+ let (params,arguments) = split tl paramsno in
+ let lifted_params = List.map (CicSubstitution.lift 1) params in
+ let cl' =
+ List.map
+ (fun (_,te) ->
+ instantiate_parameters lifted_params
+ (CicSubstitution.subst_vars exp_named_subst te)
+ ) cl
+ in
+ ok &&
+ List.fold_right
+ (fun x i -> i && does_not_occur context n nn x)
+ arguments true &&
+ (*CSC: MEGAPATCH3 (sara' quella giusta?)*)
+ List.fold_right
+ (fun x i ->
+ i &&
+ weakly_positive
+ ((Some (C.Name name,(Cic.Decl ity)))::context) (n+1) (nn+1) uri
+ x
+ ) cl' true
+ | t -> does_not_occur context n nn t
+
+(* the inductive type indexes are s.t. n < x <= nn *)
+and are_all_occurrences_positive context uri indparamsno i n nn te =
+ let module C = Cic in
+ match CicReduction.whd context te with
+ C.Appl ((C.Rel m)::tl) when m = i ->
+ (*CSC: riscrivere fermandosi a 0 *)
+ (* let's check if the inductive type is applied at least to *)
+ (* indparamsno parameters *)
+ let last =
+ List.fold_left
+ (fun k x ->
+ if k = 0 then 0
+ else
+ match CicReduction.whd context x with
+ C.Rel m when m = n - (indparamsno - k) -> k - 1
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy
+ ("Non-positive occurence in mutual inductive definition(s) [1]" ^
+ UriManager.string_of_uri uri)))
+ ) indparamsno tl
+ in
+ if last = 0 then
+ List.fold_right (fun x i -> i && does_not_occur context n nn x) tl true
+ else
+ raise (TypeCheckerFailure
+ (lazy ("Non-positive occurence in mutual inductive definition(s) [2]"^
+ UriManager.string_of_uri uri)))
+ | C.Rel m when m = i ->
+ if indparamsno = 0 then
+ true
+ else
+ raise (TypeCheckerFailure
+ (lazy ("Non-positive occurence in mutual inductive definition(s) [3]"^
+ UriManager.string_of_uri uri)))
+ | C.Prod (C.Anonymous,source,dest) ->
+ strictly_positive context n nn source &&
+ are_all_occurrences_positive
+ ((Some (C.Anonymous,(C.Decl source)))::context) uri indparamsno
+ (i+1) (n + 1) (nn + 1) dest
+ | C.Prod (name,source,dest) when
+ does_not_occur ((Some (name,(C.Decl source)))::context) 0 n dest ->
+ (* dummy abstraction, so we behave as in the anonimous case *)
+ strictly_positive context n nn source &&
+ are_all_occurrences_positive
+ ((Some (name,(C.Decl source)))::context) uri indparamsno
+ (i+1) (n + 1) (nn + 1) dest
+ | C.Prod (name,source,dest) ->
+ does_not_occur context n nn source &&
+ are_all_occurrences_positive ((Some (name,(C.Decl source)))::context)
+ uri indparamsno (i+1) (n + 1) (nn + 1) dest
+ | _ ->
+ raise
+ (TypeCheckerFailure (lazy ("Malformed inductive constructor type " ^
+ (UriManager.string_of_uri uri))))
+
+(* Main function to checks the correctness of a mutual *)
+(* inductive block definition. This is the function *)
+(* exported to the proof-engine. *)
+and typecheck_mutual_inductive_defs ~logger uri (itl,_,indparamsno) ugraph =
+ let module U = UriManager in
+ (* let's check if the arity of the inductive types are well *)
+ (* formed *)
+ let ugrap1 = List.fold_left
+ (fun ugraph (_,_,x,_) -> let _,ugraph' =
+ type_of ~logger x ugraph in ugraph')
+ ugraph itl in
+
+ (* let's check if the types of the inductive constructors *)
+ (* are well formed. *)
+ (* In order not to use type_of_aux we put the types of the *)
+ (* mutual inductive types at the head of the types of the *)
+ (* constructors using Prods *)
+ let len = List.length itl in
+ let tys =
+ List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) itl in
+ let _,ugraph2 =
+ List.fold_right
+ (fun (_,_,_,cl) (i,ugraph) ->
+ let ugraph'' =
+ List.fold_left
+ (fun ugraph (name,te) ->
+ let debrujinedte = debrujin_constructor uri len te in
+ let augmented_term =
+ List.fold_right
+ (fun (name,_,ty,_) i -> Cic.Prod (Cic.Name name, ty, i))
+ itl debrujinedte
+ in
+ let _,ugraph' = type_of ~logger augmented_term ugraph in
+ (* let's check also the positivity conditions *)
+ if
+ not
+ (are_all_occurrences_positive tys uri indparamsno i 0 len
+ debrujinedte)
+ then
+ raise
+ (TypeCheckerFailure
+ (lazy ("Non positive occurence in " ^ U.string_of_uri uri)))
+ else
+ ugraph'
+ ) ugraph cl in
+ (i + 1),ugraph''
+ ) itl (1,ugrap1)
+ in
+ ugraph2
+
+(* Main function to checks the correctness of a mutual *)
+(* inductive block definition. *)
+and check_mutual_inductive_defs uri obj ugraph =
+ match obj with
+ Cic.InductiveDefinition (itl, params, indparamsno, _) ->
+ typecheck_mutual_inductive_defs uri (itl,params,indparamsno) ugraph
+ | _ ->
+ raise (TypeCheckerFailure (
+ lazy ("Unknown mutual inductive definition:" ^
+ UriManager.string_of_uri uri)))
+
+and type_of_mutual_inductive_defs ~logger uri i ugraph =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let cobj,ugraph1 =
+ match CicEnvironment.is_type_checked ~trust:true ugraph uri with
+ CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph'
+ | CicEnvironment.UncheckedObj uobj ->
+ logger#log (`Start_type_checking uri) ;
+ let ugraph1_dust =
+ check_mutual_inductive_defs ~logger uri uobj ugraph
+ in
+ (* TASSI: FIXME: check ugraph1 == ugraph ritornato da env *)
+ try
+ CicEnvironment.set_type_checking_info uri ;
+ logger#log (`Type_checking_completed uri) ;
+ (match CicEnvironment.is_type_checked ~trust:false ugraph uri with
+ CicEnvironment.CheckedObj (cobj,ugraph') -> (cobj,ugraph')
+ | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError
+ )
+ with
+ Invalid_argument s ->
+ (*debug_print (lazy s);*)
+ uobj,ugraph1_dust
+ in
+ match cobj with
+ C.InductiveDefinition (dl,_,_,_) ->
+ let (_,_,arity,_) = List.nth dl i in
+ arity,ugraph1
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown mutual inductive definition:" ^ U.string_of_uri uri)))
+
+and type_of_mutual_inductive_constr ~logger uri i j ugraph =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let cobj,ugraph1 =
+ match CicEnvironment.is_type_checked ~trust:true ugraph uri with
+ CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph'
+ | CicEnvironment.UncheckedObj uobj ->
+ logger#log (`Start_type_checking uri) ;
+ let ugraph1_dust =
+ check_mutual_inductive_defs ~logger uri uobj ugraph
+ in
+ (* check ugraph1 validity ??? == ugraph' *)
+ try
+ CicEnvironment.set_type_checking_info uri ;
+ logger#log (`Type_checking_completed uri) ;
+ (match
+ CicEnvironment.is_type_checked ~trust:false ugraph uri
+ with
+ CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph'
+ | CicEnvironment.UncheckedObj _ ->
+ raise CicEnvironmentError)
+ with
+ Invalid_argument s ->
+ (*debug_print (lazy s);*)
+ uobj,ugraph1_dust
+ in
+ match cobj with
+ C.InductiveDefinition (dl,_,_,_) ->
+ let (_,_,_,cl) = List.nth dl i in
+ let (_,ty) = List.nth cl (j-1) in
+ ty,ugraph1
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown mutual inductive definition:" ^ UriManager.string_of_uri uri)))
+
+and recursive_args context n nn te =
+ let module C = Cic in
+ match CicReduction.whd context te with
+ C.Rel _ -> []
+ | C.Var _
+ | C.Meta _
+ | C.Sort _
+ | C.Implicit _
+ | C.Cast _ (*CSC ??? *) ->
+ raise (AssertFailure (lazy "3")) (* due to type-checking *)
+ | C.Prod (name,so,de) ->
+ (not (does_not_occur context n nn so)) ::
+ (recursive_args ((Some (name,(C.Decl so)))::context) (n+1) (nn + 1) de)
+ | C.Lambda _
+ | C.LetIn _ ->
+ raise (AssertFailure (lazy "4")) (* due to type-checking *)
+ | C.Appl _ -> []
+ | C.Const _ -> raise (AssertFailure (lazy "5"))
+ | C.MutInd _
+ | C.MutConstruct _
+ | C.MutCase _
+ | C.Fix _
+ | C.CoFix _ -> raise (AssertFailure (lazy "6")) (* due to type-checking *)
+
+and get_new_safes ~subst context p c rl safes n nn x =
+ let module C = Cic in
+ let module U = UriManager in
+ let module R = CicReduction in
+ match (R.whd ~subst context c, R.whd ~subst context p, rl) with
+ (C.Prod (_,so,ta1), C.Lambda (name,_,ta2), b::tl) ->
+ (* we are sure that the two sources are convertible because we *)
+ (* have just checked this. So let's go along ... *)
+ let safes' =
+ List.map (fun x -> x + 1) safes
+ in
+ let safes'' =
+ if b then 1::safes' else safes'
+ in
+ get_new_safes ~subst ((Some (name,(C.Decl so)))::context)
+ ta2 ta1 tl safes'' (n+1) (nn+1) (x+1)
+ | (C.Prod _, (C.MutConstruct _ as e), _)
+ | (C.Prod _, (C.Rel _ as e), _)
+ | (C.MutInd _, e, [])
+ | (C.Appl _, e, []) -> (e,safes,n,nn,x,context)
+ | (c,p,l) ->
+ (* CSC: If the next exception is raised, it just means that *)
+ (* CSC: the proof-assistant allows to use very strange things *)
+ (* CSC: as a branch of a case whose type is a Prod. In *)
+ (* CSC: particular, this means that a new (C.Prod, x,_) case *)
+ (* CSC: must be considered in this match. (e.g. x = MutCase) *)
+ raise
+ (AssertFailure (lazy
+ (Printf.sprintf "Get New Safes: c=%s ; p=%s"
+ (CicPp.ppterm c) (CicPp.ppterm p))))
+
+and split_prods ~subst context n te =
+ let module C = Cic in
+ let module R = CicReduction in
+ match (n, R.whd ~subst context te) with
+ (0, _) -> context,te
+ | (n, C.Prod (name,so,ta)) when n > 0 ->
+ split_prods ~subst ((Some (name,(C.Decl so)))::context) (n - 1) ta
+ | (_, _) -> raise (AssertFailure (lazy "8"))
+
+and eat_lambdas ~subst context n te =
+ let module C = Cic in
+ let module R = CicReduction in
+ match (n, R.whd ~subst context te) with
+ (0, _) -> (te, 0, context)
+ | (n, C.Lambda (name,so,ta)) when n > 0 ->
+ let (te, k, context') =
+ eat_lambdas ~subst ((Some (name,(C.Decl so)))::context) (n - 1) ta
+ in
+ (te, k + 1, context')
+ | (n, te) ->
+ raise (AssertFailure (lazy (sprintf "9 (%d, %s)" n (CicPp.ppterm te))))
+
+(*CSC: Tutto quello che segue e' l'intuzione di luca ;-) *)
+and check_is_really_smaller_arg ~subst context n nn kl x safes te =
+ (*CSC: forse la whd si puo' fare solo quando serve veramente. *)
+ (*CSC: cfr guarded_by_destructors *)
+ let module C = Cic in
+ let module U = UriManager in
+ match CicReduction.whd ~subst context te with
+ C.Rel m when List.mem m safes -> true
+ | C.Rel _ -> false
+ | C.Var _
+ | C.Meta _
+ | C.Sort _
+ | C.Implicit _
+ | C.Cast _
+(* | C.Cast (te,ty) ->
+ check_is_really_smaller_arg ~subst n nn kl x safes te &&
+ check_is_really_smaller_arg ~subst n nn kl x safes ty*)
+(* | C.Prod (_,so,ta) ->
+ check_is_really_smaller_arg ~subst n nn kl x safes so &&
+ check_is_really_smaller_arg ~subst (n+1) (nn+1) kl (x+1)
+ (List.map (fun x -> x + 1) safes) ta*)
+ | C.Prod _ -> raise (AssertFailure (lazy "10"))
+ | C.Lambda (name,so,ta) ->
+ check_is_really_smaller_arg ~subst context n nn kl x safes so &&
+ check_is_really_smaller_arg ~subst ((Some (name,(C.Decl so)))::context)
+ (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta
+ | C.LetIn (name,so,ta) ->
+ check_is_really_smaller_arg ~subst context n nn kl x safes so &&
+ check_is_really_smaller_arg ~subst ((Some (name,(C.Def (so,None))))::context)
+ (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta
+ | C.Appl (he::_) ->
+ (*CSC: sulla coda ci vogliono dei controlli? secondo noi no, ma *)
+ (*CSC: solo perche' non abbiamo trovato controesempi *)
+ check_is_really_smaller_arg ~subst context n nn kl x safes he
+ | C.Appl [] -> raise (AssertFailure (lazy "11"))
+ | C.Const _
+ | C.MutInd _ -> raise (AssertFailure (lazy "12"))
+ | C.MutConstruct _ -> false
+ | C.MutCase (uri,i,outtype,term,pl) ->
+ (match term with
+ C.Rel m when List.mem m safes || m = x ->
+ let (tys,len,isinductive,paramsno,cl) =
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ C.InductiveDefinition (tl,_,paramsno,_) ->
+ let tys =
+ List.map
+ (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) tl
+ in
+ let (_,isinductive,_,cl) = List.nth tl i in
+ let cl' =
+ List.map
+ (fun (id,ty) ->
+ (id, snd (split_prods ~subst tys paramsno ty))) cl
+ in
+ (tys,List.length tl,isinductive,paramsno,cl')
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown mutual inductive definition:" ^
+ UriManager.string_of_uri uri)))
+ in
+ if not isinductive then
+ List.fold_right
+ (fun p i ->
+ i && check_is_really_smaller_arg ~subst context n nn kl x safes p)
+ pl true
+ else
+ let pl_and_cl =
+ try
+ List.combine pl cl
+ with
+ Invalid_argument _ ->
+ raise (TypeCheckerFailure (lazy "not enough patterns"))
+ in
+ List.fold_right
+ (fun (p,(_,c)) i ->
+ let rl' =
+ let debrujinedte = debrujin_constructor uri len c in
+ recursive_args tys 0 len debrujinedte
+ in
+ let (e,safes',n',nn',x',context') =
+ get_new_safes ~subst context p c rl' safes n nn x
+ in
+ i &&
+ check_is_really_smaller_arg ~subst context' n' nn' kl x' safes' e
+ ) pl_and_cl true
+ | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x ->
+ let (tys,len,isinductive,paramsno,cl) =
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ C.InductiveDefinition (tl,_,paramsno,_) ->
+ let (_,isinductive,_,cl) = List.nth tl i in
+ let tys =
+ List.map (fun (n,_,ty,_) ->
+ Some(Cic.Name n,(Cic.Decl ty))) tl
+ in
+ let cl' =
+ List.map
+ (fun (id,ty) ->
+ (id, snd (split_prods ~subst tys paramsno ty))) cl
+ in
+ (tys,List.length tl,isinductive,paramsno,cl')
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown mutual inductive definition:" ^
+ UriManager.string_of_uri uri)))
+ in
+ if not isinductive then
+ List.fold_right
+ (fun p i ->
+ i && check_is_really_smaller_arg ~subst context n nn kl x safes p)
+ pl true
+ else
+ let pl_and_cl =
+ try
+ List.combine pl cl
+ with
+ Invalid_argument _ ->
+ raise (TypeCheckerFailure (lazy "not enough patterns"))
+ in
+ (*CSC: supponiamo come prima che nessun controllo sia necessario*)
+ (*CSC: sugli argomenti di una applicazione *)
+ List.fold_right
+ (fun (p,(_,c)) i ->
+ let rl' =
+ let debrujinedte = debrujin_constructor uri len c in
+ recursive_args tys 0 len debrujinedte
+ in
+ let (e, safes',n',nn',x',context') =
+ get_new_safes ~subst context p c rl' safes n nn x
+ in
+ i &&
+ check_is_really_smaller_arg ~subst context' n' nn' kl x' safes' e
+ ) pl_and_cl true
+ | _ ->
+ List.fold_right
+ (fun p i ->
+ i && check_is_really_smaller_arg ~subst context n nn kl x safes p
+ ) pl true
+ )
+ | C.Fix (_, fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len
+ and x_plus_len = x + len
+ and tys = List.map (fun (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl
+ and safes' = List.map (fun x -> x + len) safes in
+ List.fold_right
+ (fun (_,_,ty,bo) i ->
+ i &&
+ check_is_really_smaller_arg ~subst (tys@context) n_plus_len nn_plus_len kl
+ x_plus_len safes' bo
+ ) fl true
+ | C.CoFix (_, fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len
+ and x_plus_len = x + len
+ and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl
+ and safes' = List.map (fun x -> x + len) safes in
+ List.fold_right
+ (fun (_,ty,bo) i ->
+ i &&
+ check_is_really_smaller_arg ~subst (tys@context) n_plus_len nn_plus_len kl
+ x_plus_len safes' bo
+ ) fl true
+
+and guarded_by_destructors ~subst context n nn kl x safes =
+ let module C = Cic in
+ let module U = UriManager in
+ function
+ C.Rel m when m > n && m <= nn -> false
+ | C.Rel m ->
+ (match List.nth context (n-1) with
+ Some (_,C.Decl _) -> true
+ | Some (_,C.Def (bo,_)) ->
+ guarded_by_destructors ~subst context m nn kl x safes
+ (CicSubstitution.lift m bo)
+ | None -> raise (TypeCheckerFailure (lazy "Reference to deleted hypothesis"))
+ )
+ | C.Meta _
+ | C.Sort _
+ | C.Implicit _ -> true
+ | C.Cast (te,ty) ->
+ guarded_by_destructors ~subst context n nn kl x safes te &&
+ guarded_by_destructors ~subst context n nn kl x safes ty
+ | C.Prod (name,so,ta) ->
+ guarded_by_destructors ~subst context n nn kl x safes so &&
+ guarded_by_destructors ~subst ((Some (name,(C.Decl so)))::context)
+ (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta
+ | C.Lambda (name,so,ta) ->
+ guarded_by_destructors ~subst context n nn kl x safes so &&
+ guarded_by_destructors ~subst ((Some (name,(C.Decl so)))::context)
+ (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta
+ | C.LetIn (name,so,ta) ->
+ guarded_by_destructors ~subst context n nn kl x safes so &&
+ guarded_by_destructors ~subst ((Some (name,(C.Def (so,None))))::context)
+ (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta
+ | C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
+ let k = List.nth kl (m - n - 1) in
+ if not (List.length tl > k) then false
+ else
+ List.fold_right
+ (fun param i ->
+ i && guarded_by_destructors ~subst context n nn kl x safes param
+ ) tl true &&
+ check_is_really_smaller_arg ~subst context n nn kl x safes (List.nth tl k)
+ | C.Appl tl ->
+ List.fold_right
+ (fun t i -> i && guarded_by_destructors ~subst context n nn kl x safes t)
+ tl true
+ | C.Var (_,exp_named_subst)
+ | C.Const (_,exp_named_subst)
+ | C.MutInd (_,_,exp_named_subst)
+ | C.MutConstruct (_,_,_,exp_named_subst) ->
+ List.fold_right
+ (fun (_,t) i -> i && guarded_by_destructors ~subst context n nn kl x safes t)
+ exp_named_subst true
+ | C.MutCase (uri,i,outtype,term,pl) ->
+ (match CicReduction.whd ~subst context term with
+ C.Rel m when List.mem m safes || m = x ->
+ let (tys,len,isinductive,paramsno,cl) =
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ C.InductiveDefinition (tl,_,paramsno,_) ->
+ let len = List.length tl in
+ let (_,isinductive,_,cl) = List.nth tl i in
+ let tys =
+ List.map (fun (n,_,ty,_) ->
+ Some(Cic.Name n,(Cic.Decl ty))) tl
+ in
+ let cl' =
+ List.map
+ (fun (id,ty) ->
+ let debrujinedty = debrujin_constructor uri len ty in
+ (id, snd (split_prods ~subst tys paramsno ty),
+ snd (split_prods ~subst tys paramsno debrujinedty)
+ )) cl
+ in
+ (tys,len,isinductive,paramsno,cl')
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown mutual inductive definition:" ^
+ UriManager.string_of_uri uri)))
+ in
+ if not isinductive then
+ guarded_by_destructors ~subst context n nn kl x safes outtype &&
+ guarded_by_destructors ~subst context n nn kl x safes term &&
+ (*CSC: manca ??? il controllo sul tipo di term? *)
+ List.fold_right
+ (fun p i ->
+ i && guarded_by_destructors ~subst context n nn kl x safes p)
+ pl true
+ else
+ let pl_and_cl =
+ try
+ List.combine pl cl
+ with
+ Invalid_argument _ ->
+ raise (TypeCheckerFailure (lazy "not enough patterns"))
+ in
+ guarded_by_destructors ~subst context n nn kl x safes outtype &&
+ (*CSC: manca ??? il controllo sul tipo di term? *)
+ List.fold_right
+ (fun (p,(_,c,brujinedc)) i ->
+ let rl' = recursive_args tys 0 len brujinedc in
+ let (e,safes',n',nn',x',context') =
+ get_new_safes ~subst context p c rl' safes n nn x
+ in
+ i &&
+ guarded_by_destructors ~subst context' n' nn' kl x' safes' e
+ ) pl_and_cl true
+ | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x ->
+ let (tys,len,isinductive,paramsno,cl) =
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ C.InductiveDefinition (tl,_,paramsno,_) ->
+ let (_,isinductive,_,cl) = List.nth tl i in
+ let tys =
+ List.map
+ (fun (n,_,ty,_) -> Some(Cic.Name n,(Cic.Decl ty))) tl
+ in
+ let cl' =
+ List.map
+ (fun (id,ty) ->
+ (id, snd (split_prods ~subst tys paramsno ty))) cl
+ in
+ (tys,List.length tl,isinductive,paramsno,cl')
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown mutual inductive definition:" ^
+ UriManager.string_of_uri uri)))
+ in
+ if not isinductive then
+ guarded_by_destructors ~subst context n nn kl x safes outtype &&
+ guarded_by_destructors ~subst context n nn kl x safes term &&
+ (*CSC: manca ??? il controllo sul tipo di term? *)
+ List.fold_right
+ (fun p i ->
+ i && guarded_by_destructors ~subst context n nn kl x safes p)
+ pl true
+ else
+ let pl_and_cl =
+ try
+ List.combine pl cl
+ with
+ Invalid_argument _ ->
+ raise (TypeCheckerFailure (lazy "not enough patterns"))
+ in
+ guarded_by_destructors ~subst context n nn kl x safes outtype &&
+ (*CSC: manca ??? il controllo sul tipo di term? *)
+ List.fold_right
+ (fun t i ->
+ i && guarded_by_destructors ~subst context n nn kl x safes t)
+ tl true &&
+ List.fold_right
+ (fun (p,(_,c)) i ->
+ let rl' =
+ let debrujinedte = debrujin_constructor uri len c in
+ recursive_args tys 0 len debrujinedte
+ in
+ let (e, safes',n',nn',x',context') =
+ get_new_safes ~subst context p c rl' safes n nn x
+ in
+ i &&
+ guarded_by_destructors ~subst context' n' nn' kl x' safes' e
+ ) pl_and_cl true
+ | _ ->
+ guarded_by_destructors ~subst context n nn kl x safes outtype &&
+ guarded_by_destructors ~subst context n nn kl x safes term &&
+ (*CSC: manca ??? il controllo sul tipo di term? *)
+ List.fold_right
+ (fun p i -> i && guarded_by_destructors ~subst context n nn kl x safes p)
+ pl true
+ )
+ | C.Fix (_, fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len
+ and x_plus_len = x + len
+ and tys = List.map (fun (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl
+ and safes' = List.map (fun x -> x + len) safes in
+ List.fold_right
+ (fun (_,_,ty,bo) i ->
+ i && guarded_by_destructors ~subst context n nn kl x_plus_len safes' ty &&
+ guarded_by_destructors ~subst (tys@context) n_plus_len nn_plus_len kl
+ x_plus_len safes' bo
+ ) fl true
+ | C.CoFix (_, fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len
+ and x_plus_len = x + len
+ and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl
+ and safes' = List.map (fun x -> x + len) safes in
+ List.fold_right
+ (fun (_,ty,bo) i ->
+ i &&
+ guarded_by_destructors ~subst context n nn kl x_plus_len safes' ty &&
+ guarded_by_destructors ~subst (tys@context) n_plus_len nn_plus_len kl
+ x_plus_len safes' bo
+ ) fl true
+
+(* the boolean h means already protected *)
+(* args is the list of arguments the type of the constructor that may be *)
+(* found in head position must be applied to. *)
+and guarded_by_constructors ~subst context n nn h te args coInductiveTypeURI =
+ let module C = Cic in
+ (*CSC: There is a lot of code replication between the cases X and *)
+ (*CSC: (C.Appl X tl). Maybe it will be better to define a function *)
+ (*CSC: that maps X into (C.Appl X []) when X is not already a C.Appl *)
+ match CicReduction.whd ~subst context te with
+ C.Rel m when m > n && m <= nn -> h
+ | C.Rel _ -> true
+ | C.Meta _
+ | C.Sort _
+ | C.Implicit _
+ | C.Cast _
+ | C.Prod _
+ | C.LetIn _ ->
+ (* the term has just been type-checked *)
+ raise (AssertFailure (lazy "17"))
+ | C.Lambda (name,so,de) ->
+ does_not_occur ~subst context n nn so &&
+ guarded_by_constructors ~subst ((Some (name,(C.Decl so)))::context)
+ (n + 1) (nn + 1) h de args coInductiveTypeURI
+ | C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
+ h &&
+ List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) tl true
+ | C.Appl ((C.MutConstruct (uri,i,j,exp_named_subst))::tl) ->
+ let consty =
+ let obj,_ =
+ try
+ CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri
+ with Not_found -> assert false
+ in
+ match obj with
+ C.InductiveDefinition (itl,_,_,_) ->
+ let (_,_,_,cl) = List.nth itl i in
+ let (_,cons) = List.nth cl (j - 1) in
+ CicSubstitution.subst_vars exp_named_subst cons
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown mutual inductive definition:" ^ UriManager.string_of_uri uri)))
+ in
+ let rec analyse_branch context ty te =
+ match CicReduction.whd ~subst context ty with
+ C.Meta _ -> raise (AssertFailure (lazy "34"))
+ | C.Rel _
+ | C.Var _
+ | C.Sort _ ->
+ does_not_occur ~subst context n nn te
+ | C.Implicit _
+ | C.Cast _ ->
+ raise (AssertFailure (lazy "24"))(* due to type-checking *)
+ | C.Prod (name,so,de) ->
+ analyse_branch ((Some (name,(C.Decl so)))::context) de te
+ | C.Lambda _
+ | C.LetIn _ ->
+ raise (AssertFailure (lazy "25"))(* due to type-checking *)
+ | C.Appl ((C.MutInd (uri,_,_))::_) when uri == coInductiveTypeURI ->
+ guarded_by_constructors ~subst context n nn true te []
+ coInductiveTypeURI
+ | C.Appl ((C.MutInd (uri,_,_))::_) ->
+ guarded_by_constructors ~subst context n nn true te tl
+ coInductiveTypeURI
+ | C.Appl _ ->
+ does_not_occur ~subst context n nn te
+ | C.Const _ -> raise (AssertFailure (lazy "26"))
+ | C.MutInd (uri,_,_) when uri == coInductiveTypeURI ->
+ guarded_by_constructors ~subst context n nn true te []
+ coInductiveTypeURI
+ | C.MutInd _ ->
+ does_not_occur ~subst context n nn te
+ | C.MutConstruct _ -> raise (AssertFailure (lazy "27"))
+ (*CSC: we do not consider backbones with a MutCase, Fix, Cofix *)
+ (*CSC: in head position. *)
+ | C.MutCase _
+ | C.Fix _
+ | C.CoFix _ ->
+ raise (AssertFailure (lazy "28"))(* due to type-checking *)
+ in
+ let rec analyse_instantiated_type context ty l =
+ match CicReduction.whd ~subst context ty with
+ C.Rel _
+ | C.Var _
+ | C.Meta _
+ | C.Sort _
+ | C.Implicit _
+ | C.Cast _ -> raise (AssertFailure (lazy "29"))(* due to type-checking *)
+ | C.Prod (name,so,de) ->
+ begin
+ match l with
+ [] -> true
+ | he::tl ->
+ analyse_branch context so he &&
+ analyse_instantiated_type
+ ((Some (name,(C.Decl so)))::context) de tl
+ end
+ | C.Lambda _
+ | C.LetIn _ ->
+ raise (AssertFailure (lazy "30"))(* due to type-checking *)
+ | C.Appl _ ->
+ List.fold_left
+ (fun i x -> i && does_not_occur ~subst context n nn x) true l
+ | C.Const _ -> raise (AssertFailure (lazy "31"))
+ | C.MutInd _ ->
+ List.fold_left
+ (fun i x -> i && does_not_occur ~subst context n nn x) true l
+ | C.MutConstruct _ -> raise (AssertFailure (lazy "32"))
+ (*CSC: we do not consider backbones with a MutCase, Fix, Cofix *)
+ (*CSC: in head position. *)
+ | C.MutCase _
+ | C.Fix _
+ | C.CoFix _ ->
+ raise (AssertFailure (lazy "33"))(* due to type-checking *)
+ in
+ let rec instantiate_type args consty =
+ function
+ [] -> true
+ | tlhe::tltl as l ->
+ let consty' = CicReduction.whd ~subst context consty in
+ match args with
+ he::tl ->
+ begin
+ match consty' with
+ C.Prod (_,_,de) ->
+ let instantiated_de = CicSubstitution.subst he de in
+ (*CSC: siamo sicuri che non sia troppo forte? *)
+ does_not_occur ~subst context n nn tlhe &
+ instantiate_type tl instantiated_de tltl
+ | _ ->
+ (*CSC:We do not consider backbones with a MutCase, a *)
+ (*CSC:FixPoint, a CoFixPoint and so on in head position.*)
+ raise (AssertFailure (lazy "23"))
+ end
+ | [] -> analyse_instantiated_type context consty' l
+ (* These are all the other cases *)
+ in
+ instantiate_type args consty tl
+ | C.Appl ((C.CoFix (_,fl))::tl) ->
+ List.fold_left (fun i x -> i && does_not_occur ~subst context n nn x) true tl &&
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len
+ (*CSC: Is a Decl of the ty ok or should I use Def of a Fix? *)
+ and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl in
+ List.fold_right
+ (fun (_,ty,bo) i ->
+ i && does_not_occur ~subst context n nn ty &&
+ guarded_by_constructors ~subst (tys@context) n_plus_len nn_plus_len
+ h bo args coInductiveTypeURI
+ ) fl true
+ | C.Appl ((C.MutCase (_,_,out,te,pl))::tl) ->
+ List.fold_left (fun i x -> i && does_not_occur ~subst context n nn x) true tl &&
+ does_not_occur ~subst context n nn out &&
+ does_not_occur ~subst context n nn te &&
+ List.fold_right
+ (fun x i ->
+ i &&
+ guarded_by_constructors ~subst context n nn h x args
+ coInductiveTypeURI
+ ) pl true
+ | C.Appl l ->
+ List.fold_right (fun x i -> i && does_not_occur ~subst context n nn x) l true
+ | C.Var (_,exp_named_subst)
+ | C.Const (_,exp_named_subst) ->
+ List.fold_right
+ (fun (_,x) i -> i && does_not_occur ~subst context n nn x) exp_named_subst true
+ | C.MutInd _ -> assert false
+ | C.MutConstruct (_,_,_,exp_named_subst) ->
+ List.fold_right
+ (fun (_,x) i -> i && does_not_occur ~subst context n nn x) exp_named_subst true
+ | C.MutCase (_,_,out,te,pl) ->
+ does_not_occur ~subst context n nn out &&
+ does_not_occur ~subst context n nn te &&
+ List.fold_right
+ (fun x i ->
+ i &&
+ guarded_by_constructors ~subst context n nn h x args
+ coInductiveTypeURI
+ ) pl true
+ | C.Fix (_,fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len
+ (*CSC: Is a Decl of the ty ok or should I use Def of a Fix? *)
+ and tys = List.map (fun (n,_,ty,_)-> Some (C.Name n,(C.Decl ty))) fl in
+ List.fold_right
+ (fun (_,_,ty,bo) i ->
+ i && does_not_occur ~subst context n nn ty &&
+ does_not_occur ~subst (tys@context) n_plus_len nn_plus_len bo
+ ) fl true
+ | C.CoFix (_,fl) ->
+ let len = List.length fl in
+ let n_plus_len = n + len
+ and nn_plus_len = nn + len
+ (*CSC: Is a Decl of the ty ok or should I use Def of a Fix? *)
+ and tys = List.map (fun (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl in
+ List.fold_right
+ (fun (_,ty,bo) i ->
+ i && does_not_occur ~subst context n nn ty &&
+ guarded_by_constructors ~subst (tys@context) n_plus_len nn_plus_len
+ h bo
+ args coInductiveTypeURI
+ ) fl true
+
+and check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i
+ need_dummy ind arity1 arity2 ugraph =
+ let module C = Cic in
+ let module U = UriManager in
+ let arity1 = CicReduction.whd ~subst context arity1 in
+ let rec check_allowed_sort_elimination_aux ugraph context arity2 need_dummy =
+ match arity1, CicReduction.whd ~subst context arity2 with
+ (C.Prod (_,so1,de1), C.Prod (_,so2,de2)) ->
+ let b,ugraph1 =
+ CicReduction.are_convertible ~subst ~metasenv context so1 so2 ugraph in
+ if b then
+ check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i
+ need_dummy (C.Appl [CicSubstitution.lift 1 ind ; C.Rel 1]) de1 de2
+ ugraph1
+ else
+ false,ugraph1
+ | (C.Sort _, C.Prod (name,so,ta)) when not need_dummy ->
+ let b,ugraph1 =
+ CicReduction.are_convertible ~subst ~metasenv context so ind ugraph in
+ if not b then
+ false,ugraph1
+ else
+ check_allowed_sort_elimination_aux ugraph1
+ ((Some (name,C.Decl so))::context) ta true
+ | (C.Sort C.Prop, C.Sort C.Prop) when need_dummy -> true,ugraph
+ | (C.Sort C.Prop, C.Sort C.Set)
+ | (C.Sort C.Prop, C.Sort C.CProp)
+ | (C.Sort C.Prop, C.Sort (C.Type _) ) when need_dummy ->
+ (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ C.InductiveDefinition (itl,_,paramsno,_) ->
+ let itl_len = List.length itl in
+ let (name,_,ty,cl) = List.nth itl i in
+ let cl_len = List.length cl in
+ if (cl_len = 0 || (itl_len = 1 && cl_len = 1)) then
+ let non_informative,ugraph =
+ if cl_len = 0 then true,ugraph
+ else
+ is_non_informative ~logger [Some (C.Name name,C.Decl ty)]
+ paramsno (snd (List.nth cl 0)) ugraph
+ in
+ (* is it a singleton or empty non recursive and non informative
+ definition? *)
+ non_informative, ugraph
+ else
+ false,ugraph
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown mutual inductive definition:" ^
+ UriManager.string_of_uri uri)))
+ )
+ | (C.Sort C.Set, C.Sort C.Prop) when need_dummy -> true , ugraph
+ | (C.Sort C.CProp, C.Sort C.Prop) when need_dummy -> true , ugraph
+ | (C.Sort C.Set, C.Sort C.Set) when need_dummy -> true , ugraph
+ | (C.Sort C.Set, C.Sort C.CProp) when need_dummy -> true , ugraph
+ | (C.Sort C.CProp, C.Sort C.Set) when need_dummy -> true , ugraph
+ | (C.Sort C.CProp, C.Sort C.CProp) when need_dummy -> true , ugraph
+ | ((C.Sort C.Set, C.Sort (C.Type _)) | (C.Sort C.CProp, C.Sort (C.Type _)))
+ when need_dummy ->
+ (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ C.InductiveDefinition (itl,_,paramsno,_) ->
+ let tys =
+ List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) itl
+ in
+ let (_,_,_,cl) = List.nth itl i in
+ (List.fold_right
+ (fun (_,x) (i,ugraph) ->
+ if i then
+ is_small ~logger tys paramsno x ugraph
+ else
+ false,ugraph
+ ) cl (true,ugraph))
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown mutual inductive definition:" ^
+ UriManager.string_of_uri uri)))
+ )
+ | (C.Sort (C.Type _), C.Sort _) when need_dummy -> true , ugraph
+ | (_,_) -> false,ugraph
+ in
+ check_allowed_sort_elimination_aux ugraph context arity2 need_dummy
+
+and type_of_branch ~subst context argsno need_dummy outtype term constype =
+ let module C = Cic in
+ let module R = CicReduction in
+ match R.whd ~subst context constype with
+ C.MutInd (_,_,_) ->
+ if need_dummy then
+ outtype
+ else
+ C.Appl [outtype ; term]
+ | C.Appl (C.MutInd (_,_,_)::tl) ->
+ let (_,arguments) = split tl argsno
+ in
+ if need_dummy && arguments = [] then
+ outtype
+ else
+ C.Appl (outtype::arguments@(if need_dummy then [] else [term]))
+ | C.Prod (name,so,de) ->
+ let term' =
+ match CicSubstitution.lift 1 term with
+ C.Appl l -> C.Appl (l@[C.Rel 1])
+ | t -> C.Appl [t ; C.Rel 1]
+ in
+ C.Prod (C.Anonymous,so,type_of_branch ~subst
+ ((Some (name,(C.Decl so)))::context) argsno need_dummy
+ (CicSubstitution.lift 1 outtype) term' de)
+ | _ -> raise (AssertFailure (lazy "20"))
+
+(* check_metasenv_consistency checks that the "canonical" context of a
+metavariable is consitent - up to relocation via the relocation list l -
+with the actual context *)
+
+
+and check_metasenv_consistency ~logger ~subst metasenv context
+ canonical_context l ugraph
+=
+ let module C = Cic in
+ let module R = CicReduction in
+ let module S = CicSubstitution in
+ let lifted_canonical_context =
+ let rec aux i =
+ function
+ [] -> []
+ | (Some (n,C.Decl t))::tl ->
+ (Some (n,C.Decl (S.subst_meta l (S.lift i t))))::(aux (i+1) tl)
+ | (Some (n,C.Def (t,None)))::tl ->
+ (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None)))::(aux (i+1) tl)
+ | None::tl -> None::(aux (i+1) tl)
+ | (Some (n,C.Def (t,Some ty)))::tl ->
+ (Some (n,C.Def ((S.subst_meta l (S.lift i t)),Some (S.subst_meta l (S.lift i ty)))))::(aux (i+1) tl)
+ in
+ aux 1 canonical_context
+ in
+ List.fold_left2
+ (fun ugraph t ct ->
+ match (t,ct) with
+ | _,None -> ugraph
+ | Some t,Some (_,C.Def (ct,_)) ->
+ let b,ugraph1 =
+ R.are_convertible ~subst ~metasenv context t ct ugraph
+ in
+ if not b then
+ raise
+ (TypeCheckerFailure
+ (lazy (sprintf "Not well typed metavariable local context: expected a term convertible with %s, found %s" (CicPp.ppterm ct) (CicPp.ppterm t))))
+ else
+ ugraph1
+ | Some t,Some (_,C.Decl ct) ->
+ let type_t,ugraph1 =
+ type_of_aux' ~logger ~subst metasenv context t ugraph
+ in
+ let b,ugraph2 =
+ R.are_convertible ~subst ~metasenv context type_t ct ugraph1
+ in
+ if not b then
+ raise (TypeCheckerFailure
+ (lazy (sprintf "Not well typed metavariable local context: expected a term of type %s, found %s of type %s"
+ (CicPp.ppterm ct) (CicPp.ppterm t)
+ (CicPp.ppterm type_t))))
+ else
+ ugraph2
+ | None, _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Not well typed metavariable local context: "^
+ "an hypothesis, that is not hidden, is not instantiated")))
+ ) ugraph l lifted_canonical_context
+
+
+(*
+ type_of_aux' is just another name (with a different scope)
+ for type_of_aux
+*)
+
+and type_of_aux' ~logger ?(subst = []) metasenv context t ugraph =
+ let rec type_of_aux ~logger context t ugraph =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module S = CicSubstitution in
+ let module U = UriManager in
+ match t with
+ C.Rel n ->
+ (try
+ match List.nth context (n - 1) with
+ Some (_,C.Decl t) -> S.lift n t,ugraph
+ | Some (_,C.Def (_,Some ty)) -> S.lift n ty,ugraph
+ | Some (_,C.Def (bo,None)) ->
+ debug_print (lazy "##### CASO DA INVESTIGARE E CAPIRE") ;
+ type_of_aux ~logger context (S.lift n bo) ugraph
+ | None -> raise
+ (TypeCheckerFailure (lazy "Reference to deleted hypothesis"))
+ with
+ _ ->
+ raise (TypeCheckerFailure (lazy "unbound variable"))
+ )
+ | C.Var (uri,exp_named_subst) ->
+ incr fdebug ;
+ let ugraph1 =
+ check_exp_named_subst ~logger ~subst context exp_named_subst ugraph
+ in
+ let ty,ugraph2 = type_of_variable ~logger uri ugraph1 in
+ let ty1 = CicSubstitution.subst_vars exp_named_subst ty in
+ decr fdebug ;
+ ty1,ugraph2
+ | C.Meta (n,l) ->
+ (try
+ let (canonical_context,term,ty) = CicUtil.lookup_subst n subst in
+ let ugraph1 =
+ check_metasenv_consistency ~logger
+ ~subst metasenv context canonical_context l ugraph
+ in
+ (* assuming subst is well typed !!!!! *)
+ ((CicSubstitution.subst_meta l ty), ugraph1)
+ (* type_of_aux context (CicSubstitution.subst_meta l term) *)
+ with CicUtil.Subst_not_found _ ->
+ let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in
+ let ugraph1 =
+ check_metasenv_consistency ~logger
+ ~subst metasenv context canonical_context l ugraph
+ in
+ ((CicSubstitution.subst_meta l ty),ugraph1))
+ (* TASSI: CONSTRAINTS *)
+ | C.Sort (C.Type t) ->
+ let t' = CicUniv.fresh() in
+ let ugraph1 = CicUniv.add_gt t' t ugraph in
+ (C.Sort (C.Type t')),ugraph1
+ (* TASSI: CONSTRAINTS *)
+ | C.Sort s -> (C.Sort (C.Type (CicUniv.fresh ()))),ugraph
+ | C.Implicit _ -> raise (AssertFailure (lazy "21"))
+ | C.Cast (te,ty) as t ->
+ let _,ugraph1 = type_of_aux ~logger context ty ugraph in
+ let ty_te,ugraph2 = type_of_aux ~logger context te ugraph1 in
+ let b,ugraph3 =
+ R.are_convertible ~subst ~metasenv context ty_te ty ugraph2
+ in
+ if b then
+ ty,ugraph3
+ else
+ raise (TypeCheckerFailure
+ (lazy (sprintf "Invalid cast %s" (CicPp.ppterm t))))
+ | C.Prod (name,s,t) ->
+ let sort1,ugraph1 = type_of_aux ~logger context s ugraph in
+ let sort2,ugraph2 =
+ type_of_aux ~logger ((Some (name,(C.Decl s)))::context) t ugraph1
+ in
+ sort_of_prod ~subst context (name,s) (sort1,sort2) ugraph2
+ | C.Lambda (n,s,t) ->
+ let sort1,ugraph1 = type_of_aux ~logger context s ugraph in
+ (match R.whd ~subst context sort1 with
+ C.Meta _
+ | C.Sort _ -> ()
+ | _ ->
+ raise
+ (TypeCheckerFailure (lazy (sprintf
+ "Not well-typed lambda-abstraction: the source %s should be a type; instead it is a term of type %s" (CicPp.ppterm s)
+ (CicPp.ppterm sort1))))
+ ) ;
+ let type2,ugraph2 =
+ type_of_aux ~logger ((Some (n,(C.Decl s)))::context) t ugraph1
+ in
+ (C.Prod (n,s,type2)),ugraph2
+ | C.LetIn (n,s,t) ->
+ (* only to check if s is well-typed *)
+ let ty,ugraph1 = type_of_aux ~logger context s ugraph in
+ (* The type of a LetIn is a LetIn. Extremely slow since the computed
+ LetIn is later reduced and maybe also re-checked.
+ (C.LetIn (n,s, type_of_aux ((Some (n,(C.Def s)))::context) t))
+ *)
+ (* The type of the LetIn is reduced. Much faster than the previous
+ solution. Moreover the inferred type is probably very different
+ from the expected one.
+ (CicReduction.whd ~subst context
+ (C.LetIn (n,s, type_of_aux ((Some (n,(C.Def s)))::context) t)))
+ *)
+ (* One-step LetIn reduction. Even faster than the previous solution.
+ Moreover the inferred type is closer to the expected one. *)
+ let ty1,ugraph2 =
+ type_of_aux ~logger
+ ((Some (n,(C.Def (s,Some ty))))::context) t ugraph1
+ in
+ (CicSubstitution.subst s ty1),ugraph2
+ | C.Appl (he::tl) when List.length tl > 0 ->
+ let hetype,ugraph1 = type_of_aux ~logger context he ugraph in
+ let tlbody_and_type,ugraph2 =
+ List.fold_right (
+ fun x (l,ugraph) ->
+ let ty,ugraph1 = type_of_aux ~logger context x ugraph in
+ let _,ugraph1 = type_of_aux ~logger context ty ugraph1 in
+ ((x,ty)::l,ugraph1))
+ tl ([],ugraph1)
+ in
+ (* TASSI: questa c'era nel mio... ma non nel CVS... *)
+ (* let _,ugraph2 = type_of_aux context hetype ugraph2 in *)
+ eat_prods ~subst context hetype tlbody_and_type ugraph2
+ | C.Appl _ -> raise (AssertFailure (lazy "Appl: no arguments"))
+ | C.Const (uri,exp_named_subst) ->
+ incr fdebug ;
+ let ugraph1 =
+ check_exp_named_subst ~logger ~subst context exp_named_subst ugraph
+ in
+ let cty,ugraph2 = type_of_constant ~logger uri ugraph1 in
+ let cty1 =
+ CicSubstitution.subst_vars exp_named_subst cty
+ in
+ decr fdebug ;
+ cty1,ugraph2
+ | C.MutInd (uri,i,exp_named_subst) ->
+ incr fdebug ;
+ let ugraph1 =
+ check_exp_named_subst ~logger ~subst context exp_named_subst ugraph
+ in
+ (* TASSI: da me c'era anche questa, ma in CVS no *)
+ let mty,ugraph2 = type_of_mutual_inductive_defs ~logger uri i ugraph1 in
+ (* fine parte dubbia *)
+ let cty =
+ CicSubstitution.subst_vars exp_named_subst mty
+ in
+ decr fdebug ;
+ cty,ugraph2
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let ugraph1 =
+ check_exp_named_subst ~logger ~subst context exp_named_subst ugraph
+ in
+ (* TASSI: idem come sopra *)
+ let mty,ugraph2 =
+ type_of_mutual_inductive_constr ~logger uri i j ugraph1
+ in
+ let cty =
+ CicSubstitution.subst_vars exp_named_subst mty
+ in
+ cty,ugraph2
+ | C.MutCase (uri,i,outtype,term,pl) ->
+ let outsort,ugraph1 = type_of_aux ~logger context outtype ugraph in
+ let (need_dummy, k) =
+ let rec guess_args context t =
+ let outtype = CicReduction.whd ~subst context t in
+ match outtype with
+ C.Sort _ -> (true, 0)
+ | C.Prod (name, s, t) ->
+ let (b, n) =
+ guess_args ((Some (name,(C.Decl s)))::context) t in
+ if n = 0 then
+ (* last prod before sort *)
+ match CicReduction.whd ~subst context s with
+(*CSC: for _ see comment below about the missing named_exp_subst ?????????? *)
+ C.MutInd (uri',i',_) when U.eq uri' uri && i' = i ->
+ (false, 1)
+(*CSC: for _ see comment below about the missing named_exp_subst ?????????? *)
+ | C.Appl ((C.MutInd (uri',i',_)) :: _)
+ when U.eq uri' uri && i' = i -> (false, 1)
+ | _ -> (true, 1)
+ else
+ (b, n + 1)
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (lazy (sprintf
+ "Malformed case analasys' output type %s"
+ (CicPp.ppterm outtype))))
+ in
+(*
+ let (parameters, arguments, exp_named_subst),ugraph2 =
+ let ty,ugraph2 = type_of_aux context term ugraph1 in
+ match R.whd ~subst context ty with
+ (*CSC manca il caso dei CAST *)
+(*CSC: ma servono i parametri (uri,i)? Se si', perche' non serve anche il *)
+(*CSC: parametro exp_named_subst? Se no, perche' non li togliamo? *)
+(*CSC: Hint: nella DTD servono per gli stylesheet. *)
+ C.MutInd (uri',i',exp_named_subst) as typ ->
+ if U.eq uri uri' && i = i' then
+ ([],[],exp_named_subst),ugraph2
+ else
+ raise
+ (TypeCheckerFailure
+ (lazy (sprintf
+ ("Case analysys: analysed term type is %s, but is expected to be (an application of) %s#1/%d{_}")
+ (CicPp.ppterm typ) (U.string_of_uri uri) i)))
+ | C.Appl
+ ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) as typ' ->
+ if U.eq uri uri' && i = i' then
+ let params,args =
+ split tl (List.length tl - k)
+ in (params,args,exp_named_subst),ugraph2
+ else
+ raise
+ (TypeCheckerFailure
+ (lazy (sprintf
+ ("Case analysys: analysed term type is %s, "^
+ "but is expected to be (an application of) "^
+ "%s#1/%d{_}")
+ (CicPp.ppterm typ') (U.string_of_uri uri) i)))
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (lazy (sprintf
+ ("Case analysis: "^
+ "analysed term %s is not an inductive one")
+ (CicPp.ppterm term))))
+*)
+ let (b, k) = guess_args context outsort in
+ if not b then (b, k - 1) else (b, k) in
+ let (parameters, arguments, exp_named_subst),ugraph2 =
+ let ty,ugraph2 = type_of_aux ~logger context term ugraph1 in
+ match R.whd ~subst context ty with
+ C.MutInd (uri',i',exp_named_subst) as typ ->
+ if U.eq uri uri' && i = i' then
+ ([],[],exp_named_subst),ugraph2
+ else raise
+ (TypeCheckerFailure
+ (lazy (sprintf
+ ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}")
+ (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) i)))
+ | C.Appl ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) ->
+ if U.eq uri uri' && i = i' then
+ let params,args =
+ split tl (List.length tl - k)
+ in (params,args,exp_named_subst),ugraph2
+ else raise
+ (TypeCheckerFailure
+ (lazy (sprintf
+ ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}")
+ (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) i)))
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (lazy (sprintf
+ "Case analysis: analysed term %s is not an inductive one"
+ (CicPp.ppterm term))))
+ in
+ (*
+ let's control if the sort elimination is allowed:
+ [(I q1 ... qr)|B]
+ *)
+ let sort_of_ind_type =
+ if parameters = [] then
+ C.MutInd (uri,i,exp_named_subst)
+ else
+ C.Appl ((C.MutInd (uri,i,exp_named_subst))::parameters)
+ in
+ let type_of_sort_of_ind_ty,ugraph3 =
+ type_of_aux ~logger context sort_of_ind_type ugraph2 in
+ let b,ugraph4 =
+ check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i
+ need_dummy sort_of_ind_type type_of_sort_of_ind_ty outsort ugraph3
+ in
+ if not b then
+ raise
+ (TypeCheckerFailure (lazy ("Case analasys: sort elimination not allowed")));
+ (* let's check if the type of branches are right *)
+ let parsno =
+ let obj,_ =
+ try
+ CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri
+ with Not_found -> assert false
+ in
+ match obj with
+ C.InductiveDefinition (_,_,parsno,_) -> parsno
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown mutual inductive definition:" ^
+ UriManager.string_of_uri uri)))
+ in
+ let (_,branches_ok,ugraph5) =
+ List.fold_left
+ (fun (j,b,ugraph) p ->
+ if b then
+ let cons =
+ if parameters = [] then
+ (C.MutConstruct (uri,i,j,exp_named_subst))
+ else
+ (C.Appl
+ (C.MutConstruct (uri,i,j,exp_named_subst)::parameters))
+ in
+ let ty_p,ugraph1 = type_of_aux ~logger context p ugraph in
+ let ty_cons,ugraph3 = type_of_aux ~logger context cons ugraph1 in
+ (* 2 is skipped *)
+ let ty_branch =
+ type_of_branch ~subst context parsno need_dummy outtype cons
+ ty_cons in
+ let b1,ugraph4 =
+ R.are_convertible
+ ~subst ~metasenv context ty_p ty_branch ugraph3
+ in
+ if not b1 then
+ debug_print (lazy
+ ("#### " ^ CicPp.ppterm ty_p ^
+ " <==> " ^ CicPp.ppterm ty_branch));
+ (j + 1,b1,ugraph4)
+ else
+ (j,false,ugraph)
+ ) (1,true,ugraph4) pl
+ in
+ if not branches_ok then
+ raise
+ (TypeCheckerFailure (lazy "Case analysys: wrong branch type"));
+ let arguments' =
+ if not need_dummy then outtype::arguments@[term]
+ else outtype::arguments in
+ let outtype =
+ if need_dummy && arguments = [] then outtype
+ else CicReduction.head_beta_reduce (C.Appl arguments')
+ in
+ outtype,ugraph5
+ | C.Fix (i,fl) ->
+ let types_times_kl,ugraph1 =
+ (* WAS: list rev list map *)
+ List.fold_left
+ (fun (l,ugraph) (n,k,ty,_) ->
+ let _,ugraph1 = type_of_aux ~logger context ty ugraph in
+ ((Some (C.Name n,(C.Decl ty)),k)::l,ugraph1)
+ ) ([],ugraph) fl
+ in
+ let (types,kl) = List.split types_times_kl in
+ let len = List.length types in
+ let ugraph2 =
+ List.fold_left
+ (fun ugraph (name,x,ty,bo) ->
+ let ty_bo,ugraph1 =
+ type_of_aux ~logger (types@context) bo ugraph
+ in
+ let b,ugraph2 =
+ R.are_convertible ~subst ~metasenv (types@context)
+ ty_bo (CicSubstitution.lift len ty) ugraph1 in
+ if b then
+ begin
+ let (m, eaten, context') =
+ eat_lambdas ~subst (types @ context) (x + 1) bo
+ in
+ (*
+ let's control the guarded by
+ destructors conditions D{f,k,x,M}
+ *)
+ if not (guarded_by_destructors ~subst context' eaten
+ (len + eaten) kl 1 [] m) then
+ raise
+ (TypeCheckerFailure
+ (lazy ("Fix: not guarded by destructors")))
+ else
+ ugraph2
+ end
+ else
+ raise (TypeCheckerFailure (lazy ("Fix: ill-typed bodies")))
+ ) ugraph1 fl in
+ (*CSC: controlli mancanti solo su D{f,k,x,M} *)
+ let (_,_,ty,_) = List.nth fl i in
+ ty,ugraph2
+ | C.CoFix (i,fl) ->
+ let types,ugraph1 =
+ List.fold_left
+ (fun (l,ugraph) (n,ty,_) ->
+ let _,ugraph1 =
+ type_of_aux ~logger context ty ugraph in
+ (Some (C.Name n,(C.Decl ty))::l,ugraph1)
+ ) ([],ugraph) fl
+ in
+ let len = List.length types in
+ let ugraph2 =
+ List.fold_left
+ (fun ugraph (_,ty,bo) ->
+ let ty_bo,ugraph1 =
+ type_of_aux ~logger (types @ context) bo ugraph
+ in
+ let b,ugraph2 =
+ R.are_convertible ~subst ~metasenv (types @ context) ty_bo
+ (CicSubstitution.lift len ty) ugraph1
+ in
+ if b then
+ begin
+ (* let's control that the returned type is coinductive *)
+ match returns_a_coinductive ~subst context ty with
+ None ->
+ raise
+ (TypeCheckerFailure
+ (lazy "CoFix: does not return a coinductive type"))
+ | Some uri ->
+ (*
+ let's control the guarded by constructors
+ conditions C{f,M}
+ *)
+ if not (guarded_by_constructors ~subst
+ (types @ context) 0 len false bo [] uri) then
+ raise
+ (TypeCheckerFailure
+ (lazy "CoFix: not guarded by constructors"))
+ else
+ ugraph2
+ end
+ else
+ raise
+ (TypeCheckerFailure (lazy "CoFix: ill-typed bodies"))
+ ) ugraph1 fl
+ in
+ let (_,ty,_) = List.nth fl i in
+ ty,ugraph2
+
+ and check_exp_named_subst ~logger ~subst context ugraph =
+ let rec check_exp_named_subst_aux ~logger esubsts l ugraph =
+ match l with
+ [] -> ugraph
+ | ((uri,t) as item)::tl ->
+ let ty_uri,ugraph1 = type_of_variable ~logger uri ugraph in
+ let typeofvar =
+ CicSubstitution.subst_vars esubsts ty_uri in
+ let typeoft,ugraph2 = type_of_aux ~logger context t ugraph1 in
+ let b,ugraph3 =
+ CicReduction.are_convertible ~subst ~metasenv
+ context typeoft typeofvar ugraph2
+ in
+ if b then
+ check_exp_named_subst_aux ~logger (esubsts@[item]) tl ugraph3
+ else
+ begin
+ CicReduction.fdebug := 0 ;
+ ignore
+ (CicReduction.are_convertible
+ ~subst ~metasenv context typeoft typeofvar ugraph2) ;
+ fdebug := 0 ;
+ debug typeoft [typeofvar] ;
+ raise (TypeCheckerFailure (lazy "Wrong Explicit Named Substitution"))
+ end
+ in
+ check_exp_named_subst_aux ~logger [] ugraph
+
+ and sort_of_prod ~subst context (name,s) (t1, t2) ugraph =
+ let module C = Cic in
+ let t1' = CicReduction.whd ~subst context t1 in
+ let t2' = CicReduction.whd ~subst ((Some (name,C.Decl s))::context) t2 in
+ match (t1', t2') with
+ (C.Sort s1, C.Sort s2)
+ when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) ->
+ (* different from Coq manual!!! *)
+ C.Sort s2,ugraph
+ | (C.Sort (C.Type t1), C.Sort (C.Type t2)) ->
+ (* TASSI: CONSRTAINTS: the same in doubletypeinference, cicrefine *)
+ let t' = CicUniv.fresh() in
+ let ugraph1 = CicUniv.add_ge t' t1 ugraph in
+ let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in
+ C.Sort (C.Type t'),ugraph2
+ | (C.Sort _,C.Sort (C.Type t1)) ->
+ (* TASSI: CONSRTAINTS: the same in doubletypeinference, cicrefine *)
+ C.Sort (C.Type t1),ugraph (* c'e' bisogno di un fresh? *)
+ | (C.Meta _, C.Sort _) -> t2',ugraph
+ | (C.Meta _, (C.Meta (_,_) as t))
+ | (C.Sort _, (C.Meta (_,_) as t)) when CicUtil.is_closed t ->
+ t2',ugraph
+ | (_,_) -> raise (TypeCheckerFailure (lazy (sprintf
+ "Prod: expected two sorts, found = %s, %s" (CicPp.ppterm t1')
+ (CicPp.ppterm t2'))))
+
+ and eat_prods ~subst context hetype l ugraph =
+ (*CSC: siamo sicuri che le are_convertible non lavorino con termini non *)
+ (*CSC: cucinati *)
+ match l with
+ [] -> hetype,ugraph
+ | (hete, hety)::tl ->
+ (match (CicReduction.whd ~subst context hetype) with
+ Cic.Prod (n,s,t) ->
+ let b,ugraph1 =
+ CicReduction.are_convertible
+ ~subst ~metasenv context hety s ugraph
+ in
+ if b then
+ begin
+ CicReduction.fdebug := -1 ;
+ eat_prods ~subst context
+ (CicSubstitution.subst hete t) tl ugraph1
+ (*TASSI: not sure *)
+ end
+ else
+ begin
+ CicReduction.fdebug := 0 ;
+ ignore (CicReduction.are_convertible
+ ~subst ~metasenv context s hety ugraph) ;
+ fdebug := 0 ;
+ debug s [hety] ;
+ raise
+ (TypeCheckerFailure
+ (lazy (sprintf
+ ("Appl: wrong parameter-type, expected %s, found %s")
+ (CicPp.ppterm hetype) (CicPp.ppterm s))))
+ end
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy "Appl: this is not a function, it cannot be applied"))
+ )
+
+ and returns_a_coinductive ~subst context ty =
+ let module C = Cic in
+ match CicReduction.whd ~subst context ty with
+ C.MutInd (uri,i,_) ->
+ (*CSC: definire una funzioncina per questo codice sempre replicato *)
+ let obj,_ =
+ try
+ CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri
+ with Not_found -> assert false
+ in
+ (match obj with
+ C.InductiveDefinition (itl,_,_,_) ->
+ let (_,is_inductive,_,_) = List.nth itl i in
+ if is_inductive then None else (Some uri)
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown mutual inductive definition:" ^
+ UriManager.string_of_uri uri)))
+ )
+ | C.Appl ((C.MutInd (uri,i,_))::_) ->
+ (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ C.InductiveDefinition (itl,_,_,_) ->
+ let (_,is_inductive,_,_) = List.nth itl i in
+ if is_inductive then None else (Some uri)
+ | _ ->
+ raise (TypeCheckerFailure
+ (lazy ("Unknown mutual inductive definition:" ^
+ UriManager.string_of_uri uri)))
+ )
+ | C.Prod (n,so,de) ->
+ returns_a_coinductive ~subst ((Some (n,C.Decl so))::context) de
+ | _ -> None
+
+ in
+(*CSC
+debug_print (lazy ("INIZIO TYPE_OF_AUX " ^ CicPp.ppterm t)) ; flush stderr ;
+let res =
+*)
+ type_of_aux ~logger context t ugraph
+(*
+in debug_print (lazy "FINE TYPE_OF_AUX") ; flush stderr ; res
+*)
+
+(* is a small constructor? *)
+(*CSC: ottimizzare calcolando staticamente *)
+and is_small_or_non_informative ~condition ~logger context paramsno c ugraph =
+ let rec is_small_or_non_informative_aux ~logger context c ugraph =
+ let module C = Cic in
+ match CicReduction.whd context c with
+ C.Prod (n,so,de) ->
+ let s,ugraph1 = type_of_aux' ~logger [] context so ugraph in
+ let b = condition s in
+ if b then
+ is_small_or_non_informative_aux
+ ~logger ((Some (n,(C.Decl so)))::context) de ugraph1
+ else
+ false,ugraph1
+ | _ -> true,ugraph (*CSC: we trust the type-checker *)
+ in
+ let (context',dx) = split_prods ~subst:[] context paramsno c in
+ is_small_or_non_informative_aux ~logger context' dx ugraph
+
+and is_small ~logger =
+ is_small_or_non_informative
+ ~condition:(fun s -> s=Cic.Sort Cic.Prop || s=Cic.Sort Cic.Set)
+ ~logger
+
+and is_non_informative ~logger =
+ is_small_or_non_informative
+ ~condition:(fun s -> s=Cic.Sort Cic.Prop)
+ ~logger
+
+and type_of ~logger t ugraph =
+(*CSC
+debug_print (lazy ("INIZIO TYPE_OF_AUX' " ^ CicPp.ppterm t)) ; flush stderr ;
+let res =
+*)
+ type_of_aux' ~logger [] [] t ugraph
+(*CSC
+in debug_print (lazy "FINE TYPE_OF_AUX'") ; flush stderr ; res
+*)
+;;
+
+let typecheck_obj0 ~logger uri ugraph =
+ let module C = Cic in
+ function
+ C.Constant (_,Some te,ty,_,_) ->
+ let _,ugraph = type_of ~logger ty ugraph in
+ let ty_te,ugraph = type_of ~logger te ugraph in
+ let b,ugraph = (CicReduction.are_convertible [] ty_te ty ugraph) in
+ if not b then
+ raise (TypeCheckerFailure
+ (lazy
+ ("the type of the body is not the one expected:\n" ^
+ CicPp.ppterm ty_te ^ "\nvs\n" ^
+ CicPp.ppterm ty)))
+ else
+ ugraph
+ | C.Constant (_,None,ty,_,_) ->
+ (* only to check that ty is well-typed *)
+ let _,ugraph = type_of ~logger ty ugraph in
+ ugraph
+ | C.CurrentProof (_,conjs,te,ty,_,_) ->
+ let _,ugraph =
+ List.fold_left
+ (fun (metasenv,ugraph) ((_,context,ty) as conj) ->
+ let _,ugraph =
+ type_of_aux' ~logger metasenv context ty ugraph
+ in
+ metasenv @ [conj],ugraph
+ ) ([],ugraph) conjs
+ in
+ let _,ugraph = type_of_aux' ~logger conjs [] ty ugraph in
+ let type_of_te,ugraph =
+ type_of_aux' ~logger conjs [] te ugraph
+ in
+ let b,ugraph = CicReduction.are_convertible [] type_of_te ty ugraph in
+ if not b then
+ raise (TypeCheckerFailure (lazy (sprintf
+ "the current proof is not well typed because the type %s of the body is not convertible to the declared type %s"
+ (CicPp.ppterm type_of_te) (CicPp.ppterm ty))))
+ else
+ ugraph
+ | C.Variable (_,bo,ty,_,_) ->
+ (* only to check that ty is well-typed *)
+ let _,ugraph = type_of ~logger ty ugraph in
+ (match bo with
+ None -> ugraph
+ | Some bo ->
+ let ty_bo,ugraph = type_of ~logger bo ugraph in
+ let b,ugraph = CicReduction.are_convertible [] ty_bo ty ugraph in
+ if not b then
+ raise (TypeCheckerFailure
+ (lazy "the body is not the one expected"))
+ else
+ ugraph
+ )
+ | (C.InductiveDefinition _ as obj) ->
+ check_mutual_inductive_defs ~logger uri obj ugraph
+
+let typecheck uri =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let logger = new CicLogger.logger in
+ (* ??? match CicEnvironment.is_type_checked ~trust:true uri with ???? *)
+ match CicEnvironment.is_type_checked ~trust:false CicUniv.empty_ugraph uri with
+ CicEnvironment.CheckedObj (cobj,ugraph') ->
+ (* debug_print (lazy ("NON-INIZIO A TYPECHECKARE " ^ U.string_of_uri uri));*)
+ cobj,ugraph'
+ | CicEnvironment.UncheckedObj uobj ->
+ (* let's typecheck the uncooked object *)
+ logger#log (`Start_type_checking uri) ;
+ (* debug_print (lazy ("INIZIO A TYPECHECKARE " ^ U.string_of_uri uri)); *)
+ let ugraph = typecheck_obj0 ~logger uri CicUniv.empty_ugraph uobj in
+ try
+ CicEnvironment.set_type_checking_info uri;
+ logger#log (`Type_checking_completed uri);
+ match CicEnvironment.is_type_checked ~trust:false ugraph uri with
+ CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph'
+ | _ -> raise CicEnvironmentError
+ with
+ (*
+ this is raised if set_type_checking_info is called on an object
+ that has no associated universe file. If we are in univ_maker
+ phase this is OK since univ_maker will properly commit the
+ object.
+ *)
+ Invalid_argument s ->
+ (*debug_print (lazy s);*)
+ uobj,ugraph
+;;
+
+let typecheck_obj ~logger uri obj =
+ let ugraph = typecheck_obj0 ~logger uri CicUniv.empty_ugraph obj in
+ let ugraph, univlist, obj = CicUnivUtils.clean_and_fill uri obj ugraph in
+ CicEnvironment.add_type_checked_obj uri (obj,ugraph,univlist)
+
+(** wrappers which instantiate fresh loggers *)
+
+let type_of_aux' ?(subst = []) metasenv context t ugraph =
+ let logger = new CicLogger.logger in
+ type_of_aux' ~logger ~subst metasenv context t ugraph
+
+let typecheck_obj uri obj =
+ let logger = new CicLogger.logger in
+ typecheck_obj ~logger uri obj
+
+(* check_allowed_sort_elimination uri i s1 s2
+ This function is used outside the kernel to determine in advance whether
+ a MutCase will be allowed or not.
+ [uri,i] is the type of the term to match
+ [s1] is the sort of the term to eliminate (i.e. the head of the arity
+ of the inductive type [uri,i])
+ [s2] is the sort of the goal (i.e. the head of the type of the outtype
+ of the MutCase) *)
+let check_allowed_sort_elimination uri i s1 s2 =
+ fst (check_allowed_sort_elimination ~subst:[] ~metasenv:[]
+ ~logger:(new CicLogger.logger) [] uri i true
+ (Cic.Implicit None) (* never used *) (Cic.Sort s1) (Cic.Sort s2)
+ CicUniv.empty_ugraph)
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* 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
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*****************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+ (** 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
+
--- /dev/null
+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)
--- /dev/null
+(* 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)
+;;
--- /dev/null
+(* 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
--- /dev/null
+UTILITIES = create_environment parse_library list_uris
+UTILITIES_OPT = $(patsubst %,%.opt,$(UTILITIES))
+LINKOPTS = -linkpkg -thread
+LIBS = helm-cic_proof_checking
+OCAMLC = $(OCAMLFIND) ocamlc $(LINKOPTS) -package $(LIBS)
+OCAMLOPT = $(OCAMLFIND) opt $(LINKOPTS) -package $(LIBS)
+all: $(UTILITIES)
+ @echo -n
+opt: $(UTILITIES_OPT)
+ @echo -n
+%: %.ml
+ @echo " OCAMLC $<"
+ @$(OCAMLC) -o $@ $<
+%.opt: %.ml
+ @echo " OCAMLOPT $<"
+ @$(OCAMLOPT) -o $@ $<
+clean:
+ rm -f $(UTILITIES) $(UTILITIES_OPT) *.cm[iox] *.o
+
+include ../../../Makefile.defs
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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 ())
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+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
--- /dev/null
+PACKAGE = cic_unification
+PREDICATES =
+
+INTERFACE_FILES = \
+ cicMetaSubst.mli \
+ cicMkImplicit.mli \
+ cicUnification.mli \
+ cicRefine.mli
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+EXTRA_OBJECTS_TO_INSTALL =
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2003, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+(* PROFILING *)
+(*
+let deref_counter = ref 0
+let apply_subst_context_counter = ref 0
+let apply_subst_metasenv_counter = ref 0
+let lift_counter = ref 0
+let subst_counter = ref 0
+let whd_counter = ref 0
+let are_convertible_counter = ref 0
+let metasenv_length = ref 0
+let context_length = ref 0
+let reset_counters () =
+ apply_subst_counter := 0;
+ apply_subst_context_counter := 0;
+ apply_subst_metasenv_counter := 0;
+ lift_counter := 0;
+ subst_counter := 0;
+ whd_counter := 0;
+ are_convertible_counter := 0;
+ metasenv_length := 0;
+ context_length := 0
+let print_counters () =
+ debug_print (lazy (Printf.sprintf
+"apply_subst: %d
+apply_subst_context: %d
+apply_subst_metasenv: %d
+lift: %d
+subst: %d
+whd: %d
+are_convertible: %d
+metasenv length: %d (avg = %.2f)
+context length: %d (avg = %.2f)
+"
+ !apply_subst_counter !apply_subst_context_counter
+ !apply_subst_metasenv_counter !lift_counter !subst_counter !whd_counter
+ !are_convertible_counter !metasenv_length
+ ((float !metasenv_length) /. (float !apply_subst_metasenv_counter))
+ !context_length
+ ((float !context_length) /. (float !apply_subst_context_counter))
+ ))*)
+
+
+
+exception MetaSubstFailure of string Lazy.t
+exception Uncertain of string Lazy.t
+exception AssertFailure of string Lazy.t
+exception DeliftingARelWouldCaptureAFreeVariable;;
+
+let debug_print = fun _ -> ()
+
+type substitution = (int * (Cic.context * Cic.term)) list
+
+(*
+let rec deref subst =
+ let third _,_,a = a in
+ function
+ Cic.Meta(n,l) as t ->
+ (try
+ deref subst
+ (CicSubstitution.subst_meta
+ l (third (CicUtil.lookup_subst n subst)))
+ with
+ CicUtil.Subst_not_found _ -> t)
+ | t -> t
+;;
+*)
+
+let lookup_subst = CicUtil.lookup_subst
+;;
+
+
+(* clean_up_meta take a metasenv and a term and make every local context
+of each occurrence of a metavariable consistent with its canonical context,
+with respect to the hidden hipothesis *)
+
+(*
+let clean_up_meta subst metasenv t =
+ let module C = Cic in
+ let rec aux t =
+ match t with
+ C.Rel _
+ | C.Sort _ -> t
+ | C.Implicit _ -> assert false
+ | C.Meta (n,l) as t ->
+ let cc =
+ (try
+ let (cc,_) = lookup_subst n subst in cc
+ with CicUtil.Subst_not_found _ ->
+ try
+ let (_,cc,_) = CicUtil.lookup_meta n metasenv in cc
+ with CicUtil.Meta_not_found _ -> assert false) in
+ let l' =
+ (try
+ List.map2
+ (fun t1 t2 ->
+ match t1,t2 with
+ None , _ -> None
+ | _ , t -> t) cc l
+ with
+ Invalid_argument _ -> assert false) in
+ C.Meta (n, l')
+ | C.Cast (te,ty) -> C.Cast (aux te, aux ty)
+ | C.Prod (name,so,dest) -> C.Prod (name, aux so, aux dest)
+ | C.Lambda (name,so,dest) -> C.Lambda (name, aux so, aux dest)
+ | C.LetIn (name,so,dest) -> C.LetIn (name, aux so, aux dest)
+ | C.Appl l -> C.Appl (List.map aux l)
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (fun (uri,t) -> (uri, aux t)) exp_named_subst
+ in
+ C.Var (uri, exp_named_subst')
+ | C.Const (uri, exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (fun (uri,t) -> (uri, aux t)) exp_named_subst
+ in
+ C.Const (uri, exp_named_subst')
+ | C.MutInd (uri,tyno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (fun (uri,t) -> (uri, aux t)) exp_named_subst
+ in
+ C.MutInd (uri, tyno, exp_named_subst')
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (fun (uri,t) -> (uri, aux t)) exp_named_subst
+ in
+ C.MutConstruct (uri, tyno, consno, exp_named_subst')
+ | C.MutCase (uri,tyno,out,te,pl) ->
+ C.MutCase (uri, tyno, aux out, aux te, List.map aux pl)
+ | C.Fix (i,fl) ->
+ let fl' =
+ List.map
+ (fun (name,j,ty,bo) -> (name, j, aux ty, aux bo)) fl
+ in
+ C.Fix (i, fl')
+ | C.CoFix (i,fl) ->
+ let fl' =
+ List.map
+ (fun (name,ty,bo) -> (name, aux ty, aux bo)) fl
+ in
+ C.CoFix (i, fl')
+ in
+ aux t *)
+
+(*** Functions to apply a substitution ***)
+
+let apply_subst_gen ~appl_fun subst term =
+ let rec um_aux =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ function
+ C.Rel _ as t -> t
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst
+ in
+ C.Var (uri, exp_named_subst')
+ | C.Meta (i, l) ->
+ (try
+ let (_, t,_) = lookup_subst i subst in
+ um_aux (S.subst_meta l t)
+ with CicUtil.Subst_not_found _ ->
+ (* unconstrained variable, i.e. free in subst*)
+ let l' =
+ List.map (function None -> None | Some t -> Some (um_aux t)) l
+ in
+ C.Meta (i,l'))
+ | C.Sort _
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) -> C.Cast (um_aux te, um_aux ty)
+ | C.Prod (n,s,t) -> C.Prod (n, um_aux s, um_aux t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, um_aux s, um_aux t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, um_aux s, um_aux t)
+ | C.Appl (hd :: tl) -> appl_fun um_aux hd tl
+ | C.Appl _ -> assert false
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst
+ in
+ C.Const (uri, exp_named_subst')
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst
+ in
+ C.MutInd (uri,typeno,exp_named_subst')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (fun (uri, t) -> (uri, um_aux t)) exp_named_subst
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outty,t,pl) ->
+ let pl' = List.map um_aux pl in
+ C.MutCase (sp, i, um_aux outty, um_aux t, pl')
+ | C.Fix (i, fl) ->
+ let fl' =
+ List.map (fun (name, i, ty, bo) -> (name, i, um_aux ty, um_aux bo)) fl
+ in
+ C.Fix (i, fl')
+ | C.CoFix (i, fl) ->
+ let fl' =
+ List.map (fun (name, ty, bo) -> (name, um_aux ty, um_aux bo)) fl
+ in
+ C.CoFix (i, fl')
+ in
+ LibrarySync.merge_coercions (um_aux term)
+;;
+
+let apply_subst =
+ let appl_fun um_aux he tl =
+ let tl' = List.map um_aux tl in
+ let t' =
+ match um_aux he with
+ Cic.Appl l -> Cic.Appl (l@tl')
+ | he' -> Cic.Appl (he'::tl')
+ in
+ begin
+ match he with
+ Cic.Meta (m,_) -> CicReduction.head_beta_reduce t'
+ | _ -> t'
+ end
+ in
+ fun s t ->
+(* incr apply_subst_counter; *)
+ apply_subst_gen ~appl_fun s t
+;;
+
+let rec apply_subst_context subst context =
+(*
+ incr apply_subst_context_counter;
+ context_length := !context_length + List.length context;
+*)
+ List.fold_right
+ (fun item context ->
+ match item with
+ | Some (n, Cic.Decl t) ->
+ let t' = apply_subst subst t in
+ Some (n, Cic.Decl t') :: context
+ | Some (n, Cic.Def (t, ty)) ->
+ let ty' =
+ match ty with
+ | None -> None
+ | Some ty -> Some (apply_subst subst ty)
+ in
+ let t' = apply_subst subst t in
+ Some (n, Cic.Def (t', ty')) :: context
+ | None -> None :: context)
+ context []
+
+let apply_subst_metasenv subst metasenv =
+(*
+ incr apply_subst_metasenv_counter;
+ metasenv_length := !metasenv_length + List.length metasenv;
+*)
+ List.map
+ (fun (n, context, ty) ->
+ (n, apply_subst_context subst context, apply_subst subst ty))
+ (List.filter
+ (fun (i, _, _) -> not (List.mem_assoc i subst))
+ metasenv)
+
+(***** Pretty printing functions ******)
+
+let ppterm subst term = CicPp.ppterm (apply_subst subst term)
+
+let ppterm_in_name_context subst term name_context =
+ CicPp.pp (apply_subst subst term) name_context
+
+let ppterm_in_context subst term context =
+ let name_context =
+ List.map (function None -> None | Some (n,_) -> Some n) context
+ in
+ ppterm_in_name_context subst term name_context
+
+let ppcontext' ?(sep = "\n") subst context =
+ let separate s = if s = "" then "" else s ^ sep in
+ List.fold_right
+ (fun context_entry (i,name_context) ->
+ match context_entry with
+ Some (n,Cic.Decl t) ->
+ sprintf "%s%s : %s" (separate i) (CicPp.ppname n)
+ (ppterm_in_name_context subst t name_context), (Some n)::name_context
+ | Some (n,Cic.Def (bo,ty)) ->
+ sprintf "%s%s : %s := %s" (separate i) (CicPp.ppname n)
+ (match ty with
+ None -> "_"
+ | Some ty -> ppterm_in_name_context subst ty name_context)
+ (ppterm_in_name_context subst bo name_context), (Some n)::name_context
+ | None ->
+ sprintf "%s_ :? _" (separate i), None::name_context
+ ) context ("",[])
+
+let ppsubst_unfolded subst =
+ String.concat "\n"
+ (List.map
+ (fun (idx, (c, t,_)) ->
+ let context,name_context = ppcontext' ~sep:"; " subst c in
+ sprintf "%s |- ?%d:= %s" context idx
+ (ppterm_in_name_context subst t name_context))
+ subst)
+(*
+ Printf.sprintf "?%d := %s" idx (CicPp.ppterm term))
+ subst) *)
+;;
+
+let ppsubst subst =
+ String.concat "\n"
+ (List.map
+ (fun (idx, (c, t, _)) ->
+ let context,name_context = ppcontext' ~sep:"; " [] c in
+ sprintf "%s |- ?%d:= %s" context idx
+ (ppterm_in_name_context [] t name_context))
+ subst)
+;;
+
+let ppcontext ?sep subst context = fst (ppcontext' ?sep subst context)
+
+let ppmetasenv ?(sep = "\n") subst metasenv =
+ String.concat sep
+ (List.map
+ (fun (i, c, t) ->
+ let context,name_context = ppcontext' ~sep:"; " subst c in
+ sprintf "%s |- ?%d: %s" context i
+ (ppterm_in_name_context subst t name_context))
+ (List.filter
+ (fun (i, _, _) -> not (List.mem_assoc i subst))
+ metasenv))
+
+let tempi_type_of_aux_subst = ref 0.0;;
+let tempi_subst = ref 0.0;;
+let tempi_type_of_aux = ref 0.0;;
+
+(**** DELIFT ****)
+(* the delift function takes in input a metavariable index, an ordered list of
+ * optional terms [t1,...,tn] and a term t, and substitutes every tk = Some
+ * (rel(nk)) with rel(k). Typically, the list of optional terms is the explicit
+ * substitution that is applied to a metavariable occurrence and the result of
+ * the delift function is a term the implicit variable can be substituted with
+ * to make the term [t] unifiable with the metavariable occurrence. In general,
+ * the problem is undecidable if we consider equivalence in place of alpha
+ * convertibility. Our implementation, though, is even weaker than alpha
+ * convertibility, since it replace the term [tk] if and only if [tk] is a Rel
+ * (missing all the other cases). Does this matter in practice?
+ * The metavariable index is the index of the metavariable that must not occur
+ * in the term (for occur check).
+ *)
+
+exception NotInTheList;;
+
+let position n =
+ let rec aux k =
+ function
+ [] -> raise NotInTheList
+ | (Some (Cic.Rel m))::_ when m=n -> k
+ | _::tl -> aux (k+1) tl in
+ aux 1
+;;
+
+exception Occur;;
+
+let rec force_does_not_occur subst to_be_restricted t =
+ let module C = Cic in
+ let more_to_be_restricted = ref [] in
+ let rec aux k = function
+ C.Rel r when List.mem (r - k) to_be_restricted -> raise Occur
+ | C.Rel _
+ | C.Sort _ as t -> t
+ | C.Implicit _ -> assert false
+ | C.Meta (n, l) ->
+ (* we do not retrieve the term associated to ?n in subst since *)
+ (* in this way we can restrict if something goes wrong *)
+ let l' =
+ let i = ref 0 in
+ List.map
+ (function t ->
+ incr i ;
+ match t with
+ None -> None
+ | Some t ->
+ try
+ Some (aux k t)
+ with Occur ->
+ more_to_be_restricted := (n,!i) :: !more_to_be_restricted;
+ None)
+ l
+ in
+ C.Meta (n, l')
+ | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty)
+ | C.Prod (name,so,dest) -> C.Prod (name, aux k so, aux (k+1) dest)
+ | C.Lambda (name,so,dest) -> C.Lambda (name, aux k so, aux (k+1) dest)
+ | C.LetIn (name,so,dest) -> C.LetIn (name, aux k so, aux (k+1) dest)
+ | C.Appl l -> C.Appl (List.map (aux k) l)
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (fun (uri,t) -> (uri, aux k t)) exp_named_subst
+ in
+ C.Var (uri, exp_named_subst')
+ | C.Const (uri, exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (fun (uri,t) -> (uri, aux k t)) exp_named_subst
+ in
+ C.Const (uri, exp_named_subst')
+ | C.MutInd (uri,tyno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (fun (uri,t) -> (uri, aux k t)) exp_named_subst
+ in
+ C.MutInd (uri, tyno, exp_named_subst')
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (fun (uri,t) -> (uri, aux k t)) exp_named_subst
+ in
+ C.MutConstruct (uri, tyno, consno, exp_named_subst')
+ | C.MutCase (uri,tyno,out,te,pl) ->
+ C.MutCase (uri, tyno, aux k out, aux k te, List.map (aux k) pl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let k_plus_len = k + len in
+ let fl' =
+ List.map
+ (fun (name,j,ty,bo) -> (name, j, aux k ty, aux k_plus_len bo)) fl
+ in
+ C.Fix (i, fl')
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let k_plus_len = k + len in
+ let fl' =
+ List.map
+ (fun (name,ty,bo) -> (name, aux k ty, aux k_plus_len bo)) fl
+ in
+ C.CoFix (i, fl')
+ in
+ let res = aux 0 t in
+ (!more_to_be_restricted, res)
+
+let rec restrict subst to_be_restricted metasenv =
+ let names_of_context_indexes context indexes =
+ String.concat ", "
+ (List.map
+ (fun i ->
+ try
+ match List.nth context (i-1) with
+ | None -> assert false
+ | Some (n, _) -> CicPp.ppname n
+ with
+ Failure _ -> assert false
+ ) indexes)
+ in
+ let force_does_not_occur_in_context to_be_restricted = function
+ | None -> [], None
+ | Some (name, Cic.Decl t) ->
+ let (more_to_be_restricted, t') =
+ force_does_not_occur subst to_be_restricted t
+ in
+ more_to_be_restricted, Some (name, Cic.Decl t')
+ | Some (name, Cic.Def (bo, ty)) ->
+ let (more_to_be_restricted, bo') =
+ force_does_not_occur subst to_be_restricted bo
+ in
+ let more_to_be_restricted, ty' =
+ match ty with
+ | None -> more_to_be_restricted, None
+ | Some ty ->
+ let more_to_be_restricted', ty' =
+ force_does_not_occur subst to_be_restricted ty
+ in
+ more_to_be_restricted @ more_to_be_restricted',
+ Some ty'
+ in
+ more_to_be_restricted, Some (name, Cic.Def (bo', ty'))
+ in
+ let rec erase i to_be_restricted n = function
+ | [] -> [], to_be_restricted, []
+ | hd::tl ->
+ let more_to_be_restricted,restricted,tl' =
+ erase (i+1) to_be_restricted n tl
+ in
+ let restrict_me = List.mem i restricted in
+ if restrict_me then
+ more_to_be_restricted, restricted, None:: tl'
+ else
+ (try
+ let more_to_be_restricted', hd' =
+ let delifted_restricted =
+ let rec aux =
+ function
+ [] -> []
+ | j::tl when j > i -> (j - i)::aux tl
+ | _::tl -> aux tl
+ in
+ aux restricted
+ in
+ force_does_not_occur_in_context delifted_restricted hd
+ in
+ more_to_be_restricted @ more_to_be_restricted',
+ restricted, hd' :: tl'
+ with Occur ->
+ more_to_be_restricted, (i :: restricted), None :: tl')
+ in
+ let (more_to_be_restricted, metasenv) = (* restrict metasenv *)
+ List.fold_right
+ (fun (n, context, t) (more, metasenv) ->
+ let to_be_restricted =
+ List.map snd (List.filter (fun (m, _) -> m = n) to_be_restricted)
+ in
+ let (more_to_be_restricted, restricted, context') =
+ (* just an optimization *)
+ if to_be_restricted = [] then
+ [],[],context
+ else
+ erase 1 to_be_restricted n context
+ in
+ try
+ let more_to_be_restricted', t' =
+ force_does_not_occur subst restricted t
+ in
+ let metasenv' = (n, context', t') :: metasenv in
+ (more @ more_to_be_restricted @ more_to_be_restricted',
+ metasenv')
+ with Occur ->
+ raise (MetaSubstFailure (lazy (sprintf
+ "Cannot restrict the context of the metavariable ?%d over the hypotheses %s since metavariable's type depends on at least one of them"
+ n (names_of_context_indexes context to_be_restricted)))))
+ metasenv ([], [])
+ in
+ let (more_to_be_restricted', subst) = (* restrict subst *)
+ List.fold_right
+ (* TODO: cambiare dopo l'aggiunta del ty *)
+ (fun (n, (context, term,ty)) (more, subst') ->
+ let to_be_restricted =
+ List.map snd (List.filter (fun (m, _) -> m = n) to_be_restricted)
+ in
+ (try
+ let (more_to_be_restricted, restricted, context') =
+ (* just an optimization *)
+ if to_be_restricted = [] then
+ [], [], context
+ else
+ erase 1 to_be_restricted n context
+ in
+ let more_to_be_restricted', term' =
+ force_does_not_occur subst restricted term
+ in
+ let more_to_be_restricted'', ty' =
+ force_does_not_occur subst restricted ty in
+ let subst' = (n, (context', term',ty')) :: subst' in
+ let more =
+ more @ more_to_be_restricted
+ @ more_to_be_restricted'@more_to_be_restricted'' in
+ (more, subst')
+ with Occur ->
+ let error_msg = lazy (sprintf
+ "Cannot restrict the context of the metavariable ?%d over the hypotheses %s since ?%d is already instantiated with %s and at least one of the hypotheses occurs in the substituted term"
+ n (names_of_context_indexes context to_be_restricted) n
+ (ppterm subst term))
+ in
+ (* DEBUG
+ debug_print (lazy error_msg);
+ debug_print (lazy ("metasenv = \n" ^ (ppmetasenv metasenv subst)));
+ debug_print (lazy ("subst = \n" ^ (ppsubst subst)));
+ debug_print (lazy ("context = \n" ^ (ppcontext subst context))); *)
+ raise (MetaSubstFailure error_msg)))
+ subst ([], [])
+ in
+ match more_to_be_restricted @ more_to_be_restricted' with
+ | [] -> (metasenv, subst)
+ | l -> restrict subst l metasenv
+;;
+
+(*CSC: maybe we should rename delift in abstract, as I did in my dissertation *)(*Andrea: maybe not*)
+
+let delift n subst context metasenv l t =
+(* INVARIANT: we suppose that t is not another occurrence of Meta(n,_),
+ otherwise the occur check does not make sense *)
+
+(*
+ debug_print (lazy ("sto deliftando il termine " ^ (CicPp.ppterm t) ^ " rispetto
+ al contesto locale " ^ (CicPp.ppterm (Cic.Meta(0,l)))));
+*)
+
+ let module S = CicSubstitution in
+ let l =
+ let (_, canonical_context, _) = CicUtil.lookup_meta n metasenv in
+ List.map2 (fun ct lt ->
+ match (ct, lt) with
+ | None, _ -> None
+ | Some _, _ -> lt)
+ canonical_context l
+ in
+ let to_be_restricted = ref [] in
+ let rec deliftaux k =
+ let module C = Cic in
+ function
+ C.Rel m ->
+ if m <=k then
+ C.Rel m (*CSC: che succede se c'e' un Def? Dovrebbe averlo gia' *)
+ (*CSC: deliftato la regola per il LetIn *)
+ (*CSC: FALSO! La regola per il LetIn non lo fa *)
+ else
+ (try
+ match List.nth context (m-k-1) with
+ Some (_,C.Def (t,_)) ->
+ (*CSC: Hmmm. This bit of reduction is not in the spirit of *)
+ (*CSC: first order unification. Does it help or does it harm? *)
+ deliftaux k (S.lift m t)
+ | Some (_,C.Decl t) ->
+ C.Rel ((position (m-k) l) + k)
+ | None -> raise (MetaSubstFailure (lazy "RelToHiddenHypothesis"))
+ with
+ Failure _ ->
+ raise (MetaSubstFailure (lazy "Unbound variable found in deliftaux"))
+ )
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
+ | C.Meta (i, l1) as t ->
+ (try
+ let (_,t,_) = CicUtil.lookup_subst i subst in
+ deliftaux k (CicSubstitution.subst_meta l1 t)
+ with CicUtil.Subst_not_found _ ->
+ (* see the top level invariant *)
+ if (i = n) then
+ raise (MetaSubstFailure (lazy (sprintf
+ "Cannot unify the metavariable ?%d with a term that has as subterm %s in which the same metavariable occurs (occur check)"
+ i (ppterm subst t))))
+ else
+ begin
+ (* I do not consider the term associated to ?i in subst since *)
+ (* in this way I can restrict if something goes wrong. *)
+ let rec deliftl j =
+ function
+ [] -> []
+ | None::tl -> None::(deliftl (j+1) tl)
+ | (Some t)::tl ->
+ let l1' = (deliftl (j+1) tl) in
+ try
+ Some (deliftaux k t)::l1'
+ with
+ NotInTheList
+ | MetaSubstFailure _ ->
+ to_be_restricted :=
+ (i,j)::!to_be_restricted ; None::l1'
+ in
+ let l' = deliftl 1 l1 in
+ C.Meta(i,l')
+ end)
+ | C.Sort _ as t -> t
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) -> C.Cast (deliftaux k te, deliftaux k ty)
+ | C.Prod (n,s,t) -> C.Prod (n, deliftaux k s, deliftaux (k+1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, deliftaux k s, deliftaux (k+1) t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, deliftaux k s, deliftaux (k+1) t)
+ | C.Appl l -> C.Appl (List.map (deliftaux k) l)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
+ in
+ C.MutInd (uri,typeno,exp_named_subst')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outty,t,pl) ->
+ C.MutCase (sp, i, deliftaux k outty, deliftaux k t,
+ List.map (deliftaux k) pl)
+ | C.Fix (i, fl) ->
+ let len = List.length fl in
+ let liftedfl =
+ List.map
+ (fun (name, i, ty, bo) ->
+ (name, i, deliftaux k ty, deliftaux (k+len) bo))
+ fl
+ in
+ C.Fix (i, liftedfl)
+ | C.CoFix (i, fl) ->
+ let len = List.length fl in
+ let liftedfl =
+ List.map
+ (fun (name, ty, bo) -> (name, deliftaux k ty, deliftaux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, liftedfl)
+ in
+ let res =
+ try
+ deliftaux 0 t
+ with
+ NotInTheList ->
+ (* This is the case where we fail even first order unification. *)
+ (* The reason is that our delift function is weaker than first *)
+ (* order (in the sense of alpha-conversion). See comment above *)
+ (* related to the delift function. *)
+(* debug_print (lazy "First Order UnificationFailure during delift") ;
+debug_print(lazy (sprintf
+ "Error trying to abstract %s over [%s]: the algorithm only tried to abstract over bound variables"
+ (ppterm subst t)
+ (String.concat "; "
+ (List.map
+ (function Some t -> ppterm subst t | None -> "_") l
+ )))); *)
+ raise (Uncertain (lazy (sprintf
+ "Error trying to abstract %s over [%s]: the algorithm only tried to abstract over bound variables"
+ (ppterm subst t)
+ (String.concat "; "
+ (List.map
+ (function Some t -> ppterm subst t | None -> "_")
+ l)))))
+ in
+ let (metasenv, subst) = restrict subst !to_be_restricted metasenv in
+ res, metasenv, subst
+;;
+
+(* delifts a term t of n levels strating from k, that is changes (Rel m)
+ * to (Rel (m - n)) when m > (k + n). if k <= m < k + n delift fails
+ *)
+let delift_rels_from subst metasenv k n =
+ let rec liftaux subst metasenv k =
+ let module C = Cic in
+ function
+ C.Rel m ->
+ if m < k then
+ C.Rel m, subst, metasenv
+ else if m < k + n then
+ raise DeliftingARelWouldCaptureAFreeVariable
+ else
+ C.Rel (m - n), subst, metasenv
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst',subst,metasenv =
+ List.fold_right
+ (fun (uri,t) (l,subst,metasenv) ->
+ let t',subst,metasenv = liftaux subst metasenv k t in
+ (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv)
+ in
+ C.Var (uri,exp_named_subst'),subst,metasenv
+ | C.Meta (i,l) ->
+ (try
+ let (_, t,_) = lookup_subst i subst in
+ liftaux subst metasenv k (CicSubstitution.subst_meta l t)
+ with CicUtil.Subst_not_found _ ->
+ let l',to_be_restricted,subst,metasenv =
+ let rec aux con l subst metasenv =
+ match l with
+ [] -> [],[],subst,metasenv
+ | he::tl ->
+ let tl',to_be_restricted,subst,metasenv =
+ aux (con + 1) tl subst metasenv in
+ let he',more_to_be_restricted,subst,metasenv =
+ match he with
+ None -> None,[],subst,metasenv
+ | Some t ->
+ try
+ let t',subst,metasenv = liftaux subst metasenv k t in
+ Some t',[],subst,metasenv
+ with
+ DeliftingARelWouldCaptureAFreeVariable ->
+ None,[i,con],subst,metasenv
+ in
+ he'::tl',more_to_be_restricted@to_be_restricted,subst,metasenv
+ in
+ aux 1 l subst metasenv in
+ let metasenv,subst = restrict subst to_be_restricted metasenv in
+ C.Meta(i,l'),subst,metasenv)
+ | C.Sort _ as t -> t,subst,metasenv
+ | C.Implicit _ as t -> t,subst,metasenv
+ | C.Cast (te,ty) ->
+ let te',subst,metasenv = liftaux subst metasenv k te in
+ let ty',subst,metasenv = liftaux subst metasenv k ty in
+ C.Cast (te',ty'),subst,metasenv
+ | C.Prod (n,s,t) ->
+ let s',subst,metasenv = liftaux subst metasenv k s in
+ let t',subst,metasenv = liftaux subst metasenv (k+1) t in
+ C.Prod (n,s',t'),subst,metasenv
+ | C.Lambda (n,s,t) ->
+ let s',subst,metasenv = liftaux subst metasenv k s in
+ let t',subst,metasenv = liftaux subst metasenv (k+1) t in
+ C.Lambda (n,s',t'),subst,metasenv
+ | C.LetIn (n,s,t) ->
+ let s',subst,metasenv = liftaux subst metasenv k s in
+ let t',subst,metasenv = liftaux subst metasenv (k+1) t in
+ C.LetIn (n,s',t'),subst,metasenv
+ | C.Appl l ->
+ let l',subst,metasenv =
+ List.fold_right
+ (fun t (l,subst,metasenv) ->
+ let t',subst,metasenv = liftaux subst metasenv k t in
+ t'::l,subst,metasenv) l ([],subst,metasenv) in
+ C.Appl l',subst,metasenv
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst',subst,metasenv =
+ List.fold_right
+ (fun (uri,t) (l,subst,metasenv) ->
+ let t',subst,metasenv = liftaux subst metasenv k t in
+ (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv)
+ in
+ C.Const (uri,exp_named_subst'),subst,metasenv
+ | C.MutInd (uri,tyno,exp_named_subst) ->
+ let exp_named_subst',subst,metasenv =
+ List.fold_right
+ (fun (uri,t) (l,subst,metasenv) ->
+ let t',subst,metasenv = liftaux subst metasenv k t in
+ (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv)
+ in
+ C.MutInd (uri,tyno,exp_named_subst'),subst,metasenv
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ let exp_named_subst',subst,metasenv =
+ List.fold_right
+ (fun (uri,t) (l,subst,metasenv) ->
+ let t',subst,metasenv = liftaux subst metasenv k t in
+ (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv)
+ in
+ C.MutConstruct (uri,tyno,consno,exp_named_subst'),subst,metasenv
+ | C.MutCase (sp,i,outty,t,pl) ->
+ let outty',subst,metasenv = liftaux subst metasenv k outty in
+ let t',subst,metasenv = liftaux subst metasenv k t in
+ let pl',subst,metasenv =
+ List.fold_right
+ (fun t (l,subst,metasenv) ->
+ let t',subst,metasenv = liftaux subst metasenv k t in
+ t'::l,subst,metasenv) pl ([],subst,metasenv)
+ in
+ C.MutCase (sp,i,outty',t',pl'),subst,metasenv
+ | C.Fix (i, fl) ->
+ let len = List.length fl in
+ let liftedfl,subst,metasenv =
+ List.fold_right
+ (fun (name, i, ty, bo) (l,subst,metasenv) ->
+ let ty',subst,metasenv = liftaux subst metasenv k ty in
+ let bo',subst,metasenv = liftaux subst metasenv (k+len) bo in
+ (name,i,ty',bo')::l,subst,metasenv
+ ) fl ([],subst,metasenv)
+ in
+ C.Fix (i, liftedfl),subst,metasenv
+ | C.CoFix (i, fl) ->
+ let len = List.length fl in
+ let liftedfl,subst,metasenv =
+ List.fold_right
+ (fun (name, ty, bo) (l,subst,metasenv) ->
+ let ty',subst,metasenv = liftaux subst metasenv k ty in
+ let bo',subst,metasenv = liftaux subst metasenv (k+len) bo in
+ (name,ty',bo')::l,subst,metasenv
+ ) fl ([],subst,metasenv)
+ in
+ C.CoFix (i, liftedfl),subst,metasenv
+ in
+ liftaux subst metasenv k
+
+let delift_rels subst metasenv n t =
+ delift_rels_from subst metasenv 1 n t
+
+
+(**** END OF DELIFT ****)
+
+
+(** {2 Format-like pretty printers} *)
+
+let fpp_gen ppf s =
+ Format.pp_print_string ppf s;
+ Format.pp_print_newline ppf ();
+ Format.pp_print_flush ppf ()
+
+let fppsubst ppf subst = fpp_gen ppf (ppsubst subst)
+let fppterm ppf term = fpp_gen ppf (CicPp.ppterm term)
+let fppmetasenv ppf metasenv = fpp_gen ppf (ppmetasenv [] metasenv)
+
--- /dev/null
+(* 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
+*)
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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)
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+exception RefineFailure of string Lazy.t;;
+exception Uncertain of string Lazy.t;;
+exception AssertFailure of string Lazy.t;;
+
+let insert_coercions = ref true
+
+let debug_print = fun _ -> ()
+
+let profiler = HExtlib.profile "CicRefine.fo_unif"
+
+let fo_unif_subst subst context metasenv t1 t2 ugraph =
+ try
+let foo () =
+ CicUnification.fo_unif_subst subst context metasenv t1 t2 ugraph
+in profiler.HExtlib.profile foo ()
+ with
+ (CicUnification.UnificationFailure msg) -> raise (RefineFailure msg)
+ | (CicUnification.Uncertain msg) -> raise (Uncertain msg)
+;;
+
+let enrich localization_tbl t ?(f = fun msg -> msg) exn =
+ let exn' =
+ match exn with
+ RefineFailure msg -> RefineFailure (f msg)
+ | Uncertain msg -> Uncertain (f msg)
+ | _ -> assert false in
+ let loc =
+ try
+ Cic.CicHash.find localization_tbl t
+ with Not_found ->
+ prerr_endline ("!!! NOT LOCALIZED: " ^ CicPp.ppterm t);
+ assert false
+ in
+ raise (HExtlib.Localized (loc,exn'))
+
+let relocalize localization_tbl oldt newt =
+ try
+ let infos = Cic.CicHash.find localization_tbl oldt in
+ Cic.CicHash.remove localization_tbl oldt;
+ Cic.CicHash.add localization_tbl newt infos;
+ with
+ Not_found -> ()
+;;
+
+let rec split l n =
+ match (l,n) with
+ (l,0) -> ([], l)
+ | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2)
+ | (_,_) -> raise (AssertFailure (lazy "split: list too short"))
+;;
+
+let exp_impl metasenv subst context =
+ function
+ | Some `Type ->
+ let (metasenv', idx) = CicMkImplicit.mk_implicit_type metasenv subst context in
+ let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in
+ metasenv', Cic.Meta (idx, irl)
+ | Some `Closed ->
+ let (metasenv', idx) = CicMkImplicit.mk_implicit metasenv subst [] in
+ metasenv', Cic.Meta (idx, [])
+ | None ->
+ let (metasenv', idx) = CicMkImplicit.mk_implicit metasenv subst context in
+ let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in
+ metasenv', Cic.Meta (idx, irl)
+ | _ -> assert false
+;;
+
+
+let rec type_of_constant uri ugraph =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let _ = CicTypeChecker.typecheck uri in
+ let obj,u =
+ try
+ CicEnvironment.get_cooked_obj ugraph uri
+ with Not_found -> assert false
+ in
+ match obj with
+ C.Constant (_,_,ty,_,_) -> ty,u
+ | C.CurrentProof (_,_,_,ty,_,_) -> ty,u
+ | _ ->
+ raise
+ (RefineFailure (lazy ("Unknown constant definition " ^ U.string_of_uri uri)))
+
+and type_of_variable uri ugraph =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let _ = CicTypeChecker.typecheck uri in
+ let obj,u =
+ try
+ CicEnvironment.get_cooked_obj ugraph uri
+ with Not_found -> assert false
+ in
+ match obj with
+ C.Variable (_,_,ty,_,_) -> ty,u
+ | _ ->
+ raise
+ (RefineFailure
+ (lazy ("Unknown variable definition " ^ UriManager.string_of_uri uri)))
+
+and type_of_mutual_inductive_defs uri i ugraph =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let _ = CicTypeChecker.typecheck uri in
+ let obj,u =
+ try
+ CicEnvironment.get_cooked_obj ugraph uri
+ with Not_found -> assert false
+ in
+ match obj with
+ C.InductiveDefinition (dl,_,_,_) ->
+ let (_,_,arity,_) = List.nth dl i in
+ arity,u
+ | _ ->
+ raise
+ (RefineFailure
+ (lazy ("Unknown mutual inductive definition " ^ U.string_of_uri uri)))
+
+and type_of_mutual_inductive_constr uri i j ugraph =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let _ = CicTypeChecker.typecheck uri in
+ let obj,u =
+ try
+ CicEnvironment.get_cooked_obj ugraph uri
+ with Not_found -> assert false
+ in
+ match obj with
+ C.InductiveDefinition (dl,_,_,_) ->
+ let (_,_,_,cl) = List.nth dl i in
+ let (_,ty) = List.nth cl (j-1) in
+ ty,u
+ | _ ->
+ raise
+ (RefineFailure
+ (lazy
+ ("Unkown mutual inductive definition " ^ U.string_of_uri uri)))
+
+
+(* type_of_aux' is just another name (with a different scope) for type_of_aux *)
+
+(* the check_branch function checks if a branch of a case is refinable.
+ It returns a pair (outype_instance,args), a subst and a metasenv.
+ outype_instance is the expected result of applying the case outtype
+ to args.
+ The problem is that outype is in general unknown, and we should
+ try to synthesize it from the above information, that is in general
+ a second order unification problem. *)
+
+and check_branch n context metasenv subst left_args_no actualtype term expectedtype ugraph =
+ let module C = Cic in
+ (* let module R = CicMetaSubst in *)
+ let module R = CicReduction in
+ match R.whd ~subst context expectedtype with
+ C.MutInd (_,_,_) ->
+ (n,context,actualtype, [term]), subst, metasenv, ugraph
+ | C.Appl (C.MutInd (_,_,_)::tl) ->
+ let (_,arguments) = split tl left_args_no in
+ (n,context,actualtype, arguments@[term]), subst, metasenv, ugraph
+ | C.Prod (name,so,de) ->
+ (* we expect that the actual type of the branch has the due
+ number of Prod *)
+ (match R.whd ~subst context actualtype with
+ C.Prod (name',so',de') ->
+ let subst, metasenv, ugraph1 =
+ fo_unif_subst subst context metasenv so so' ugraph in
+ let term' =
+ (match CicSubstitution.lift 1 term with
+ C.Appl l -> C.Appl (l@[C.Rel 1])
+ | t -> C.Appl [t ; C.Rel 1]) in
+ (* we should also check that the name variable is anonymous in
+ the actual type de' ?? *)
+ check_branch (n+1)
+ ((Some (name,(C.Decl so)))::context)
+ metasenv subst left_args_no de' term' de ugraph1
+ | _ -> raise (AssertFailure (lazy "Wrong number of arguments")))
+ | _ -> raise (AssertFailure (lazy "Prod or MutInd expected"))
+
+and type_of_aux' ?(localization_tbl = Cic.CicHash.create 1) metasenv context t
+ ugraph
+=
+ let rec type_of_aux subst metasenv context t ugraph =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module U = UriManager in
+ let (t',_,_,_,_) as res =
+ match t with
+ (* function *)
+ C.Rel n ->
+ (try
+ match List.nth context (n - 1) with
+ Some (_,C.Decl ty) ->
+ t,S.lift n ty,subst,metasenv, ugraph
+ | Some (_,C.Def (_,Some ty)) ->
+ t,S.lift n ty,subst,metasenv, ugraph
+ | Some (_,C.Def (bo,None)) ->
+ let ty,ugraph =
+ (* if it is in the context it must be already well-typed*)
+ CicTypeChecker.type_of_aux' ~subst metasenv context
+ (S.lift n bo) ugraph
+ in
+ t,ty,subst,metasenv,ugraph
+ | None ->
+ enrich localization_tbl t
+ (RefineFailure (lazy "Rel to hidden hypothesis"))
+ with
+ _ ->
+ enrich localization_tbl t
+ (RefineFailure (lazy "Not a close term")))
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst',subst',metasenv',ugraph1 =
+ check_exp_named_subst
+ subst metasenv context exp_named_subst ugraph
+ in
+ let ty_uri,ugraph1 = type_of_variable uri ugraph in
+ let ty =
+ CicSubstitution.subst_vars exp_named_subst' ty_uri
+ in
+ C.Var (uri,exp_named_subst'),ty,subst',metasenv',ugraph1
+ | C.Meta (n,l) ->
+ (try
+ let (canonical_context, term,ty) =
+ CicUtil.lookup_subst n subst
+ in
+ let l',subst',metasenv',ugraph1 =
+ check_metasenv_consistency n subst metasenv context
+ canonical_context l ugraph
+ in
+ (* trust or check ??? *)
+ C.Meta (n,l'),CicSubstitution.subst_meta l' ty,
+ subst', metasenv', ugraph1
+ (* type_of_aux subst metasenv
+ context (CicSubstitution.subst_meta l term) *)
+ with CicUtil.Subst_not_found _ ->
+ let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in
+ let l',subst',metasenv', ugraph1 =
+ check_metasenv_consistency n subst metasenv context
+ canonical_context l ugraph
+ in
+ C.Meta (n,l'),CicSubstitution.subst_meta l' ty,
+ subst', metasenv',ugraph1)
+ | C.Sort (C.Type tno) ->
+ let tno' = CicUniv.fresh() in
+ let ugraph1 = CicUniv.add_gt tno' tno ugraph in
+ t,(C.Sort (C.Type tno')),subst,metasenv,ugraph1
+ | C.Sort _ ->
+ t,C.Sort (C.Type (CicUniv.fresh())),subst,metasenv,ugraph
+ | C.Implicit infos ->
+ let metasenv',t' = exp_impl metasenv subst context infos in
+ type_of_aux subst metasenv' context t' ugraph
+ | C.Cast (te,ty) ->
+ let ty',_,subst',metasenv',ugraph1 =
+ type_of_aux subst metasenv context ty ugraph
+ in
+ let te',inferredty,subst'',metasenv'',ugraph2 =
+ type_of_aux subst' metasenv' context te ugraph1
+ in
+ (try
+ let subst''',metasenv''',ugraph3 =
+ fo_unif_subst subst'' context metasenv''
+ inferredty ty' ugraph2
+ in
+ C.Cast (te',ty'),ty',subst''',metasenv''',ugraph3
+ with
+ exn ->
+ enrich localization_tbl te'
+ ~f:(fun _ ->
+ lazy ("The term " ^
+ CicMetaSubst.ppterm_in_context subst'' te'
+ context ^ " has type " ^
+ CicMetaSubst.ppterm_in_context subst'' inferredty
+ context ^ " but is here used with type " ^
+ CicMetaSubst.ppterm_in_context subst'' ty' context)) exn
+ )
+ | C.Prod (name,s,t) ->
+ let carr t subst context = CicMetaSubst.apply_subst subst t in
+ let coerce_to_sort in_source tgt_sort t type_to_coerce
+ subst context metasenv uragph
+ =
+ if not !insert_coercions then
+ t,type_to_coerce,subst,metasenv,ugraph
+ else
+ let coercion_src = carr type_to_coerce subst context in
+ match coercion_src with
+ | Cic.Sort _ ->
+ t,type_to_coerce,subst,metasenv,ugraph
+ | Cic.Meta _ as meta ->
+ t, meta, subst, metasenv, ugraph
+ | Cic.Cast _ as cast ->
+ t, cast, subst, metasenv, ugraph
+ | term ->
+ let coercion_tgt = carr (Cic.Sort tgt_sort) subst context in
+ let search = CoercGraph.look_for_coercion in
+ let boh = search coercion_src coercion_tgt in
+ (match boh with
+ | CoercGraph.NoCoercion
+ | CoercGraph.NotHandled _ ->
+ enrich localization_tbl t
+ (RefineFailure
+ (lazy ("The term " ^
+ CicMetaSubst.ppterm_in_context subst t context ^
+ " is not a type since it has type " ^
+ CicMetaSubst.ppterm_in_context
+ subst coercion_src context ^ " that is not a sort")))
+ | CoercGraph.NotMetaClosed ->
+ enrich localization_tbl t
+ (Uncertain
+ (lazy ("The term " ^
+ CicMetaSubst.ppterm_in_context subst t context ^
+ " is not a type since it has type " ^
+ CicMetaSubst.ppterm_in_context
+ subst coercion_src context ^ " that is not a sort")))
+ | CoercGraph.SomeCoercion c ->
+ let newt, tty, subst, metasenv, ugraph =
+ avoid_double_coercion
+ subst metasenv ugraph
+ (Cic.Appl[c;t]) coercion_tgt
+ in
+ newt, tty, subst, metasenv, ugraph)
+ in
+ let s',sort1,subst',metasenv',ugraph1 =
+ type_of_aux subst metasenv context s ugraph
+ in
+ let s',sort1,subst', metasenv',ugraph1 =
+ coerce_to_sort true (Cic.Type(CicUniv.fresh()))
+ s' sort1 subst' context metasenv' ugraph1
+ in
+ let context_for_t = ((Some (name,(C.Decl s')))::context) in
+ let t',sort2,subst'',metasenv'',ugraph2 =
+ type_of_aux subst' metasenv'
+ context_for_t t ugraph1
+ in
+ let t',sort2,subst'',metasenv'',ugraph2 =
+ coerce_to_sort false (Cic.Type(CicUniv.fresh()))
+ t' sort2 subst'' context_for_t metasenv'' ugraph2
+ in
+ let sop,subst''',metasenv''',ugraph3 =
+ sort_of_prod subst'' metasenv''
+ context (name,s') (sort1,sort2) ugraph2
+ in
+ C.Prod (name,s',t'),sop,subst''',metasenv''',ugraph3
+ | C.Lambda (n,s,t) ->
+
+ let s',sort1,subst',metasenv',ugraph1 =
+ type_of_aux subst metasenv context s ugraph in
+ let s',sort1,subst',metasenv',ugraph1 =
+ if not !insert_coercions then
+ s',sort1, subst', metasenv', ugraph1
+ else
+ match CicReduction.whd ~subst:subst' context sort1 with
+ | C.Meta _ | C.Sort _ -> s',sort1, subst', metasenv', ugraph1
+ | coercion_src ->
+ let coercion_tgt = Cic.Sort (Cic.Type (CicUniv.fresh())) in
+ let search = CoercGraph.look_for_coercion in
+ let boh = search coercion_src coercion_tgt in
+ match boh with
+ | CoercGraph.SomeCoercion c ->
+ let newt, tty, subst', metasenv', ugraph1 =
+ avoid_double_coercion
+ subst' metasenv' ugraph1
+ (Cic.Appl[c;s']) coercion_tgt
+ in
+ newt, tty, subst', metasenv', ugraph1
+ | CoercGraph.NoCoercion
+ | CoercGraph.NotHandled _ ->
+ enrich localization_tbl s'
+ (RefineFailure
+ (lazy ("The term " ^
+ CicMetaSubst.ppterm_in_context subst s' context ^
+ " is not a type since it has type " ^
+ CicMetaSubst.ppterm_in_context
+ subst coercion_src context ^ " that is not a sort")))
+ | CoercGraph.NotMetaClosed ->
+ enrich localization_tbl s'
+ (Uncertain
+ (lazy ("The term " ^
+ CicMetaSubst.ppterm_in_context subst s' context ^
+ " is not a type since it has type " ^
+ CicMetaSubst.ppterm_in_context
+ subst coercion_src context ^ " that is not a sort")))
+ in
+ let context_for_t = ((Some (n,(C.Decl s')))::context) in
+ let t',type2,subst'',metasenv'',ugraph2 =
+ type_of_aux subst' metasenv' context_for_t t ugraph1
+ in
+ C.Lambda (n,s',t'),C.Prod (n,s',type2),
+ subst'',metasenv'',ugraph2
+ | C.LetIn (n,s,t) ->
+ (* only to check if s is well-typed *)
+ let s',ty,subst',metasenv',ugraph1 =
+ type_of_aux subst metasenv context s ugraph
+ in
+ let context_for_t = ((Some (n,(C.Def (s',Some ty))))::context) in
+
+ let t',inferredty,subst'',metasenv'',ugraph2 =
+ type_of_aux subst' metasenv'
+ context_for_t t ugraph1
+ in
+ (* One-step LetIn reduction.
+ * Even faster than the previous solution.
+ * Moreover the inferred type is closer to the expected one.
+ *)
+ C.LetIn (n,s',t'),CicSubstitution.subst s' inferredty,
+ subst'',metasenv'',ugraph2
+ | C.Appl (he::((_::_) as tl)) ->
+ let he',hetype,subst',metasenv',ugraph1 =
+ type_of_aux subst metasenv context he ugraph
+ in
+ let tlbody_and_type,subst'',metasenv'',ugraph2 =
+ List.fold_right
+ (fun x (res,subst,metasenv,ugraph) ->
+ let x',ty,subst',metasenv',ugraph1 =
+ type_of_aux subst metasenv context x ugraph
+ in
+ (x', ty)::res,subst',metasenv',ugraph1
+ ) tl ([],subst',metasenv',ugraph1)
+ in
+ let tl',applty,subst''',metasenv''',ugraph3 =
+ eat_prods true subst'' metasenv'' context
+ hetype tlbody_and_type ugraph2
+ in
+ avoid_double_coercion
+ subst''' metasenv''' ugraph3 (C.Appl (he'::tl')) applty
+ | C.Appl _ -> assert false
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst',subst',metasenv',ugraph1 =
+ check_exp_named_subst subst metasenv context
+ exp_named_subst ugraph in
+ let ty_uri,ugraph2 = type_of_constant uri ugraph1 in
+ let cty =
+ CicSubstitution.subst_vars exp_named_subst' ty_uri
+ in
+ C.Const (uri,exp_named_subst'),cty,subst',metasenv',ugraph2
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let exp_named_subst',subst',metasenv',ugraph1 =
+ check_exp_named_subst subst metasenv context
+ exp_named_subst ugraph
+ in
+ let ty_uri,ugraph2 = type_of_mutual_inductive_defs uri i ugraph1 in
+ let cty =
+ CicSubstitution.subst_vars exp_named_subst' ty_uri in
+ C.MutInd (uri,i,exp_named_subst'),cty,subst',metasenv',ugraph2
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let exp_named_subst',subst',metasenv',ugraph1 =
+ check_exp_named_subst subst metasenv context
+ exp_named_subst ugraph
+ in
+ let ty_uri,ugraph2 =
+ type_of_mutual_inductive_constr uri i j ugraph1
+ in
+ let cty =
+ CicSubstitution.subst_vars exp_named_subst' ty_uri
+ in
+ C.MutConstruct (uri,i,j,exp_named_subst'),cty,subst',
+ metasenv',ugraph2
+ | C.MutCase (uri, i, outtype, term, pl) ->
+ (* first, get the inductive type (and noparams)
+ * in the environment *)
+ let (_,b,arity,constructors), expl_params, no_left_params,ugraph =
+ let _ = CicTypeChecker.typecheck uri in
+ let obj,u = CicEnvironment.get_cooked_obj ugraph uri in
+ match obj with
+ C.InductiveDefinition (l,expl_params,parsno,_) ->
+ List.nth l i , expl_params, parsno, u
+ | _ ->
+ enrich localization_tbl t
+ (RefineFailure
+ (lazy ("Unkown mutual inductive definition " ^
+ U.string_of_uri uri)))
+ in
+ let rec count_prod t =
+ match CicReduction.whd ~subst context t with
+ C.Prod (_, _, t) -> 1 + (count_prod t)
+ | _ -> 0
+ in
+ let no_args = count_prod arity in
+ (* now, create a "generic" MutInd *)
+ let metasenv,left_args =
+ CicMkImplicit.n_fresh_metas metasenv subst context no_left_params
+ in
+ let metasenv,right_args =
+ let no_right_params = no_args - no_left_params in
+ if no_right_params < 0 then assert false
+ else CicMkImplicit.n_fresh_metas
+ metasenv subst context no_right_params
+ in
+ let metasenv,exp_named_subst =
+ CicMkImplicit.fresh_subst metasenv subst context expl_params in
+ let expected_type =
+ if no_args = 0 then
+ C.MutInd (uri,i,exp_named_subst)
+ else
+ C.Appl
+ (C.MutInd (uri,i,exp_named_subst)::(left_args @ right_args))
+ in
+ (* check consistency with the actual type of term *)
+ let term',actual_type,subst,metasenv,ugraph1 =
+ type_of_aux subst metasenv context term ugraph in
+ let expected_type',_, subst, metasenv,ugraph2 =
+ type_of_aux subst metasenv context expected_type ugraph1
+ in
+ let actual_type = CicReduction.whd ~subst context actual_type in
+ let subst,metasenv,ugraph3 =
+ try
+ fo_unif_subst subst context metasenv
+ expected_type' actual_type ugraph2
+ with
+ exn ->
+ enrich localization_tbl term' exn
+ ~f:(function _ ->
+ lazy ("The term " ^
+ CicMetaSubst.ppterm_in_context subst term'
+ context ^ " has type " ^
+ CicMetaSubst.ppterm_in_context subst actual_type
+ context ^ " but is here used with type " ^
+ CicMetaSubst.ppterm_in_context subst expected_type' context))
+ in
+ let rec instantiate_prod t =
+ function
+ [] -> t
+ | he::tl ->
+ match CicReduction.whd ~subst context t with
+ C.Prod (_,_,t') ->
+ instantiate_prod (CicSubstitution.subst he t') tl
+ | _ -> assert false
+ in
+ let arity_instantiated_with_left_args =
+ instantiate_prod arity left_args in
+ (* TODO: check if the sort elimination
+ * is allowed: [(I q1 ... qr)|B] *)
+ let (pl',_,outtypeinstances,subst,metasenv,ugraph4) =
+ List.fold_left
+ (fun (pl,j,outtypeinstances,subst,metasenv,ugraph) p ->
+ let constructor =
+ if left_args = [] then
+ (C.MutConstruct (uri,i,j,exp_named_subst))
+ else
+ (C.Appl
+ (C.MutConstruct (uri,i,j,exp_named_subst)::left_args))
+ in
+ let p',actual_type,subst,metasenv,ugraph1 =
+ type_of_aux subst metasenv context p ugraph
+ in
+ let constructor',expected_type, subst, metasenv,ugraph2 =
+ type_of_aux subst metasenv context constructor ugraph1
+ in
+ let outtypeinstance,subst,metasenv,ugraph3 =
+ check_branch 0 context metasenv subst no_left_params
+ actual_type constructor' expected_type ugraph2
+ in
+ (pl @ [p'],j+1,
+ outtypeinstance::outtypeinstances,subst,metasenv,ugraph3))
+ ([],1,[],subst,metasenv,ugraph3) pl
+ in
+
+ (* we are left to check that the outype matches his instances.
+ The easy case is when the outype is specified, that amount
+ to a trivial check. Otherwise, we should guess a type from
+ its instances
+ *)
+
+ let outtype,outtypety, subst, metasenv,ugraph4 =
+ type_of_aux subst metasenv context outtype ugraph4 in
+ (match outtype with
+ | C.Meta (n,l) ->
+ (let candidate,ugraph5,metasenv,subst =
+ let exp_name_subst, metasenv =
+ let o,_ =
+ CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri
+ in
+ let uris = CicUtil.params_of_obj o in
+ List.fold_right (
+ fun uri (acc,metasenv) ->
+ let metasenv',new_meta =
+ CicMkImplicit.mk_implicit metasenv subst context
+ in
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable
+ context
+ in
+ (uri, Cic.Meta(new_meta,irl))::acc, metasenv'
+ ) uris ([],metasenv)
+ in
+ let ty =
+ match left_args,right_args with
+ [],[] -> Cic.MutInd(uri, i, exp_name_subst)
+ | _,_ ->
+ let rec mk_right_args =
+ function
+ 0 -> []
+ | n -> (Cic.Rel n)::(mk_right_args (n - 1))
+ in
+ let right_args_no = List.length right_args in
+ let lifted_left_args =
+ List.map (CicSubstitution.lift right_args_no) left_args
+ in
+ Cic.Appl (Cic.MutInd(uri,i,exp_name_subst)::
+ (lifted_left_args @ mk_right_args right_args_no))
+ in
+ let fresh_name =
+ FreshNamesGenerator.mk_fresh_name ~subst metasenv
+ context Cic.Anonymous ~typ:ty
+ in
+ match outtypeinstances with
+ | [] ->
+ let extended_context =
+ let rec add_right_args =
+ function
+ Cic.Prod (name,ty,t) ->
+ Some (name,Cic.Decl ty)::(add_right_args t)
+ | _ -> []
+ in
+ (Some (fresh_name,Cic.Decl ty))::
+ (List.rev
+ (add_right_args arity_instantiated_with_left_args))@
+ context
+ in
+ let metasenv,new_meta =
+ CicMkImplicit.mk_implicit metasenv subst extended_context
+ in
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable
+ extended_context
+ in
+ let rec add_lambdas b =
+ function
+ Cic.Prod (name,ty,t) ->
+ Cic.Lambda (name,ty,(add_lambdas b t))
+ | _ -> Cic.Lambda (fresh_name, ty, b)
+ in
+ let candidate =
+ add_lambdas (Cic.Meta (new_meta,irl))
+ arity_instantiated_with_left_args
+ in
+ (Some candidate),ugraph4,metasenv,subst
+ | (constructor_args_no,_,instance,_)::tl ->
+ try
+ let instance',subst,metasenv =
+ CicMetaSubst.delift_rels subst metasenv
+ constructor_args_no instance
+ in
+ let candidate,ugraph,metasenv,subst =
+ List.fold_left (
+ fun (candidate_oty,ugraph,metasenv,subst)
+ (constructor_args_no,_,instance,_) ->
+ match candidate_oty with
+ | None -> None,ugraph,metasenv,subst
+ | Some ty ->
+ try
+ let instance',subst,metasenv =
+ CicMetaSubst.delift_rels subst metasenv
+ constructor_args_no instance
+ in
+ let subst,metasenv,ugraph =
+ fo_unif_subst subst context metasenv
+ instance' ty ugraph
+ in
+ candidate_oty,ugraph,metasenv,subst
+ with
+ CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable
+ | CicUnification.UnificationFailure _
+ | CicUnification.Uncertain _ ->
+ None,ugraph,metasenv,subst
+ ) (Some instance',ugraph4,metasenv,subst) tl
+ in
+ match candidate with
+ | None -> None, ugraph,metasenv,subst
+ | Some t ->
+ let rec add_lambdas n b =
+ function
+ Cic.Prod (name,ty,t) ->
+ Cic.Lambda (name,ty,(add_lambdas (n + 1) b t))
+ | _ ->
+ Cic.Lambda (fresh_name, ty,
+ CicSubstitution.lift (n + 1) t)
+ in
+ Some
+ (add_lambdas 0 t arity_instantiated_with_left_args),
+ ugraph,metasenv,subst
+ with CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
+ None,ugraph4,metasenv,subst
+ in
+ match candidate with
+ | None -> raise (Uncertain (lazy "can't solve an higher order unification problem"))
+ | Some candidate ->
+ let subst,metasenv,ugraph =
+ fo_unif_subst subst context metasenv
+ candidate outtype ugraph5
+ in
+ C.MutCase (uri, i, outtype, term', pl'),
+ CicReduction.head_beta_reduce
+ (CicMetaSubst.apply_subst subst
+ (Cic.Appl (outtype::right_args@[term']))),
+ subst,metasenv,ugraph)
+ | _ -> (* easy case *)
+ let tlbody_and_type,subst,metasenv,ugraph4 =
+ List.fold_right
+ (fun x (res,subst,metasenv,ugraph) ->
+ let x',ty,subst',metasenv',ugraph1 =
+ type_of_aux subst metasenv context x ugraph
+ in
+ (x', ty)::res,subst',metasenv',ugraph1
+ ) (right_args @ [term']) ([],subst,metasenv,ugraph4)
+ in
+ let _,_,subst,metasenv,ugraph4 =
+ eat_prods false subst metasenv context
+ outtypety tlbody_and_type ugraph4
+ in
+ let _,_, subst, metasenv,ugraph5 =
+ type_of_aux subst metasenv context
+ (C.Appl ((outtype :: right_args) @ [term'])) ugraph4
+ in
+ let (subst,metasenv,ugraph6) =
+ List.fold_left
+ (fun (subst,metasenv,ugraph)
+ (constructor_args_no,context,instance,args) ->
+ let instance' =
+ let appl =
+ let outtype' =
+ CicSubstitution.lift constructor_args_no outtype
+ in
+ C.Appl (outtype'::args)
+ in
+ CicReduction.whd ~subst context appl
+ in
+ fo_unif_subst subst context metasenv
+ instance instance' ugraph)
+ (subst,metasenv,ugraph5) outtypeinstances
+ in
+ C.MutCase (uri, i, outtype, term', pl'),
+ CicReduction.head_beta_reduce
+ (CicMetaSubst.apply_subst subst
+ (C.Appl(outtype::right_args@[term]))),
+ subst,metasenv,ugraph6)
+ | C.Fix (i,fl) ->
+ let fl_ty',subst,metasenv,types,ugraph1 =
+ List.fold_left
+ (fun (fl,subst,metasenv,types,ugraph) (n,_,ty,_) ->
+ let ty',_,subst',metasenv',ugraph1 =
+ type_of_aux subst metasenv context ty ugraph
+ in
+ fl @ [ty'],subst',metasenv',
+ Some (C.Name n,(C.Decl ty')) :: types, ugraph
+ ) ([],subst,metasenv,[],ugraph) fl
+ in
+ let len = List.length types in
+ let context' = types@context in
+ let fl_bo',subst,metasenv,ugraph2 =
+ List.fold_left
+ (fun (fl,subst,metasenv,ugraph) ((name,x,_,bo),ty) ->
+ let bo',ty_of_bo,subst,metasenv,ugraph1 =
+ type_of_aux subst metasenv context' bo ugraph
+ in
+ let subst',metasenv',ugraph' =
+ fo_unif_subst subst context' metasenv
+ ty_of_bo (CicSubstitution.lift len ty) ugraph1
+ in
+ fl @ [bo'] , subst',metasenv',ugraph'
+ ) ([],subst,metasenv,ugraph1) (List.combine fl fl_ty')
+ in
+ let ty = List.nth fl_ty' i in
+ (* now we have the new ty in fl_ty', the new bo in fl_bo',
+ * and we want the new fl with bo' and ty' injected in the right
+ * place.
+ *)
+ let rec map3 f l1 l2 l3 =
+ match l1,l2,l3 with
+ | [],[],[] -> []
+ | h1::tl1,h2::tl2,h3::tl3 -> (f h1 h2 h3) :: (map3 f tl1 tl2 tl3)
+ | _ -> assert false
+ in
+ let fl'' = map3 (fun ty' bo' (name,x,ty,bo) -> (name,x,ty',bo') )
+ fl_ty' fl_bo' fl
+ in
+ C.Fix (i,fl''),ty,subst,metasenv,ugraph2
+ | C.CoFix (i,fl) ->
+ let fl_ty',subst,metasenv,types,ugraph1 =
+ List.fold_left
+ (fun (fl,subst,metasenv,types,ugraph) (n,ty,_) ->
+ let ty',_,subst',metasenv',ugraph1 =
+ type_of_aux subst metasenv context ty ugraph
+ in
+ fl @ [ty'],subst',metasenv',
+ Some (C.Name n,(C.Decl ty')) :: types, ugraph1
+ ) ([],subst,metasenv,[],ugraph) fl
+ in
+ let len = List.length types in
+ let context' = types@context in
+ let fl_bo',subst,metasenv,ugraph2 =
+ List.fold_left
+ (fun (fl,subst,metasenv,ugraph) ((name,_,bo),ty) ->
+ let bo',ty_of_bo,subst,metasenv,ugraph1 =
+ type_of_aux subst metasenv context' bo ugraph
+ in
+ let subst',metasenv',ugraph' =
+ fo_unif_subst subst context' metasenv
+ ty_of_bo (CicSubstitution.lift len ty) ugraph1
+ in
+ fl @ [bo'],subst',metasenv',ugraph'
+ ) ([],subst,metasenv,ugraph1) (List.combine fl fl_ty')
+ in
+ let ty = List.nth fl_ty' i in
+ (* now we have the new ty in fl_ty', the new bo in fl_bo',
+ * and we want the new fl with bo' and ty' injected in the right
+ * place.
+ *)
+ let rec map3 f l1 l2 l3 =
+ match l1,l2,l3 with
+ | [],[],[] -> []
+ | h1::tl1,h2::tl2,h3::tl3 -> (f h1 h2 h3) :: (map3 f tl1 tl2 tl3)
+ | _ -> assert false
+ in
+ let fl'' = map3 (fun ty' bo' (name,ty,bo) -> (name,ty',bo') )
+ fl_ty' fl_bo' fl
+ in
+ C.CoFix (i,fl''),ty,subst,metasenv,ugraph2
+ in
+ relocalize localization_tbl t t';
+ res
+
+ and avoid_double_coercion subst metasenv ugraph t ty =
+ match t with
+ | (Cic.Appl [ c1 ; (Cic.Appl [c2; head]) ]) when
+ CoercGraph.is_a_coercion c1 && CoercGraph.is_a_coercion c2 ->
+ let source_carr = CoercGraph.source_of c2 in
+ let tgt_carr = CicMetaSubst.apply_subst subst ty in
+ (match CoercGraph.look_for_coercion source_carr tgt_carr
+ with
+ | CoercGraph.SomeCoercion c ->
+ Cic.Appl [ c ; head ], ty, subst,metasenv,ugraph
+ | _ -> assert false) (* the composite coercion must exist *)
+ | _ -> t, ty, subst, metasenv, ugraph
+
+ (* check_metasenv_consistency checks that the "canonical" context of a
+ metavariable is consitent - up to relocation via the relocation list l -
+ with the actual context *)
+ and check_metasenv_consistency
+ metano subst metasenv context canonical_context l ugraph
+ =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module S = CicSubstitution in
+ let lifted_canonical_context =
+ let rec aux i =
+ function
+ [] -> []
+ | (Some (n,C.Decl t))::tl ->
+ (Some (n,C.Decl (S.subst_meta l (S.lift i t))))::(aux (i+1) tl)
+ | (Some (n,C.Def (t,None)))::tl ->
+ (Some (n,C.Def ((S.subst_meta l (S.lift i t)),None)))::(aux (i+1) tl)
+ | None::tl -> None::(aux (i+1) tl)
+ | (Some (n,C.Def (t,Some ty)))::tl ->
+ (Some (n,
+ C.Def ((S.subst_meta l (S.lift i t)),
+ Some (S.subst_meta l (S.lift i ty))))) :: (aux (i+1) tl)
+ in
+ aux 1 canonical_context
+ in
+ try
+ List.fold_left2
+ (fun (l,subst,metasenv,ugraph) t ct ->
+ match (t,ct) with
+ _,None ->
+ l @ [None],subst,metasenv,ugraph
+ | Some t,Some (_,C.Def (ct,_)) ->
+ let subst',metasenv',ugraph' =
+ (try
+ fo_unif_subst subst context metasenv t ct ugraph
+ with e -> raise (RefineFailure (lazy (sprintf "The local context is not consistent with the canonical context, since %s cannot be unified with %s. Reason: %s" (CicMetaSubst.ppterm subst t) (CicMetaSubst.ppterm subst ct) (match e with AssertFailure msg -> Lazy.force msg | _ -> (Printexc.to_string e))))))
+ in
+ l @ [Some t],subst',metasenv',ugraph'
+ | Some t,Some (_,C.Decl ct) ->
+ let t',inferredty,subst',metasenv',ugraph1 =
+ type_of_aux subst metasenv context t ugraph
+ in
+ let subst'',metasenv'',ugraph2 =
+ (try
+ fo_unif_subst
+ subst' context metasenv' inferredty ct ugraph1
+ with e -> raise (RefineFailure (lazy (sprintf "The local context is not consistent with the canonical context, since the type %s of %s cannot be unified with the expected type %s. Reason: %s" (CicMetaSubst.ppterm subst' inferredty) (CicMetaSubst.ppterm subst' t) (CicMetaSubst.ppterm subst' ct) (match e with AssertFailure msg -> Lazy.force msg | RefineFailure msg -> Lazy.force msg | _ -> (Printexc.to_string e))))))
+ in
+ l @ [Some t'], subst'',metasenv'',ugraph2
+ | None, Some _ ->
+ raise (RefineFailure (lazy (sprintf "Not well typed metavariable instance %s: the local context does not instantiate an hypothesis even if the hypothesis is not restricted in the canonical context %s" (CicMetaSubst.ppterm subst (Cic.Meta (metano, l))) (CicMetaSubst.ppcontext subst canonical_context))))) ([],subst,metasenv,ugraph) l lifted_canonical_context
+ with
+ Invalid_argument _ ->
+ raise
+ (RefineFailure
+ (lazy (sprintf
+ "Not well typed metavariable instance %s: the length of the local context does not match the length of the canonical context %s"
+ (CicMetaSubst.ppterm subst (Cic.Meta (metano, l)))
+ (CicMetaSubst.ppcontext subst canonical_context))))
+
+ and check_exp_named_subst metasubst metasenv context tl ugraph =
+ let rec check_exp_named_subst_aux metasubst metasenv substs tl ugraph =
+ match tl with
+ [] -> [],metasubst,metasenv,ugraph
+ | (uri,t)::tl ->
+ let ty_uri,ugraph1 = type_of_variable uri ugraph in
+ let typeofvar =
+ CicSubstitution.subst_vars substs ty_uri in
+ (* CSC: why was this code here? it is wrong
+ (match CicEnvironment.get_cooked_obj ~trust:false uri with
+ Cic.Variable (_,Some bo,_,_) ->
+ raise
+ (RefineFailure (lazy
+ "A variable with a body can not be explicit substituted"))
+ | Cic.Variable (_,None,_,_) -> ()
+ | _ ->
+ raise
+ (RefineFailure (lazy
+ ("Unkown variable definition " ^ UriManager.string_of_uri uri)))
+ ) ;
+ *)
+ let t',typeoft,metasubst',metasenv',ugraph2 =
+ type_of_aux metasubst metasenv context t ugraph1 in
+ let subst = uri,t' in
+ let metasubst'',metasenv'',ugraph3 =
+ try
+ fo_unif_subst
+ metasubst' context metasenv' typeoft typeofvar ugraph2
+ with _ ->
+ raise (RefineFailure (lazy
+ ("Wrong Explicit Named Substitution: " ^
+ CicMetaSubst.ppterm metasubst' typeoft ^
+ " not unifiable with " ^
+ CicMetaSubst.ppterm metasubst' typeofvar)))
+ in
+ (* FIXME: no mere tail recursive! *)
+ let exp_name_subst, metasubst''', metasenv''', ugraph4 =
+ check_exp_named_subst_aux
+ metasubst'' metasenv'' (substs@[subst]) tl ugraph3
+ in
+ ((uri,t')::exp_name_subst), metasubst''', metasenv''', ugraph4
+ in
+ check_exp_named_subst_aux metasubst metasenv [] tl ugraph
+
+
+ and sort_of_prod subst metasenv context (name,s) (t1, t2) ugraph =
+ let module C = Cic in
+ let context_for_t2 = (Some (name,C.Decl s))::context in
+ let t1'' = CicReduction.whd ~subst context t1 in
+ let t2'' = CicReduction.whd ~subst context_for_t2 t2 in
+ match (t1'', t2'') with
+ (C.Sort s1, C.Sort s2)
+ when (s2 = C.Prop or s2 = C.Set or s2 = C.CProp) ->
+ (* different than Coq manual!!! *)
+ C.Sort s2,subst,metasenv,ugraph
+ | (C.Sort (C.Type t1), C.Sort (C.Type t2)) ->
+ let t' = CicUniv.fresh() in
+ let ugraph1 = CicUniv.add_ge t' t1 ugraph in
+ let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in
+ C.Sort (C.Type t'),subst,metasenv,ugraph2
+ | (C.Sort _,C.Sort (C.Type t1)) ->
+ C.Sort (C.Type t1),subst,metasenv,ugraph
+ | (C.Meta _, C.Sort _) -> t2'',subst,metasenv,ugraph
+ | (C.Sort _,C.Meta _) | (C.Meta _,C.Meta _) ->
+ (* TODO how can we force the meta to become a sort? If we don't we
+ * brake the invariant that refine produce only well typed terms *)
+ (* TODO if we check the non meta term and if it is a sort then we
+ * are likely to know the exact value of the result e.g. if the rhs
+ * is a Sort (Prop | Set | CProp) then the result is the rhs *)
+ let (metasenv,idx) =
+ CicMkImplicit.mk_implicit_sort metasenv subst in
+ let (subst, metasenv,ugraph1) =
+ fo_unif_subst subst context_for_t2 metasenv
+ (C.Meta (idx,[])) t2'' ugraph
+ in
+ t2'',subst,metasenv,ugraph1
+ | _,_ ->
+ raise
+ (RefineFailure
+ (lazy
+ (sprintf
+ ("Two sorts were expected, found %s " ^^
+ "(that reduces to %s) and %s (that reduces to %s)")
+ (CicPp.ppterm t1) (CicPp.ppterm t1'') (CicPp.ppterm t2)
+ (CicPp.ppterm t2''))))
+
+ and eat_prods
+ allow_coercions subst metasenv context hetype tlbody_and_type ugraph
+ =
+ let rec mk_prod metasenv context' =
+ function
+ [] ->
+ let (metasenv, idx) =
+ CicMkImplicit.mk_implicit_type metasenv subst context'
+ in
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context'
+ in
+ metasenv,Cic.Meta (idx, irl)
+ | (_,argty)::tl ->
+ let (metasenv, idx) =
+ CicMkImplicit.mk_implicit_type metasenv subst context'
+ in
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context'
+ in
+ let meta = Cic.Meta (idx,irl) in
+ let name =
+ (* The name must be fresh for context. *)
+ (* Nevertheless, argty is well-typed only in context. *)
+ (* Thus I generate a name (name_hint) in context and *)
+ (* then I generate a name --- using the hint name_hint *)
+ (* --- that is fresh in context'. *)
+ let name_hint =
+ (* Cic.Name "pippo" *)
+ FreshNamesGenerator.mk_fresh_name ~subst metasenv
+ (* (CicMetaSubst.apply_subst_metasenv subst metasenv) *)
+ (CicMetaSubst.apply_subst_context subst context)
+ Cic.Anonymous
+ ~typ:(CicMetaSubst.apply_subst subst argty)
+ in
+ (* [] and (Cic.Sort Cic.prop) are dummy: they will not be used *)
+ FreshNamesGenerator.mk_fresh_name ~subst
+ [] context' name_hint ~typ:(Cic.Sort Cic.Prop)
+ in
+ let metasenv,target =
+ mk_prod metasenv ((Some (name, Cic.Decl meta))::context') tl
+ in
+ metasenv,Cic.Prod (name,meta,target)
+ in
+ let metasenv,hetype' = mk_prod metasenv context tlbody_and_type in
+ let (subst, metasenv,ugraph1) =
+ try
+ fo_unif_subst subst context metasenv hetype hetype' ugraph
+ with exn ->
+ debug_print (lazy (Printf.sprintf "hetype=%s\nhetype'=%s\nmetasenv=%s\nsubst=%s"
+ (CicPp.ppterm hetype)
+ (CicPp.ppterm hetype')
+ (CicMetaSubst.ppmetasenv [] metasenv)
+ (CicMetaSubst.ppsubst subst)));
+ raise exn
+
+ in
+ let rec eat_prods metasenv subst context hetype ugraph =
+ function
+ | [] -> [],metasenv,subst,hetype,ugraph
+ | (hete, hety)::tl ->
+ (match hetype with
+ Cic.Prod (n,s,t) ->
+ let arg,subst,metasenv,ugraph1 =
+ try
+ let subst,metasenv,ugraph1 =
+ fo_unif_subst subst context metasenv hety s ugraph
+ in
+ hete,subst,metasenv,ugraph1
+ with exn when allow_coercions && !insert_coercions ->
+ (* we search a coercion from hety to s *)
+ let coer, tgt_carr =
+ let carr t subst context =
+ CicMetaSubst.apply_subst subst t
+ in
+ let c_hety = carr hety subst context in
+ let c_s = carr s subst context in
+ CoercGraph.look_for_coercion c_hety c_s, c_s
+ in
+ (match coer with
+ | CoercGraph.NoCoercion
+ | CoercGraph.NotHandled _ ->
+ enrich localization_tbl hete
+ (RefineFailure
+ (lazy ("The term " ^
+ CicMetaSubst.ppterm_in_context subst hete
+ context ^ " has type " ^
+ CicMetaSubst.ppterm_in_context subst hety
+ context ^ " but is here used with type " ^
+ CicMetaSubst.ppterm_in_context subst s context
+ (* "\nReason: " ^ Lazy.force e*))))
+ | CoercGraph.NotMetaClosed ->
+ enrich localization_tbl hete
+ (Uncertain
+ (lazy ("The term " ^
+ CicMetaSubst.ppterm_in_context subst hete
+ context ^ " has type " ^
+ CicMetaSubst.ppterm_in_context subst hety
+ context ^ " but is here used with type " ^
+ CicMetaSubst.ppterm_in_context subst s context
+ (* "\nReason: " ^ Lazy.force e*))))
+ | CoercGraph.SomeCoercion c ->
+ let newt, _, subst, metasenv, ugraph =
+ avoid_double_coercion
+ subst metasenv ugraph
+ (Cic.Appl[c;hete]) tgt_carr in
+ try
+ let newty,newhety,subst,metasenv,ugraph =
+ type_of_aux subst metasenv context newt ugraph in
+ let subst,metasenv,ugraph1 =
+ fo_unif_subst subst context metasenv
+ newhety s ugraph
+ in
+ newt, subst, metasenv, ugraph
+ with exn ->
+ enrich localization_tbl hete
+ ~f:(fun _ ->
+ (lazy ("The term " ^
+ CicMetaSubst.ppterm_in_context subst hete
+ context ^ " has type " ^
+ CicMetaSubst.ppterm_in_context subst hety
+ context ^ " but is here used with type " ^
+ CicMetaSubst.ppterm_in_context subst s context
+ (* "\nReason: " ^ Lazy.force e*)))) exn)
+ | exn ->
+ enrich localization_tbl hete
+ ~f:(fun _ ->
+ (lazy ("The term " ^
+ CicMetaSubst.ppterm_in_context subst hete
+ context ^ " has type " ^
+ CicMetaSubst.ppterm_in_context subst hety
+ context ^ " but is here used with type " ^
+ CicMetaSubst.ppterm_in_context subst s context
+ (* "\nReason: " ^ Lazy.force e*)))) exn
+ in
+ let coerced_args,metasenv',subst',t',ugraph2 =
+ eat_prods metasenv subst context
+ (CicSubstitution.subst arg t) ugraph1 tl
+ in
+ arg::coerced_args,metasenv',subst',t',ugraph2
+ | _ -> assert false
+ )
+ in
+ let coerced_args,metasenv,subst,t,ugraph2 =
+ eat_prods metasenv subst context hetype' ugraph1 tlbody_and_type
+ in
+ coerced_args,t,subst,metasenv,ugraph2
+ in
+
+ (* eat prods ends here! *)
+
+ let t',ty,subst',metasenv',ugraph1 =
+ type_of_aux [] metasenv context t ugraph
+ in
+ let substituted_t = CicMetaSubst.apply_subst subst' t' in
+ let substituted_ty = CicMetaSubst.apply_subst subst' ty in
+ (* Andrea: ho rimesso qui l'applicazione della subst al
+ metasenv dopo che ho droppato l'invariante che il metsaenv
+ e' sempre istanziato *)
+ let substituted_metasenv =
+ CicMetaSubst.apply_subst_metasenv subst' metasenv' in
+ (* metasenv' *)
+ (* substituted_t,substituted_ty,substituted_metasenv *)
+ (* ANDREA: spostare tutta questa robaccia da un altra parte *)
+ let cleaned_t =
+ FreshNamesGenerator.clean_dummy_dependent_types substituted_t in
+ let cleaned_ty =
+ FreshNamesGenerator.clean_dummy_dependent_types substituted_ty in
+ let cleaned_metasenv =
+ List.map
+ (function (n,context,ty) ->
+ let ty' = FreshNamesGenerator.clean_dummy_dependent_types ty in
+ let context' =
+ List.map
+ (function
+ None -> None
+ | Some (n, Cic.Decl t) ->
+ Some (n,
+ Cic.Decl (FreshNamesGenerator.clean_dummy_dependent_types t))
+ | Some (n, Cic.Def (bo,ty)) ->
+ let bo' = FreshNamesGenerator.clean_dummy_dependent_types bo in
+ let ty' =
+ match ty with
+ None -> None
+ | Some ty ->
+ Some (FreshNamesGenerator.clean_dummy_dependent_types ty)
+ in
+ Some (n, Cic.Def (bo',ty'))
+ ) context
+ in
+ (n,context',ty')
+ ) substituted_metasenv
+ in
+ (cleaned_t,cleaned_ty,cleaned_metasenv,ugraph1)
+;;
+
+let type_of_aux' ?localization_tbl metasenv context term ugraph =
+ try
+ type_of_aux' ?localization_tbl metasenv context term ugraph
+ with
+ CicUniv.UniverseInconsistency msg -> raise (RefineFailure (lazy msg))
+
+let undebrujin uri typesno tys t =
+ snd
+ (List.fold_right
+ (fun (name,_,_,_) (i,t) ->
+ (* here the explicit_named_substituion is assumed to be *)
+ (* of length 0 *)
+ let t' = Cic.MutInd (uri,i,[]) in
+ let t = CicSubstitution.subst t' t in
+ i - 1,t
+ ) tys (typesno - 1,t))
+
+let map_first_n n start f g l =
+ let rec aux acc k l =
+ if k < n then
+ match l with
+ | [] -> raise (Invalid_argument "map_first_n")
+ | hd :: tl -> f hd k (aux acc (k+1) tl)
+ else
+ g acc l
+ in
+ aux start 0 l
+
+(*CSC: this is a very rough approximation; to be finished *)
+let are_all_occurrences_positive metasenv ugraph uri tys leftno =
+ let subst,metasenv,ugraph,tys =
+ List.fold_right
+ (fun (name,ind,arity,cl) (subst,metasenv,ugraph,acc) ->
+ let subst,metasenv,ugraph,cl =
+ List.fold_right
+ (fun (name,ty) (subst,metasenv,ugraph,acc) ->
+ let rec aux ctx k subst = function
+ | Cic.Appl((Cic.MutInd (uri',_,_)as hd)::tl) when uri = uri'->
+ let subst,metasenv,ugraph,tl =
+ map_first_n leftno
+ (subst,metasenv,ugraph,[])
+ (fun t n (subst,metasenv,ugraph,acc) ->
+ let subst,metasenv,ugraph =
+ fo_unif_subst
+ subst ctx metasenv t (Cic.Rel (k-n)) ugraph
+ in
+ subst,metasenv,ugraph,(t::acc))
+ (fun (s,m,g,acc) tl -> assert(acc=[]);(s,m,g,tl))
+ tl
+ in
+ subst,metasenv,ugraph,(Cic.Appl (hd::tl))
+ | Cic.MutInd(uri',_,_) as t when uri = uri'->
+ subst,metasenv,ugraph,t
+ | Cic.Prod (name,s,t) ->
+ let ctx = (Some (name,Cic.Decl s))::ctx in
+ let subst,metasenv,ugraph,t = aux ctx (k+1) subst t in
+ subst,metasenv,ugraph,Cic.Prod (name,s,t)
+ | _ ->
+ raise
+ (RefineFailure
+ (lazy "not well formed constructor type"))
+ in
+ let subst,metasenv,ugraph,ty = aux [] 0 subst ty in
+ subst,metasenv,ugraph,(name,ty) :: acc)
+ cl (subst,metasenv,ugraph,[])
+ in
+ subst,metasenv,ugraph,(name,ind,arity,cl)::acc)
+ tys ([],metasenv,ugraph,[])
+ in
+ let substituted_tys =
+ List.map
+ (fun (name,ind,arity,cl) ->
+ let cl =
+ List.map (fun (name, ty) -> name,CicMetaSubst.apply_subst subst ty) cl
+ in
+ name,ind,CicMetaSubst.apply_subst subst arity,cl)
+ tys
+ in
+ metasenv,ugraph,substituted_tys
+
+let typecheck metasenv uri obj ~localization_tbl =
+ let ugraph = CicUniv.empty_ugraph in
+ match obj with
+ Cic.Constant (name,Some bo,ty,args,attrs) ->
+ let bo',boty,metasenv,ugraph =
+ type_of_aux' ~localization_tbl metasenv [] bo ugraph in
+ let ty',_,metasenv,ugraph =
+ type_of_aux' ~localization_tbl metasenv [] ty ugraph in
+ let subst,metasenv,ugraph = fo_unif_subst [] [] metasenv boty ty' ugraph in
+ let bo' = CicMetaSubst.apply_subst subst bo' in
+ let ty' = CicMetaSubst.apply_subst subst ty' in
+ let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
+ Cic.Constant (name,Some bo',ty',args,attrs),metasenv,ugraph
+ | Cic.Constant (name,None,ty,args,attrs) ->
+ let ty',_,metasenv,ugraph =
+ type_of_aux' ~localization_tbl metasenv [] ty ugraph
+ in
+ Cic.Constant (name,None,ty',args,attrs),metasenv,ugraph
+ | Cic.CurrentProof (name,metasenv',bo,ty,args,attrs) ->
+ assert (metasenv' = metasenv);
+ (* Here we do not check the metasenv for correctness *)
+ let bo',boty,metasenv,ugraph =
+ type_of_aux' ~localization_tbl metasenv [] bo ugraph in
+ let ty',sort,metasenv,ugraph =
+ type_of_aux' ~localization_tbl metasenv [] ty ugraph in
+ begin
+ match sort with
+ Cic.Sort _
+ (* instead of raising Uncertain, let's hope that the meta will become
+ a sort *)
+ | Cic.Meta _ -> ()
+ | _ -> raise (RefineFailure (lazy "The term provided is not a type"))
+ end;
+ let subst,metasenv,ugraph = fo_unif_subst [] [] metasenv boty ty' ugraph in
+ let bo' = CicMetaSubst.apply_subst subst bo' in
+ let ty' = CicMetaSubst.apply_subst subst ty' in
+ let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
+ Cic.CurrentProof (name,metasenv,bo',ty',args,attrs),metasenv,ugraph
+ | Cic.Variable _ -> assert false (* not implemented *)
+ | Cic.InductiveDefinition (tys,args,paramsno,attrs) ->
+ (*CSC: this code is greately simplified and many many checks are missing *)
+ (*CSC: e.g. the constructors are not required to build their own types, *)
+ (*CSC: the arities are not required to have as type a sort, etc. *)
+ let uri = match uri with Some uri -> uri | None -> assert false in
+ let typesno = List.length tys in
+ (* first phase: we fix only the types *)
+ let metasenv,ugraph,tys =
+ List.fold_right
+ (fun (name,b,ty,cl) (metasenv,ugraph,res) ->
+ let ty',_,metasenv,ugraph =
+ type_of_aux' ~localization_tbl metasenv [] ty ugraph
+ in
+ metasenv,ugraph,(name,b,ty',cl)::res
+ ) tys (metasenv,ugraph,[]) in
+ let con_context =
+ List.rev_map (fun (name,_,ty,_)-> Some (Cic.Name name,Cic.Decl ty)) tys in
+ (* second phase: we fix only the constructors *)
+ let metasenv,ugraph,tys =
+ List.fold_right
+ (fun (name,b,ty,cl) (metasenv,ugraph,res) ->
+ let metasenv,ugraph,cl' =
+ List.fold_right
+ (fun (name,ty) (metasenv,ugraph,res) ->
+ let ty =
+ CicTypeChecker.debrujin_constructor
+ ~cb:(relocalize localization_tbl) uri typesno ty in
+ let ty',_,metasenv,ugraph =
+ type_of_aux' ~localization_tbl metasenv con_context ty ugraph in
+ let ty' = undebrujin uri typesno tys ty' in
+ metasenv,ugraph,(name,ty')::res
+ ) cl (metasenv,ugraph,[])
+ in
+ metasenv,ugraph,(name,b,ty,cl')::res
+ ) tys (metasenv,ugraph,[]) in
+ (* third phase: we check the positivity condition *)
+ let metasenv,ugraph,tys =
+ are_all_occurrences_positive metasenv ugraph uri tys paramsno
+ in
+ Cic.InductiveDefinition (tys,args,paramsno,attrs),metasenv,ugraph
+
+(* DEBUGGING ONLY
+let type_of_aux' metasenv context term =
+ try
+ let (t,ty,m) =
+ type_of_aux' metasenv context term in
+ debug_print (lazy
+ ("@@@ REFINE SUCCESSFUL: " ^ CicPp.ppterm t ^ " : " ^ CicPp.ppterm ty));
+ debug_print (lazy
+ ("@@@ REFINE SUCCESSFUL (metasenv):\n" ^ CicMetaSubst.ppmetasenv ~sep:";" m []));
+ (t,ty,m)
+ with
+ | RefineFailure msg as e ->
+ debug_print (lazy ("@@@ REFINE FAILED: " ^ msg));
+ raise e
+ | Uncertain msg as e ->
+ debug_print (lazy ("@@@ REFINE UNCERTAIN: " ^ msg));
+ raise e
+;; *)
+
+let profiler2 = HExtlib.profile "CicRefine"
+
+let type_of_aux' ?localization_tbl metasenv context term ugraph =
+ profiler2.HExtlib.profile
+ (type_of_aux' ?localization_tbl metasenv context term) ugraph
+
+let typecheck ~localization_tbl metasenv uri obj =
+ profiler2.HExtlib.profile (typecheck ~localization_tbl metasenv uri) obj
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception 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 *)
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+exception UnificationFailure of string Lazy.t;;
+exception Uncertain of string Lazy.t;;
+exception AssertFailure of string Lazy.t;;
+
+let verbose = false;;
+let debug_print = fun _ -> ()
+
+let profiler_toa = HExtlib.profile "fo_unif_subst.type_of_aux'"
+let profiler_beta_expand = HExtlib.profile "fo_unif_subst.beta_expand"
+let profiler_deref = HExtlib.profile "fo_unif_subst.deref'"
+let profiler_are_convertible = HExtlib.profile "fo_unif_subst.are_convertible"
+
+let type_of_aux' metasenv subst context term ugraph =
+let foo () =
+ try
+ CicTypeChecker.type_of_aux' ~subst metasenv context term ugraph
+ with
+ CicTypeChecker.TypeCheckerFailure msg ->
+ let msg =
+ lazy
+ (sprintf
+ "Kernel Type checking error:
+%s\n%s\ncontext=\n%s\nmetasenv=\n%s\nsubstitution=\n%s\nException:\n%s.\nToo bad."
+ (CicMetaSubst.ppterm subst term)
+ (CicMetaSubst.ppterm [] term)
+ (CicMetaSubst.ppcontext subst context)
+ (CicMetaSubst.ppmetasenv subst metasenv)
+ (CicMetaSubst.ppsubst subst) (Lazy.force msg)) in
+ raise (AssertFailure msg)
+ | CicTypeChecker.AssertFailure msg ->
+ let msg = lazy
+ (sprintf
+ "Kernel Type checking assertion failure:
+%s\n%s\ncontext=\n%s\nmetasenv=\n%s\nsubstitution=\n%s\nException:\n%s.\nToo bad."
+ (CicMetaSubst.ppterm subst term)
+ (CicMetaSubst.ppterm [] term)
+ (CicMetaSubst.ppcontext subst context)
+ (CicMetaSubst.ppmetasenv subst metasenv)
+ (CicMetaSubst.ppsubst subst) (Lazy.force msg)) in
+ raise (AssertFailure msg)
+in profiler_toa.HExtlib.profile foo ()
+;;
+
+let exists_a_meta l =
+ List.exists (function Cic.Meta _ -> true | _ -> false) l
+
+let rec deref subst t =
+ let snd (_,a,_) = a in
+ match t with
+ Cic.Meta(n,l) ->
+ (try
+ deref subst
+ (CicSubstitution.subst_meta
+ l (snd (CicUtil.lookup_subst n subst)))
+ with
+ CicUtil.Subst_not_found _ -> t)
+ | Cic.Appl(Cic.Meta(n,l)::args) ->
+ (match deref subst (Cic.Meta(n,l)) with
+ | Cic.Lambda _ as t ->
+ deref subst (CicReduction.head_beta_reduce (Cic.Appl(t::args)))
+ | r -> Cic.Appl(r::args))
+ | Cic.Appl(((Cic.Lambda _) as t)::args) ->
+ deref subst (CicReduction.head_beta_reduce (Cic.Appl(t::args)))
+ | t -> t
+;;
+
+let deref subst t =
+ let foo () = deref subst t
+ in profiler_deref.HExtlib.profile foo ()
+
+exception WrongShape;;
+let eta_reduce after_beta_expansion after_beta_expansion_body
+ before_beta_expansion
+ =
+ try
+ match before_beta_expansion,after_beta_expansion_body with
+ Cic.Appl l, Cic.Appl l' ->
+ let rec all_but_last check_last =
+ function
+ [] -> assert false
+ | [Cic.Rel 1] -> []
+ | [_] -> if check_last then raise WrongShape else []
+ | he::tl -> he::(all_but_last check_last tl)
+ in
+ let all_but_last check_last l =
+ match all_but_last check_last l with
+ [] -> assert false
+ | [he] -> he
+ | l -> Cic.Appl l
+ in
+ let t = CicSubstitution.subst (Cic.Rel (-1)) (all_but_last true l') in
+ let all_but_last = all_but_last false l in
+ (* here we should test alpha-equivalence; however we know by
+ construction that here alpha_equivalence is equivalent to = *)
+ if t = all_but_last then
+ all_but_last
+ else
+ after_beta_expansion
+ | _,_ -> after_beta_expansion
+ with
+ WrongShape -> after_beta_expansion
+
+let rec beta_expand test_equality_only metasenv subst context t arg ugraph =
+ let module S = CicSubstitution in
+ let module C = Cic in
+let foo () =
+ let rec aux metasenv subst n context t' ugraph =
+ try
+
+ let subst,metasenv,ugraph1 =
+ fo_unif_subst test_equality_only subst context metasenv
+ (CicSubstitution.lift n arg) t' ugraph
+
+ in
+ subst,metasenv,C.Rel (1 + n),ugraph1
+ with
+ Uncertain _
+ | UnificationFailure _ ->
+ match t' with
+ | C.Rel m -> subst,metasenv,
+ (if m <= n then C.Rel m else C.Rel (m+1)),ugraph
+ | C.Var (uri,exp_named_subst) ->
+ let subst,metasenv,exp_named_subst',ugraph1 =
+ aux_exp_named_subst metasenv subst n context exp_named_subst ugraph
+ in
+ subst,metasenv,C.Var (uri,exp_named_subst'),ugraph1
+ | C.Meta (i,l) ->
+ (* andrea: in general, beta_expand can create badly typed
+ terms. This happens quite seldom in practice, UNLESS we
+ iterate on the local context. For this reason, we renounce
+ to iterate and just lift *)
+ let l =
+ List.map
+ (function
+ Some t -> Some (CicSubstitution.lift 1 t)
+ | None -> None) l in
+ subst, metasenv, C.Meta (i,l), ugraph
+ | C.Sort _
+ | C.Implicit _ as t -> subst,metasenv,t,ugraph
+ | C.Cast (te,ty) ->
+ let subst,metasenv,te',ugraph1 =
+ aux metasenv subst n context te ugraph in
+ let subst,metasenv,ty',ugraph2 =
+ aux metasenv subst n context ty ugraph1 in
+ (* TASSI: sure this is in serial? *)
+ subst,metasenv,(C.Cast (te', ty')),ugraph2
+ | C.Prod (nn,s,t) ->
+ let subst,metasenv,s',ugraph1 =
+ aux metasenv subst n context s ugraph in
+ let subst,metasenv,t',ugraph2 =
+ aux metasenv subst (n+1) ((Some (nn, C.Decl s))::context) t
+ ugraph1
+ in
+ (* TASSI: sure this is in serial? *)
+ subst,metasenv,(C.Prod (nn, s', t')),ugraph2
+ | C.Lambda (nn,s,t) ->
+ let subst,metasenv,s',ugraph1 =
+ aux metasenv subst n context s ugraph in
+ let subst,metasenv,t',ugraph2 =
+ aux metasenv subst (n+1) ((Some (nn, C.Decl s))::context) t ugraph1
+ in
+ (* TASSI: sure this is in serial? *)
+ subst,metasenv,(C.Lambda (nn, s', t')),ugraph2
+ | C.LetIn (nn,s,t) ->
+ let subst,metasenv,s',ugraph1 =
+ aux metasenv subst n context s ugraph in
+ let subst,metasenv,t',ugraph2 =
+ aux metasenv subst (n+1) ((Some (nn, C.Def (s,None)))::context) t
+ ugraph1
+ in
+ (* TASSI: sure this is in serial? *)
+ subst,metasenv,(C.LetIn (nn, s', t')),ugraph2
+ | C.Appl l ->
+ let subst,metasenv,revl',ugraph1 =
+ List.fold_left
+ (fun (subst,metasenv,appl,ugraph) t ->
+ let subst,metasenv,t',ugraph1 =
+ aux metasenv subst n context t ugraph in
+ subst,metasenv,(t'::appl),ugraph1
+ ) (subst,metasenv,[],ugraph) l
+ in
+ subst,metasenv,(C.Appl (List.rev revl')),ugraph1
+ | C.Const (uri,exp_named_subst) ->
+ let subst,metasenv,exp_named_subst',ugraph1 =
+ aux_exp_named_subst metasenv subst n context exp_named_subst ugraph
+ in
+ subst,metasenv,(C.Const (uri,exp_named_subst')),ugraph1
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let subst,metasenv,exp_named_subst',ugraph1 =
+ aux_exp_named_subst metasenv subst n context exp_named_subst ugraph
+ in
+ subst,metasenv,(C.MutInd (uri,i,exp_named_subst')),ugraph1
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let subst,metasenv,exp_named_subst',ugraph1 =
+ aux_exp_named_subst metasenv subst n context exp_named_subst ugraph
+ in
+ subst,metasenv,(C.MutConstruct (uri,i,j,exp_named_subst')),ugraph1
+ | C.MutCase (sp,i,outt,t,pl) ->
+ let subst,metasenv,outt',ugraph1 =
+ aux metasenv subst n context outt ugraph in
+ let subst,metasenv,t',ugraph2 =
+ aux metasenv subst n context t ugraph1 in
+ let subst,metasenv,revpl',ugraph3 =
+ List.fold_left
+ (fun (subst,metasenv,pl,ugraph) t ->
+ let subst,metasenv,t',ugraph1 =
+ aux metasenv subst n context t ugraph in
+ subst,metasenv,(t'::pl),ugraph1
+ ) (subst,metasenv,[],ugraph2) pl
+ in
+ subst,metasenv,(C.MutCase (sp,i,outt', t', List.rev revpl')),ugraph3
+ (* TASSI: not sure this is serial *)
+ | C.Fix (i,fl) ->
+(*CSC: not implemented
+ let tylen = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) -> (name, i, aux n ty, aux (n+tylen) bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+*)
+ subst,metasenv,(CicSubstitution.lift 1 t' ),ugraph
+ | C.CoFix (i,fl) ->
+(*CSC: not implemented
+ let tylen = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) -> (name, aux n ty, aux (n+tylen) bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+
+*)
+ subst,metasenv,(CicSubstitution.lift 1 t'), ugraph
+
+ and aux_exp_named_subst metasenv subst n context ens ugraph =
+ List.fold_right
+ (fun (uri,t) (subst,metasenv,l,ugraph) ->
+ let subst,metasenv,t',ugraph1 = aux metasenv subst n context t ugraph in
+ subst,metasenv,((uri,t')::l),ugraph1) ens (subst,metasenv,[],ugraph)
+ in
+ let argty,ugraph1 = type_of_aux' metasenv subst context arg ugraph in
+ let fresh_name =
+ FreshNamesGenerator.mk_fresh_name ~subst
+ metasenv context (Cic.Name "Hbeta") ~typ:argty
+ in
+ let subst,metasenv,t',ugraph2 = aux metasenv subst 0 context t ugraph1 in
+ let t'' = eta_reduce (C.Lambda (fresh_name,argty,t')) t' t in
+ subst, metasenv, t'', ugraph2
+in profiler_beta_expand.HExtlib.profile foo ()
+
+
+and beta_expand_many test_equality_only metasenv subst context t args ugraph =
+ let subst,metasenv,hd,ugraph =
+ List.fold_right
+ (fun arg (subst,metasenv,t,ugraph) ->
+ let subst,metasenv,t,ugraph1 =
+ beta_expand test_equality_only
+ metasenv subst context t arg ugraph
+ in
+ subst,metasenv,t,ugraph1
+ ) args (subst,metasenv,t,ugraph)
+ in
+ subst,metasenv,hd,ugraph
+
+
+(* NUOVA UNIFICAZIONE *)
+(* A substitution is a (int * Cic.term) list that associates a
+ metavariable i with its body.
+ A metaenv is a (int * Cic.term) list that associate a metavariable
+ i with is type.
+ fo_unif_new takes a metasenv, a context, two terms t1 and t2 and gives back
+ a new substitution which is _NOT_ unwinded. It must be unwinded before
+ applying it. *)
+
+and fo_unif_subst test_equality_only subst context metasenv t1 t2 ugraph =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module S = CicSubstitution in
+ let t1 = deref subst t1 in
+ let t2 = deref subst t2 in
+ let b,ugraph =
+let foo () =
+ R.are_convertible ~subst ~metasenv context t1 t2 ugraph
+in profiler_are_convertible.HExtlib.profile foo ()
+ in
+ if b then
+ subst, metasenv, ugraph
+ else
+ match (t1, t2) with
+ | (C.Meta (n,ln), C.Meta (m,lm)) when n=m ->
+ let _,subst,metasenv,ugraph1 =
+ (try
+ List.fold_left2
+ (fun (j,subst,metasenv,ugraph) t1 t2 ->
+ match t1,t2 with
+ None,_
+ | _,None -> j+1,subst,metasenv,ugraph
+ | Some t1', Some t2' ->
+ (* First possibility: restriction *)
+ (* Second possibility: unification *)
+ (* Third possibility: convertibility *)
+ let b, ugraph1 =
+ R.are_convertible
+ ~subst ~metasenv context t1' t2' ugraph
+ in
+ if b then
+ j+1,subst,metasenv, ugraph1
+ else
+ (try
+ let subst,metasenv,ugraph2 =
+ fo_unif_subst
+ test_equality_only
+ subst context metasenv t1' t2' ugraph
+ in
+ j+1,subst,metasenv,ugraph2
+ with
+ Uncertain _
+ | UnificationFailure _ ->
+debug_print (lazy ("restringo Meta n." ^ (string_of_int n) ^ "on variable n." ^ (string_of_int j)));
+ let metasenv, subst =
+ CicMetaSubst.restrict
+ subst [(n,j)] metasenv in
+ j+1,subst,metasenv,ugraph1)
+ ) (1,subst,metasenv,ugraph) ln lm
+ with
+ Exit ->
+ raise
+ (UnificationFailure (lazy "1"))
+ (*
+ (sprintf
+ "Error trying to unify %s with %s: the algorithm tried to check whether the two substitutions are convertible; if they are not, it tried to unify the two substitutions. No restriction was attempted."
+ (CicMetaSubst.ppterm subst t1)
+ (CicMetaSubst.ppterm subst t2))) *)
+ | Invalid_argument _ ->
+ raise
+ (UnificationFailure (lazy "2")))
+ (*
+ (sprintf
+ "Error trying to unify %s with %s: the lengths of the two local contexts do not match."
+ (CicMetaSubst.ppterm subst t1)
+ (CicMetaSubst.ppterm subst t2)))) *)
+ in subst,metasenv,ugraph1
+ | (C.Meta (n,_), C.Meta (m,_)) when n>m ->
+ fo_unif_subst test_equality_only subst context metasenv t2 t1 ugraph
+ | (C.Meta (n,l), t)
+ | (t, C.Meta (n,l)) ->
+ let swap =
+ match t1,t2 with
+ C.Meta (n,_), C.Meta (m,_) when n < m -> false
+ | _, C.Meta _ -> false
+ | _,_ -> true
+ in
+ let lower = fun x y -> if swap then y else x in
+ let upper = fun x y -> if swap then x else y in
+ let fo_unif_subst_ordered
+ test_equality_only subst context metasenv m1 m2 ugraph =
+ fo_unif_subst test_equality_only subst context metasenv
+ (lower m1 m2) (upper m1 m2) ugraph
+ in
+ begin
+ let subst,metasenv,ugraph1 =
+ let (_,_,meta_type) = CicUtil.lookup_meta n metasenv in
+ (try
+ let tyt,ugraph1 =
+ type_of_aux' metasenv subst context t ugraph
+ in
+ fo_unif_subst
+ test_equality_only
+ subst context metasenv tyt (S.subst_meta l meta_type) ugraph1
+ with
+ UnificationFailure _ as e -> raise e
+ | Uncertain msg -> raise (UnificationFailure msg)
+ | AssertFailure _ ->
+ debug_print (lazy "siamo allo huge hack");
+ (* TODO huge hack!!!!
+ * we keep on unifying/refining in the hope that
+ * the problem will be eventually solved.
+ * In the meantime we're breaking a big invariant:
+ * the terms that we are unifying are no longer well
+ * typed in the current context (in the worst case
+ * we could even diverge) *)
+ (subst, metasenv,ugraph)) in
+ let t',metasenv,subst =
+ try
+ CicMetaSubst.delift n subst context metasenv l t
+ with
+ (CicMetaSubst.MetaSubstFailure msg)->
+ raise (UnificationFailure msg)
+ | (CicMetaSubst.Uncertain msg) -> raise (Uncertain msg)
+ in
+ let t'',ugraph2 =
+ match t' with
+ C.Sort (C.Type u) when not test_equality_only ->
+ let u' = CicUniv.fresh () in
+ let s = C.Sort (C.Type u') in
+ let ugraph2 =
+ CicUniv.add_ge (upper u u') (lower u u') ugraph1
+ in
+ s,ugraph2
+ | _ -> t',ugraph1
+ in
+ (* Unifying the types may have already instantiated n. Let's check *)
+ try
+ let (_, oldt,_) = CicUtil.lookup_subst n subst in
+ let lifted_oldt = S.subst_meta l oldt in
+ fo_unif_subst_ordered
+ test_equality_only subst context metasenv t lifted_oldt ugraph2
+ with
+ CicUtil.Subst_not_found _ ->
+ let (_, context, ty) = CicUtil.lookup_meta n metasenv in
+ let subst = (n, (context, t'',ty)) :: subst in
+ let metasenv =
+ List.filter (fun (m,_,_) -> not (n = m)) metasenv in
+ subst, metasenv, ugraph2
+ end
+ | (C.Var (uri1,exp_named_subst1),C.Var (uri2,exp_named_subst2))
+ | (C.Const (uri1,exp_named_subst1),C.Const (uri2,exp_named_subst2)) ->
+ if UriManager.eq uri1 uri2 then
+ fo_unif_subst_exp_named_subst test_equality_only subst context metasenv
+ exp_named_subst1 exp_named_subst2 ugraph
+ else
+ raise (UnificationFailure (lazy
+ (sprintf
+ "Can't unify %s with %s due to different constants"
+ (CicMetaSubst.ppterm subst t1)
+ (CicMetaSubst.ppterm subst t2))))
+ | C.MutInd (uri1,i1,exp_named_subst1),C.MutInd (uri2,i2,exp_named_subst2) ->
+ if UriManager.eq uri1 uri2 && i1 = i2 then
+ fo_unif_subst_exp_named_subst
+ test_equality_only
+ subst context metasenv exp_named_subst1 exp_named_subst2 ugraph
+ else
+ raise (UnificationFailure (lazy "4"))
+ (* (sprintf
+ "Can't unify %s with %s due to different inductive principles"
+ (CicMetaSubst.ppterm subst t1)
+ (CicMetaSubst.ppterm subst t2))) *)
+ | C.MutConstruct (uri1,i1,j1,exp_named_subst1),
+ C.MutConstruct (uri2,i2,j2,exp_named_subst2) ->
+ if UriManager.eq uri1 uri2 && i1 = i2 && j1 = j2 then
+ fo_unif_subst_exp_named_subst
+ test_equality_only
+ subst context metasenv exp_named_subst1 exp_named_subst2 ugraph
+ else
+ raise (UnificationFailure (lazy "5"))
+ (* (sprintf
+ "Can't unify %s with %s due to different inductive constructors"
+ (CicMetaSubst.ppterm subst t1)
+ (CicMetaSubst.ppterm subst t2))) *)
+ | (C.Implicit _, _) | (_, C.Implicit _) -> assert false
+ | (C.Cast (te,ty), t2) -> fo_unif_subst test_equality_only
+ subst context metasenv te t2 ugraph
+ | (t1, C.Cast (te,ty)) -> fo_unif_subst test_equality_only
+ subst context metasenv t1 te ugraph
+ | (C.Prod (n1,s1,t1), C.Prod (_,s2,t2)) ->
+ let subst',metasenv',ugraph1 =
+ fo_unif_subst true subst context metasenv s1 s2 ugraph
+ in
+ fo_unif_subst test_equality_only
+ subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2 ugraph1
+ | (C.Lambda (n1,s1,t1), C.Lambda (_,s2,t2)) ->
+ let subst',metasenv',ugraph1 =
+ fo_unif_subst test_equality_only subst context metasenv s1 s2 ugraph
+ in
+ fo_unif_subst test_equality_only
+ subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2 ugraph1
+ | (C.LetIn (_,s1,t1), t2)
+ | (t2, C.LetIn (_,s1,t1)) ->
+ fo_unif_subst
+ test_equality_only subst context metasenv t2 (S.subst s1 t1) ugraph
+ | (C.Appl l1, C.Appl l2) ->
+ (* andrea: this case should be probably rewritten in the
+ spirit of deref *)
+ (match l1,l2 with
+ | C.Meta (i,_)::args1, C.Meta (j,_)::args2 when i = j ->
+ (try
+ List.fold_left2
+ (fun (subst,metasenv,ugraph) t1 t2 ->
+ fo_unif_subst
+ test_equality_only subst context metasenv t1 t2 ugraph)
+ (subst,metasenv,ugraph) l1 l2
+ with (Invalid_argument msg) ->
+ raise (UnificationFailure (lazy msg)))
+ | C.Meta (i,l)::args, _ when not(exists_a_meta args) ->
+ (* we verify that none of the args is a Meta,
+ since beta expanding with respoect to a metavariable
+ makes no sense *)
+ (*
+ (try
+ let (_,t,_) = CicUtil.lookup_subst i subst in
+ let lifted = S.subst_meta l t in
+ let reduced = CicReduction.head_beta_reduce (Cic.Appl (lifted::args)) in
+ fo_unif_subst
+ test_equality_only
+ subst context metasenv reduced t2 ugraph
+ with CicUtil.Subst_not_found _ -> *)
+ let subst,metasenv,beta_expanded,ugraph1 =
+ beta_expand_many
+ test_equality_only metasenv subst context t2 args ugraph
+ in
+ fo_unif_subst test_equality_only subst context metasenv
+ (C.Meta (i,l)) beta_expanded ugraph1
+ | _, C.Meta (i,l)::args when not(exists_a_meta args) ->
+ (* (try
+ let (_,t,_) = CicUtil.lookup_subst i subst in
+ let lifted = S.subst_meta l t in
+ let reduced = CicReduction.head_beta_reduce (Cic.Appl (lifted::args)) in
+ fo_unif_subst
+ test_equality_only
+ subst context metasenv t1 reduced ugraph
+ with CicUtil.Subst_not_found _ -> *)
+ let subst,metasenv,beta_expanded,ugraph1 =
+ beta_expand_many
+ test_equality_only
+ metasenv subst context t1 args ugraph
+ in
+ fo_unif_subst test_equality_only subst context metasenv
+ (C.Meta (i,l)) beta_expanded ugraph1
+ | _,_ ->
+ let lr1 = List.rev l1 in
+ let lr2 = List.rev l2 in
+ let rec
+ fo_unif_l test_equality_only subst metasenv (l1,l2) ugraph =
+ match (l1,l2) with
+ [],_
+ | _,[] -> assert false
+ | ([h1],[h2]) ->
+ fo_unif_subst
+ test_equality_only subst context metasenv h1 h2 ugraph
+ | ([h],l)
+ | (l,[h]) ->
+ fo_unif_subst test_equality_only subst context metasenv
+ h (C.Appl (List.rev l)) ugraph
+ | ((h1::l1),(h2::l2)) ->
+ let subst', metasenv',ugraph1 =
+ fo_unif_subst
+ test_equality_only
+ subst context metasenv h1 h2 ugraph
+ in
+ fo_unif_l
+ test_equality_only subst' metasenv' (l1,l2) ugraph1
+ in
+ (try
+ fo_unif_l
+ test_equality_only subst metasenv (lr1, lr2) ugraph
+ with
+ | UnificationFailure _
+ | Uncertain _ as exn ->
+ (match l1, l2 with
+ | (((Cic.Const (uri1, ens1)) as c1) :: tl1),
+ (((Cic.Const (uri2, ens2)) as c2) :: tl2) when
+ CoercGraph.is_a_coercion c1 &&
+ CoercGraph.is_a_coercion c2 ->
+ let body1, attrs1, ugraph =
+ match CicEnvironment.get_obj ugraph uri1 with
+ | Cic.Constant (_,Some bo, _, _, attrs),u -> bo,attrs,u
+ | _ -> assert false
+ in
+ let body2, attrs2, ugraph =
+ match CicEnvironment.get_obj ugraph uri2 with
+ | Cic.Constant (_,Some bo, _, _, attrs),u -> bo, attrs,u
+ | _ -> assert false
+ in
+ let is_composite1 =
+ List.exists ((=) (`Class `Coercion)) attrs1 in
+ let is_composite2 =
+ List.exists ((=) (`Class `Coercion)) attrs2 in
+ (match is_composite1, is_composite2 with
+ | false, false -> raise exn
+ | true, false ->
+ let body1 = CicSubstitution.subst_vars ens1 body1 in
+ let appl = Cic.Appl (body1::tl1) in
+ let redappl = CicReduction.head_beta_reduce appl in
+ fo_unif_subst
+ test_equality_only subst context metasenv
+ redappl t2 ugraph
+ | false, true ->
+ let body2 = CicSubstitution.subst_vars ens2 body2 in
+ let appl = Cic.Appl (body2::tl2) in
+ let redappl = CicReduction.head_beta_reduce appl in
+ fo_unif_subst
+ test_equality_only subst context metasenv
+ t1 redappl ugraph
+ | true, true ->
+ let body1 = CicSubstitution.subst_vars ens1 body1 in
+ let appl1 = Cic.Appl (body1::tl1) in
+ let redappl1 = CicReduction.head_beta_reduce appl1 in
+ let body2 = CicSubstitution.subst_vars ens2 body2 in
+ let appl2 = Cic.Appl (body2::tl2) in
+ let redappl2 = CicReduction.head_beta_reduce appl2 in
+ fo_unif_subst
+ test_equality_only subst context metasenv
+ redappl1 redappl2 ugraph)
+ | _ -> raise exn)))
+ | (C.MutCase (_,_,outt1,t1',pl1), C.MutCase (_,_,outt2,t2',pl2))->
+ let subst', metasenv',ugraph1 =
+ fo_unif_subst test_equality_only subst context metasenv outt1 outt2
+ ugraph in
+ let subst'',metasenv'',ugraph2 =
+ fo_unif_subst test_equality_only subst' context metasenv' t1' t2'
+ ugraph1 in
+ (try
+ List.fold_left2
+ (fun (subst,metasenv,ugraph) t1 t2 ->
+ fo_unif_subst
+ test_equality_only subst context metasenv t1 t2 ugraph
+ ) (subst'',metasenv'',ugraph2) pl1 pl2
+ with
+ Invalid_argument _ ->
+ raise (UnificationFailure (lazy "6.1")))
+ (* (sprintf
+ "Error trying to unify %s with %s: the number of branches is not the same."
+ (CicMetaSubst.ppterm subst t1)
+ (CicMetaSubst.ppterm subst t2)))) *)
+ | (C.Rel _, _) | (_, C.Rel _) ->
+ if t1 = t2 then
+ subst, metasenv,ugraph
+ else
+ raise (UnificationFailure (lazy
+ (sprintf
+ "Can't unify %s with %s because they are not convertible"
+ (CicMetaSubst.ppterm subst t1)
+ (CicMetaSubst.ppterm subst t2))))
+ | (C.Appl (C.Meta(i,l)::args),t2) when not(exists_a_meta args) ->
+ let subst,metasenv,beta_expanded,ugraph1 =
+ beta_expand_many
+ test_equality_only metasenv subst context t2 args ugraph
+ in
+ fo_unif_subst test_equality_only subst context metasenv
+ (C.Meta (i,l)) beta_expanded ugraph1
+ | (t1,C.Appl (C.Meta(i,l)::args)) when not(exists_a_meta args) ->
+ let subst,metasenv,beta_expanded,ugraph1 =
+ beta_expand_many
+ test_equality_only metasenv subst context t1 args ugraph
+ in
+ fo_unif_subst test_equality_only subst context metasenv
+ beta_expanded (C.Meta (i,l)) ugraph1
+ | (C.Sort _ ,_) | (_, C.Sort _)
+ | (C.Const _, _) | (_, C.Const _)
+ | (C.MutInd _, _) | (_, C.MutInd _)
+ | (C.MutConstruct _, _) | (_, C.MutConstruct _)
+ | (C.Fix _, _) | (_, C.Fix _)
+ | (C.CoFix _, _) | (_, C.CoFix _) ->
+ if t1 = t2 then
+ subst, metasenv, ugraph
+ else
+ let b,ugraph1 =
+ R.are_convertible ~subst ~metasenv context t1 t2 ugraph
+ in
+ if b then
+ subst, metasenv, ugraph1
+ else
+ raise
+ (UnificationFailure (lazy (sprintf
+ "Can't unify %s with %s because they are not convertible"
+ (CicMetaSubst.ppterm subst t1)
+ (CicMetaSubst.ppterm subst t2))))
+ | (C.Prod _, t2) ->
+ let t2' = R.whd ~subst context t2 in
+ (match t2' with
+ C.Prod _ ->
+ fo_unif_subst test_equality_only
+ subst context metasenv t1 t2' ugraph
+ | _ -> raise (UnificationFailure (lazy "8")))
+ | (t1, C.Prod _) ->
+ let t1' = R.whd ~subst context t1 in
+ (match t1' with
+ C.Prod _ ->
+ fo_unif_subst test_equality_only
+ subst context metasenv t1' t2 ugraph
+ | _ -> (* raise (UnificationFailure "9")) *)
+ raise
+ (UnificationFailure (lazy (sprintf
+ "Can't unify %s with %s because they are not convertible"
+ (CicMetaSubst.ppterm subst t1)
+ (CicMetaSubst.ppterm subst t2)))))
+ | (_,_) ->
+ raise (UnificationFailure (lazy "10"))
+ (* (sprintf
+ "Can't unify %s with %s because they are not convertible"
+ (CicMetaSubst.ppterm subst t1)
+ (CicMetaSubst.ppterm subst t2))) *)
+
+and fo_unif_subst_exp_named_subst test_equality_only subst context metasenv
+ exp_named_subst1 exp_named_subst2 ugraph
+=
+ try
+ List.fold_left2
+ (fun (subst,metasenv,ugraph) (uri1,t1) (uri2,t2) ->
+ assert (uri1=uri2) ;
+ fo_unif_subst test_equality_only subst context metasenv t1 t2 ugraph
+ ) (subst,metasenv,ugraph) exp_named_subst1 exp_named_subst2
+ with
+ Invalid_argument _ ->
+ let print_ens ens =
+ String.concat " ; "
+ (List.map
+ (fun (uri,t) ->
+ UriManager.string_of_uri uri ^ " := " ^ (CicMetaSubst.ppterm subst t)
+ ) ens)
+ in
+ raise (UnificationFailure (lazy (sprintf
+ "Error trying to unify the two explicit named substitutions (local contexts) %s and %s: their lengths is different." (print_ens exp_named_subst1) (print_ens exp_named_subst2))))
+
+(* A substitution is a (int * Cic.term) list that associates a *)
+(* metavariable i with its body. *)
+(* metasenv is of type Cic.metasenv *)
+(* fo_unif takes a metasenv, a context, two terms t1 and t2 and gives back *)
+(* a new substitution which is already unwinded and ready to be applied and *)
+(* a new metasenv in which some hypothesis in the contexts of the *)
+(* metavariables may have been restricted. *)
+let fo_unif metasenv context t1 t2 ugraph =
+ fo_unif_subst false [] context metasenv t1 t2 ugraph ;;
+
+let enrich_msg msg subst context metasenv t1 t2 ugraph =
+ lazy (
+ if verbose then
+ sprintf "[Verbose] Unification error unifying %s of type %s with %s of type %s in context\n%s\nand metasenv\n%s\nand substitution\n%s\nbecause %s"
+ (CicMetaSubst.ppterm subst t1)
+ (try
+ let ty_t1,_ = type_of_aux' metasenv subst context t1 ugraph in
+ CicPp.ppterm ty_t1
+ with
+ | UnificationFailure s
+ | Uncertain s
+ | AssertFailure s -> sprintf "MALFORMED(t1): \n<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))
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception 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
+
--- /dev/null
+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
--- /dev/null
+PACKAGE = content_pres
+PREDICATES =
+
+INTERFACE_FILES = \
+ renderingAttrs.mli \
+ cicNotationLexer.mli \
+ cicNotationParser.mli \
+ mpresentation.mli \
+ box.mli \
+ content2presMatcher.mli \
+ termContentPres.mli \
+ cicNotationPres.mli \
+ boxPp.mli \
+ content2pres.mli \
+ sequent2pres.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = \
+ $(INTERFACE_FILES:%.mli=%.ml)
+
+cicNotationPres.cmi: OCAMLOPTIONS += -rectypes
+cicNotationPres.cmo: OCAMLOPTIONS += -rectypes
+cicNotationPres.cmx: OCAMLOPTIONS += -rectypes
+
+all: test_lexer
+clean: clean_tests
+
+LOCAL_LINKOPTS = -package helm-content_pres -linkpkg
+test: test_lexer
+test_lexer: test_lexer.ml $(PACKAGE).cma
+ @echo " OCAMLC $<"
+ @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
+
+clean_tests:
+ rm -f test_lexer{,.opt}
+
+cicNotationLexer.cmo: OCAMLC = $(OCAMLC_P4)
+cicNotationParser.cmo: OCAMLC = $(OCAMLC_P4)
+cicNotationLexer.cmx: OCAMLOPT = $(OCAMLOPT_P4)
+cicNotationParser.cmx: OCAMLOPT = $(OCAMLOPT_P4)
+cicNotationLexer.ml.annot: OCAMLC = $(OCAMLC_P4)
+cicNotationParser.ml.annot: OCAMLC = $(OCAMLC_P4)
+
+include ../../Makefile.defs
+include ../Makefile.common
+
+# <cross> 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>
+
--- /dev/null
+(* 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 b_toggle items = Action ([ None, "type", "toggle"], items)
+
+let pp_attr attr =
+ let pp (ns, n, v) =
+ Printf.sprintf "%s%s=%s" (match ns with None -> "" | Some s -> s ^ ":") n v
+ in
+ String.concat " " (List.map pp attr)
+
+let get_attr = function
+ | Text (attr, _)
+ | Space attr
+ | Ink attr
+ | H (attr, _)
+ | V (attr, _)
+ | HV (attr, _)
+ | HOV (attr, _)
+ | Object (attr, _)
+ | Action (attr, _) ->
+ attr
+
+let set_attr attr = function
+ | Text (_, x) -> Text (attr, x)
+ | Space _ -> Space attr
+ | Ink _ -> Ink attr
+ | H (_, x) -> H (attr, x)
+ | V (_, x) -> V (attr, x)
+ | HV (_, x) -> HV (attr, x)
+ | HOV (_, x) -> HOV (attr, x)
+ | Object (_, x) -> Object (attr, x)
+ | Action (_, x) -> Action (attr, x)
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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 b_toggle: 'expr box list -> 'expr box (** action which toggle among items *)
+
+val pp_attr: attr -> string
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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)
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 _ -> []
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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: *)
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+module Ast = CicNotationPt
+module Mpres = Mpresentation
+
+type mathml_markup = boxml_markup Mpres.mpres
+and boxml_markup = mathml_markup Box.box
+
+type markup = mathml_markup
+
+let atop_attributes = [None, "linethickness", "0pt"]
+
+let to_unicode = Utf8Macro.unicode_of_tex
+
+let rec make_attributes l1 = function
+ | [] -> []
+ | hd :: tl ->
+ (match hd with
+ | None -> make_attributes (List.tl l1) tl
+ | Some s ->
+ let p,n = List.hd l1 in
+ (p,n,s) :: make_attributes (List.tl l1) tl)
+
+let box_of_mpres =
+ function
+ | Mpresentation.Mobject (attrs, box) ->
+ assert (attrs = []);
+ box
+ | mpres -> Box.Object ([], mpres)
+
+let mpres_of_box =
+ function
+ | Box.Object (attrs, mpres) ->
+ assert (attrs = []);
+ mpres
+ | box -> Mpresentation.Mobject ([], box)
+
+let rec genuine_math =
+ function
+ | Mpresentation.Mobject ([], obj) -> not (genuine_box obj)
+ | _ -> true
+and genuine_box =
+ function
+ | Box.Object ([], mpres) -> not (genuine_math mpres)
+ | _ -> true
+
+let rec eligible_math =
+ function
+ | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> eligible_math mpres
+ | Mpresentation.Mobject ([], _) -> false
+ | _ -> true
+
+let rec promote_to_math =
+ function
+ | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> promote_to_math mpres
+ | math -> math
+
+let small_skip =
+ Mpresentation.Mspace (RenderingAttrs.small_skip_attributes `MathML)
+
+let rec add_mpres_attributes new_attr = function
+ | Mpresentation.Mobject (attr, box) ->
+ Mpresentation.Mobject (attr, add_box_attributes new_attr box)
+ | mpres ->
+ Mpresentation.set_attr (new_attr @ Mpresentation.get_attr mpres) mpres
+and add_box_attributes new_attr = function
+ | Box.Object (attr, mpres) ->
+ Box.Object (attr, add_mpres_attributes new_attr mpres)
+ | box -> Box.set_attr (new_attr @ Box.get_attr box) box
+
+let box_of mathonly spec attrs children =
+ match children with
+ | [t] -> add_mpres_attributes attrs t
+ | _ ->
+ let kind, spacing, indent = spec in
+ let dress children =
+ if spacing then
+ CicNotationUtil.dress small_skip children
+ else
+ children
+ in
+ if mathonly then Mpresentation.Mrow (attrs, dress children)
+ else
+ let attrs' =
+ (if spacing then RenderingAttrs.spacing_attributes `BoxML else [])
+ @ (if indent then RenderingAttrs.indent_attributes `BoxML else [])
+ @ attrs
+ in
+ match kind with
+ | Ast.H ->
+ if List.for_all eligible_math children then
+ Mpresentation.Mrow (attrs',
+ dress (List.map promote_to_math children))
+ else
+ mpres_of_box (Box.H (attrs',
+ List.map box_of_mpres children))
+(* | Ast.H when List.for_all genuine_math children ->
+ Mpresentation.Mrow (attrs', dress children) *)
+ | Ast.V ->
+ mpres_of_box (Box.V (attrs',
+ List.map box_of_mpres children))
+ | Ast.HV ->
+ mpres_of_box (Box.HV (attrs',
+ List.map box_of_mpres children))
+ | Ast.HOV ->
+ mpres_of_box (Box.HOV (attrs',
+ List.map box_of_mpres children))
+
+let open_paren = Mpresentation.Mo ([], "(")
+let closed_paren = Mpresentation.Mo ([], ")")
+let open_brace = Mpresentation.Mo ([], "{")
+let closed_brace = Mpresentation.Mo ([], "}")
+let hidden_substs = Mpresentation.Mtext ([], "{...}")
+let open_box_paren = Box.Text ([], "(")
+let closed_box_paren = Box.Text ([], ")")
+let semicolon = Mpresentation.Mo ([], ";")
+let toggle_action children =
+ Mpresentation.Maction ([None, "actiontype", "toggle"], children)
+
+type child_pos = [ `Left | `Right | `Inner ]
+
+let pp_assoc =
+ function
+ | Gramext.LeftA -> "LeftA"
+ | Gramext.RightA -> "RightA"
+ | Gramext.NonA -> "NonA"
+
+let is_atomic t =
+ let rec aux_mpres = function
+ | Mpres.Mi _
+ | Mpres.Mo _
+ | Mpres.Mn _
+ | Mpres.Ms _
+ | Mpres.Mtext _
+ | Mpres.Mspace _ -> true
+ | Mpres.Mobject (_, box) -> aux_box box
+ | Mpres.Maction (_, [mpres])
+ | Mpres.Mrow (_, [mpres]) -> aux_mpres mpres
+ | _ -> false
+ and aux_box = function
+ | Box.Space _
+ | Box.Ink _
+ | Box.Text _ -> true
+ | Box.Object (_, mpres) -> aux_mpres mpres
+ | Box.H (_, [box])
+ | Box.V (_, [box])
+ | Box.HV (_, [box])
+ | Box.HOV (_, [box])
+ | Box.Action (_, [box]) -> aux_box box
+ | _ -> false
+ in
+ aux_mpres t
+
+let add_parens child_prec child_assoc child_pos curr_prec t =
+(* eprintf
+ ("add_parens: " ^^
+ "child_prec = %d\nchild_assoc = %s\nchild_pos = %s\ncurr_prec= %d\n\n%!")
+ child_prec (pp_assoc child_assoc) (CicNotationPp.pp_pos child_pos)
+ curr_prec; *)
+ if is_atomic t then t
+ else if child_prec >= 0
+ && (child_prec < curr_prec
+ || (child_prec = curr_prec &&
+ child_assoc = Gramext.LeftA &&
+ child_pos <> `Left)
+ || (child_prec = curr_prec &&
+ child_assoc = Gramext.RightA &&
+ child_pos <> `Right))
+ then begin (* parens should be added *)
+(* prerr_endline "adding parens!"; *)
+ match t with
+ | Mpresentation.Mobject (_, box) ->
+ mpres_of_box (Box.H ([], [ open_box_paren; box; closed_box_paren ]))
+ | mpres -> Mpresentation.Mrow ([], [open_paren; t; closed_paren])
+ end else
+ t
+
+let render ids_to_uris =
+ let module A = Ast in
+ let module P = Mpresentation in
+(* let use_unicode = true in *)
+ let lookup_uri id =
+ (try
+ let uri = Hashtbl.find ids_to_uris id in
+ Some (UriManager.string_of_uri uri)
+ with Not_found -> None)
+ in
+ let make_href xmlattrs xref =
+ let xref_uris =
+ List.fold_right
+ (fun xref uris ->
+ match lookup_uri xref with
+ | None -> uris
+ | Some uri -> uri :: uris)
+ !xref []
+ in
+ let xmlattrs_uris, xmlattrs =
+ let xref_attrs, other_attrs =
+ List.partition
+ (function Some "xlink", "href", _ -> true | _ -> false)
+ xmlattrs
+ in
+ List.map (fun (_, _, uri) -> uri) xref_attrs,
+ other_attrs
+ in
+ let uris =
+ match xmlattrs_uris @ xref_uris with
+ | [] -> None
+ | uris ->
+ Some (String.concat " "
+ (HExtlib.list_uniq (List.sort String.compare uris)))
+ in
+ let xrefs =
+ match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs)
+ in
+ xref := [];
+ xmlattrs
+ @ make_attributes [Some "helm", "xref"; Some "xlink", "href"]
+ [xrefs; uris]
+ in
+ let make_xref xref =
+ let xrefs =
+ match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs)
+ in
+ xref := [];
+ make_attributes [Some "helm","xref"] [xrefs]
+ in
+ (* when mathonly is true no boxes should be generated, only mrows *)
+ (* "xref" is *)
+ let rec aux xmlattrs mathonly xref pos prec t =
+ match t with
+ | A.AttributedTerm _ ->
+ aux_attributes xmlattrs mathonly xref pos prec t
+ | A.Num (literal, _) ->
+ let attrs =
+ (RenderingAttrs.number_attributes `MathML)
+ @ make_href xmlattrs xref
+ in
+ Mpres.Mn (attrs, literal)
+ | A.Symbol (literal, _) ->
+ let attrs =
+ (RenderingAttrs.symbol_attributes `MathML)
+ @ make_href xmlattrs xref
+ in
+ Mpres.Mo (attrs, to_unicode literal)
+ | A.Ident (literal, subst)
+ | A.Uri (literal, subst) ->
+ let attrs =
+ (RenderingAttrs.ident_attributes `MathML)
+ @ make_href xmlattrs xref
+ in
+ let name = Mpres.Mi (attrs, to_unicode literal) in
+ (match subst with
+ | Some []
+ | None -> name
+ | Some substs ->
+ let substs' =
+ box_of mathonly (A.H, false, false) []
+ (open_brace
+ :: (CicNotationUtil.dress semicolon
+ (List.map
+ (fun (name, t) ->
+ box_of mathonly (A.H, false, false) [] [
+ Mpres.Mi ([], name);
+ Mpres.Mo ([], to_unicode "\\def");
+ aux [] mathonly xref pos prec t ])
+ substs))
+ @ [ closed_brace ])
+ in
+ let substs_maction = toggle_action [ hidden_substs; substs' ] in
+ box_of mathonly (A.H, false, false) [] [ name; substs_maction ])
+ | A.Literal l -> aux_literal xmlattrs xref prec l
+ | A.UserInput -> Mpres.Mtext ([], "%")
+ | A.Layout l -> aux_layout mathonly xref pos prec l
+ | A.Magic _
+ | A.Variable _ -> assert false (* should have been instantiated *)
+ | t ->
+ prerr_endline ("unexpected ast: " ^ CicNotationPp.pp_term t);
+ assert false
+ and aux_attributes xmlattrs mathonly xref pos prec t =
+ let reset = ref false in
+ let new_level = ref None in
+ let new_xref = ref [] in
+ let new_xmlattrs = ref [] in
+ let new_pos = ref pos in
+(* let reinit = ref false in *)
+ let rec aux_attribute =
+ function
+ | A.AttributedTerm (attr, t) ->
+ (match attr with
+ | `Loc _
+ | `Raw _ -> ()
+ | `Level (-1, _) -> reset := true
+ | `Level (child_prec, child_assoc) ->
+ new_level := Some (child_prec, child_assoc)
+ | `IdRef xref -> new_xref := xref :: !new_xref
+ | `ChildPos pos -> new_pos := pos
+ | `XmlAttrs attrs -> new_xmlattrs := attrs @ !new_xmlattrs);
+ aux_attribute t
+ | t ->
+ (match !new_level with
+ | None -> aux !new_xmlattrs mathonly new_xref !new_pos prec t
+ | Some (child_prec, child_assoc) ->
+ let t' =
+ aux !new_xmlattrs mathonly new_xref !new_pos child_prec t in
+ if !reset
+ then t'
+ else add_parens child_prec child_assoc !new_pos prec t')
+ in
+ aux_attribute t
+ and aux_literal xmlattrs xref prec l =
+ let attrs = make_href xmlattrs xref in
+ (match l with
+ | `Symbol s -> Mpres.Mo (attrs, to_unicode s)
+ | `Keyword s -> Mpres.Mo (attrs, to_unicode s)
+ | `Number s -> Mpres.Mn (attrs, to_unicode s))
+ and aux_layout mathonly xref pos prec l =
+ let attrs = make_xref xref in
+ let invoke' t = aux [] true (ref []) pos prec t in
+ (* use the one below to reset precedence and associativity *)
+ let invoke_reinit t = aux [] mathonly xref `Inner ~-1 t in
+ match l with
+ | A.Sub (t1, t2) -> Mpres.Msub (attrs, invoke' t1, invoke_reinit t2)
+ | A.Sup (t1, t2) -> Mpres.Msup (attrs, invoke' t1, invoke_reinit t2)
+ | A.Below (t1, t2) -> Mpres.Munder (attrs, invoke' t1, invoke_reinit t2)
+ | A.Above (t1, t2) -> Mpres.Mover (attrs, invoke' t1, invoke_reinit t2)
+ | A.Frac (t1, t2)
+ | A.Over (t1, t2) ->
+ Mpres.Mfrac (attrs, invoke_reinit t1, invoke_reinit t2)
+ | A.Atop (t1, t2) ->
+ Mpres.Mfrac (atop_attributes @ attrs, invoke_reinit t1,
+ invoke_reinit t2)
+ | A.Sqrt t -> Mpres.Msqrt (attrs, invoke_reinit t)
+ | A.Root (t1, t2) ->
+ Mpres.Mroot (attrs, invoke_reinit t1, invoke_reinit t2)
+ | A.Box ((_, spacing, _) as kind, terms) ->
+ let children =
+ aux_children mathonly spacing xref pos prec
+ (CicNotationUtil.ungroup terms)
+ in
+ box_of mathonly kind attrs children
+ | A.Group terms ->
+ let children =
+ aux_children mathonly false xref pos prec
+ (CicNotationUtil.ungroup terms)
+ in
+ box_of mathonly (A.H, false, false) attrs children
+ | A.Break -> assert false (* TODO? *)
+ and aux_children mathonly spacing xref pos prec terms =
+ let find_clusters =
+ let rec aux_list first clusters acc =
+ function
+ [] when acc = [] -> List.rev clusters
+ | [] -> aux_list first (List.rev acc :: clusters) [] []
+ | (A.Layout A.Break) :: tl when acc = [] ->
+ aux_list first clusters [] tl
+ | (A.Layout A.Break) :: tl ->
+ aux_list first (List.rev acc :: clusters) [] tl
+ | [hd] ->
+(* let pos' =
+ if first then
+ pos
+ else
+ match pos with
+ `None -> `Right
+ | `Inner -> `Inner
+ | `Right -> `Right
+ | `Left -> `Inner
+ in *)
+ aux_list false clusters
+ (aux [] mathonly xref pos prec hd :: acc) []
+ | hd :: tl ->
+(* let pos' =
+ match pos, first with
+ `None, true -> `Left
+ | `None, false -> `Inner
+ | `Left, true -> `Left
+ | `Left, false -> `Inner
+ | `Right, _ -> `Inner
+ | `Inner, _ -> `Inner
+ in *)
+ aux_list false clusters
+ (aux [] mathonly xref pos prec hd :: acc) tl
+ in
+ aux_list true [] []
+ in
+ let boxify_pres =
+ function
+ [t] -> t
+ | tl -> box_of mathonly (A.H, spacing, false) [] tl
+ in
+ List.map boxify_pres (find_clusters terms)
+ in
+ aux [] false (ref []) `Inner ~-1
+
+let rec print_box (t: boxml_markup) =
+ Box.box2xml print_mpres t
+and print_mpres (t: mathml_markup) =
+ Mpresentation.print_mpres print_box t
+
+let print_xml = print_mpres
+
+(* let render_to_boxml id_to_uri t =
+ let xml_stream = print_box (box_of_mpres (render id_to_uri t)) in
+ Xml.add_xml_declaration xml_stream *)
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* 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 ->
+ let concl =
+ make_concl ~attrs:[ Some "helm", "xref", p.Con.proof_id ]
+ "proof of" ac in
+ B.b_toggle [ concl; body ]
+ in
+ B.V ([],
+ [B.Text ([],"(" ^ name ^ ")");
+ B.indent action])
+
+ and context2pres c continuation =
+ (* we generate a subtable for each context element, for selection
+ purposes
+ The table generated by the head-element does not have an xref;
+ the whole context-proof is already selectable *)
+ match c with
+ [] -> continuation
+ | hd::tl ->
+ let continuation' =
+ List.fold_right
+ (fun ce continuation ->
+ let xref = get_xref ce in
+ B.V([Some "helm", "xref", xref ],
+ [B.H([Some "helm", "xref", "ce_"^xref],
+ [ce2pres_in_proof_context_element ce]);
+ continuation])) tl continuation in
+ let hd_xref= get_xref hd in
+ B.V([],
+ [B.H([Some "helm", "xref", "ce_"^hd_xref],
+ [ce2pres_in_proof_context_element hd]);
+ continuation'])
+
+ and ce2pres_in_joint_context_element = function
+ | `Inductive _ -> assert false (* TODO *)
+ | (`Declaration _) as x -> ce2pres x
+ | (`Hypothesis _) as x -> ce2pres x
+ | (`Proof _) as x -> ce2pres x
+ | (`Definition _) as x -> ce2pres x
+
+ and ce2pres_in_proof_context_element = function
+ | `Joint ho ->
+ B.H ([],(List.map ce2pres_in_joint_context_element ho.Content.joint_defs))
+ | (`Declaration _) as x -> ce2pres x
+ | (`Hypothesis _) as x -> ce2pres x
+ | (`Proof _) as x -> ce2pres x
+ | (`Definition _) as x -> ce2pres x
+
+ and ce2pres =
+ function
+ `Declaration d ->
+ (match d.Con.dec_name with
+ Some s ->
+ let ty = term2pres d.Con.dec_type in
+ B.H ([],
+ [(B.b_kw "Assume");
+ B.b_space;
+ B.Object ([], P.Mi([],s));
+ B.Text([],":");
+ ty])
+ | None ->
+ prerr_endline "NO NAME!!"; assert false)
+ | `Hypothesis h ->
+ (match h.Con.dec_name with
+ Some s ->
+ let ty = term2pres h.Con.dec_type in
+ B.H ([],
+ [(B.b_kw "Suppose");
+ B.b_space;
+ B.Text([],"(");
+ B.Object ([], P.Mi ([],s));
+ B.Text([],")");
+ B.b_space;
+ ty])
+ | None ->
+ prerr_endline "NO NAME!!"; assert false)
+ | `Proof p ->
+ proof2pres p
+ | `Definition d ->
+ (match d.Con.def_name with
+ Some s ->
+ let term = term2pres d.Con.def_term in
+ B.H ([],
+ [ B.b_kw "Let"; B.b_space;
+ B.Object ([], P.Mi([],s));
+ B.Text([]," = ");
+ term])
+ | None ->
+ prerr_endline "NO NAME!!"; assert false)
+
+ and acontext2pres ac continuation indent =
+ List.fold_right
+ (fun p continuation ->
+ let hd =
+ if indent then
+ B.indent (proof2pres p)
+ else
+ proof2pres p in
+ B.V([Some "helm","xref",p.Con.proof_id],
+ [B.H([Some "helm","xref","ace_"^p.Con.proof_id],[hd]);
+ continuation])) ac continuation
+
+ and conclude2pres conclude indent omit_conclusion =
+ let tconclude_body =
+ match conclude.Con.conclude_conclusion with
+ Some t when
+ not omit_conclusion or
+ (* CSC: I ignore the omit_conclusion flag in this case. *)
+ (* CSC: Is this the correct behaviour? In the stylesheets *)
+ (* CSC: we simply generated nothing (i.e. the output type *)
+ (* CSC: of the function should become an option. *)
+ conclude.Con.conclude_method = "BU_Conversion" ->
+ let concl = (term2pres t) in
+ if conclude.Con.conclude_method = "BU_Conversion" then
+ make_concl "that is equivalent to" concl
+ else if conclude.Con.conclude_method = "FalseInd" then
+ (* false ind is in charge to add the conclusion *)
+ falseind conclude
+ else
+ let conclude_body = conclude_aux conclude in
+ let ann_concl =
+ if conclude.Con.conclude_method = "TD_Conversion" then
+ make_concl "that is equivalent to" concl
+ else make_concl "we conclude" concl in
+ B.V ([], [conclude_body; ann_concl])
+ | _ -> conclude_aux conclude in
+ if indent then
+ B.indent (B.H ([Some "helm", "xref", conclude.Con.conclude_id],
+ [tconclude_body]))
+ else
+ B.H ([Some "helm", "xref", conclude.Con.conclude_id],[tconclude_body])
+
+ and conclude_aux conclude =
+ if conclude.Con.conclude_method = "TD_Conversion" then
+ let expected =
+ (match conclude.Con.conclude_conclusion with
+ None -> B.Text([],"NO EXPECTED!!!")
+ | Some c -> term2pres c) in
+ let subproof =
+ (match conclude.Con.conclude_args with
+ [Con.ArgProof p] -> p
+ | _ -> assert false) in
+ let synth =
+ (match subproof.Con.proof_conclude.Con.conclude_conclusion with
+ None -> B.Text([],"NO SYNTH!!!")
+ | Some c -> (term2pres c)) in
+ B.V
+ ([],
+ [make_concl "we must prove" expected;
+ make_concl "or equivalently" synth;
+ proof2pres subproof])
+ else if conclude.Con.conclude_method = "BU_Conversion" then
+ assert false
+ else if conclude.Con.conclude_method = "Exact" then
+ let arg =
+ (match conclude.Con.conclude_args with
+ [Con.Term t] -> term2pres t
+ | [Con.Premise p] ->
+ (match p.Con.premise_binder with
+ | None -> assert false; (* unnamed hypothesis ??? *)
+ | Some s -> B.Text([],s))
+ | err -> assert false) in
+ (match conclude.Con.conclude_conclusion with
+ None ->
+ B.b_h [] [B.b_kw "Consider"; B.b_space; arg]
+ | Some c -> let conclusion = term2pres c in
+ make_row
+ [arg; B.b_space; B.b_kw "proves"]
+ conclusion
+ )
+ else if conclude.Con.conclude_method = "Intros+LetTac" then
+ (match conclude.Con.conclude_args with
+ [Con.ArgProof p] -> proof2pres p
+ | _ -> assert false)
+(* OLD CODE
+ let conclusion =
+ (match conclude.Con.conclude_conclusion with
+ None -> B.Text([],"NO Conclusion!!!")
+ | Some c -> term2pres c) in
+ (match conclude.Con.conclude_args with
+ [Con.ArgProof p] ->
+ B.V
+ ([None,"align","baseline 1"; None,"equalrows","false";
+ None,"columnalign","left"],
+ [B.H([],[B.Object([],proof2pres p)]);
+ B.H([],[B.Object([],
+ (make_concl "we proved 1" conclusion))])]);
+ | _ -> assert false)
+*)
+ else if (conclude.Con.conclude_method = "Case") then
+ case conclude
+ else if (conclude.Con.conclude_method = "ByInduction") then
+ byinduction conclude
+ else if (conclude.Con.conclude_method = "Exists") then
+ exists conclude
+ else if (conclude.Con.conclude_method = "AndInd") then
+ andind conclude
+ else if (conclude.Con.conclude_method = "FalseInd") then
+ falseind conclude
+ else if (conclude.Con.conclude_method = "Rewrite") then
+ let justif =
+ (match (List.nth conclude.Con.conclude_args 6) with
+ Con.ArgProof p -> justification term2pres p
+ | _ -> assert false) in
+ let term1 =
+ (match List.nth conclude.Con.conclude_args 2 with
+ Con.Term t -> term2pres t
+ | _ -> assert false) in
+ let term2 =
+ (match List.nth conclude.Con.conclude_args 5 with
+ Con.Term t -> term2pres t
+ | _ -> assert false) in
+ B.V ([],
+ [B.H ([],[
+ (B.b_kw "rewrite");
+ B.b_space; term1;
+ B.b_space; (B.b_kw "with");
+ B.b_space; term2;
+ B.indent justif])])
+ else if conclude.Con.conclude_method = "Apply" then
+ let pres_args =
+ make_args_for_apply term2pres conclude.Con.conclude_args in
+ B.H([],
+ (B.b_kw "by")::
+ B.b_space::
+ B.Text([],"(")::pres_args@[B.Text([],")")])
+ else
+ B.V ([], [
+ B.b_kw ("Apply method" ^ conclude.Con.conclude_method ^ " to");
+ (B.indent (B.V ([], args2pres conclude.Con.conclude_args)))])
+
+ and args2pres l = List.map arg2pres l
+
+ and arg2pres =
+ function
+ Con.Aux n -> B.b_kw ("aux " ^ n)
+ | Con.Premise prem -> B.b_kw "premise"
+ | Con.Lemma lemma -> B.b_kw "lemma"
+ | Con.Term t -> term2pres t
+ | Con.ArgProof p -> proof2pres p
+ | Con.ArgMethod s -> B.b_kw "method"
+
+ and case conclude =
+ let proof_conclusion =
+ (match conclude.Con.conclude_conclusion with
+ None -> B.b_kw "No conclusion???"
+ | Some t -> term2pres t) in
+ let arg,args_for_cases =
+ (match conclude.Con.conclude_args with
+ Con.Aux(_)::Con.Aux(_)::Con.Term(_)::arg::tl ->
+ arg,tl
+ | _ -> assert false) in
+ let case_on =
+ let case_arg =
+ (match arg with
+ Con.Aux n -> B.b_kw "an aux???"
+ | Con.Premise prem ->
+ (match prem.Con.premise_binder with
+ None -> B.b_kw "the previous result"
+ | Some n -> B.Object ([], P.Mi([],n)))
+ | Con.Lemma lemma -> B.Object ([], P.Mi([],lemma.Con.lemma_name))
+ | Con.Term t ->
+ term2pres t
+ | Con.ArgProof p -> B.b_kw "a proof???"
+ | Con.ArgMethod s -> B.b_kw "a method???")
+ in
+ (make_concl "we proceed by cases on" case_arg) in
+ let to_prove =
+ (make_concl "to prove" proof_conclusion) in
+ B.V ([], case_on::to_prove::(make_cases args_for_cases))
+
+ and byinduction conclude =
+ let proof_conclusion =
+ (match conclude.Con.conclude_conclusion with
+ None -> B.b_kw "No conclusion???"
+ | Some t -> term2pres t) in
+ let inductive_arg,args_for_cases =
+ (match conclude.Con.conclude_args with
+ Con.Aux(n)::_::tl ->
+ let l1,l2 = split (int_of_string n) tl in
+ let last_pos = (List.length l2)-1 in
+ List.nth l2 last_pos,l1
+ | _ -> assert false) in
+ let induction_on =
+ let arg =
+ (match inductive_arg with
+ Con.Aux n -> B.b_kw "an aux???"
+ | Con.Premise prem ->
+ (match prem.Con.premise_binder with
+ None -> B.b_kw "the previous result"
+ | Some n -> B.Object ([], P.Mi([],n)))
+ | Con.Lemma lemma -> B.Object ([], P.Mi([],lemma.Con.lemma_name))
+ | Con.Term t ->
+ term2pres t
+ | Con.ArgProof p -> B.b_kw "a proof???"
+ | Con.ArgMethod s -> B.b_kw "a method???") in
+ (make_concl "we proceed by induction on" arg) in
+ let to_prove =
+ (make_concl "to prove" proof_conclusion) in
+ B.V ([], induction_on::to_prove:: (make_cases args_for_cases))
+
+ and make_cases l = List.map make_case l
+
+ and make_case =
+ function
+ Con.ArgProof p ->
+ let name =
+ (match p.Con.proof_name with
+ None -> B.b_kw "no name for case!!"
+ | Some n -> B.Object ([], P.Mi([],n))) in
+ let indhyps,args =
+ List.partition
+ (function
+ `Hypothesis h -> h.Con.dec_inductive
+ | _ -> false) p.Con.proof_context in
+ let pattern_aux =
+ List.fold_right
+ (fun e p ->
+ let dec =
+ (match e with
+ `Declaration h
+ | `Hypothesis h ->
+ let name =
+ (match h.Con.dec_name with
+ None -> "NO NAME???"
+ | Some n ->n) in
+ [B.b_space;
+ B.Object ([], P.Mi ([],name));
+ B.Text([],":");
+ (term2pres h.Con.dec_type)]
+ | _ -> [B.Text ([],"???")]) in
+ dec@p) args [] in
+ let pattern =
+ B.H ([],
+ (B.b_kw "Case"::B.b_space::name::pattern_aux)@
+ [B.b_space;
+ B.Text([], Utf8Macro.unicode_of_tex "\\Rightarrow")]) in
+ let subconcl =
+ (match p.Con.proof_conclude.Con.conclude_conclusion with
+ None -> B.b_kw "No conclusion!!!"
+ | Some t -> term2pres t) in
+ let asubconcl = B.indent (make_concl "the thesis becomes" subconcl) in
+ let induction_hypothesis =
+ (match indhyps with
+ [] -> []
+ | _ ->
+ let text = B.indent (B.b_kw "by induction hypothesis we know") in
+ let make_hyp =
+ function
+ `Hypothesis h ->
+ let name =
+ (match h.Con.dec_name with
+ None -> "no name"
+ | Some s -> s) in
+ B.indent (B.H ([],
+ [B.Text([],"(");
+ B.Object ([], P.Mi ([],name));
+ B.Text([],")");
+ B.b_space;
+ term2pres h.Con.dec_type]))
+ | _ -> assert false in
+ let hyps = List.map make_hyp indhyps in
+ text::hyps) in
+ (* let acontext =
+ acontext2pres_old p.Con.proof_apply_context true in *)
+ let body = conclude2pres p.Con.proof_conclude true false in
+ let presacontext =
+ let acontext_id =
+ match p.Con.proof_apply_context with
+ [] -> p.Con.proof_conclude.Con.conclude_id
+ | {Con.proof_id = id}::_ -> id
+ in
+ B.Action([None,"type","toggle"],
+ [ B.indent (add_xref acontext_id (B.b_kw "Proof"));
+ acontext2pres p.Con.proof_apply_context body true]) in
+ B.V ([], pattern::asubconcl::induction_hypothesis@[presacontext])
+ | _ -> assert false
+
+ and falseind conclude =
+ let proof_conclusion =
+ (match conclude.Con.conclude_conclusion with
+ None -> B.b_kw "No conclusion???"
+ | Some t -> term2pres t) in
+ let case_arg =
+ (match conclude.Con.conclude_args with
+ [Con.Aux(n);_;case_arg] -> case_arg
+ | _ -> assert false;
+ (*
+ List.map (ContentPp.parg 0) conclude.Con.conclude_args;
+ assert false *)) in
+ let arg =
+ (match case_arg with
+ Con.Aux n -> assert false
+ | Con.Premise prem ->
+ (match prem.Con.premise_binder with
+ None -> [B.b_kw "Contradiction, hence"]
+ | Some n ->
+ [ B.Object ([],P.Mi([],n)); B.skip;
+ B.b_kw "is contradictory, hence"])
+ | Con.Lemma lemma ->
+ [ B.Object ([], P.Mi([],lemma.Con.lemma_name)); B.skip;
+ B.b_kw "is contradictory, hence" ]
+ | _ -> assert false) in
+ (* let body = proof2pres {proof with Con.proof_context = tl} in *)
+ make_row arg proof_conclusion
+
+ and andind conclude =
+ let proof,case_arg =
+ (match conclude.Con.conclude_args with
+ [Con.Aux(n);_;Con.ArgProof proof;case_arg] -> proof,case_arg
+ | _ -> assert false;
+ (*
+ List.map (ContentPp.parg 0) conclude.Con.conclude_args;
+ assert false *)) in
+ let arg =
+ (match case_arg with
+ Con.Aux n -> assert false
+ | Con.Premise prem ->
+ (match prem.Con.premise_binder with
+ None -> []
+ | Some n -> [(B.b_kw "by"); B.b_space; B.Object([], P.Mi([],n))])
+ | Con.Lemma lemma ->
+ [(B.b_kw "by");B.skip;
+ B.Object([], P.Mi([],lemma.Con.lemma_name))]
+ | _ -> assert false) in
+ match proof.Con.proof_context with
+ `Hypothesis hyp1::`Hypothesis hyp2::tl ->
+ let get_name hyp =
+ (match hyp.Con.dec_name with
+ None -> "_"
+ | Some s -> s) in
+ let preshyp1 =
+ B.H ([],
+ [B.Text([],"(");
+ B.Object ([], P.Mi([],get_name hyp1));
+ B.Text([],")");
+ B.skip;
+ term2pres hyp1.Con.dec_type]) in
+ let preshyp2 =
+ B.H ([],
+ [B.Text([],"(");
+ B.Object ([], P.Mi([],get_name hyp2));
+ B.Text([],")");
+ B.skip;
+ term2pres hyp2.Con.dec_type]) in
+ (* let body = proof2pres {proof with Con.proof_context = tl} in *)
+ let body = conclude2pres proof.Con.proof_conclude false true in
+ let presacontext =
+ acontext2pres proof.Con.proof_apply_context body false in
+ B.V
+ ([],
+ [B.H ([],arg@[B.skip; B.b_kw "we have"]);
+ preshyp1;
+ B.b_kw "and";
+ preshyp2;
+ presacontext]);
+ | _ -> assert false
+
+ and exists conclude =
+ let proof =
+ (match conclude.Con.conclude_args with
+ [Con.Aux(n);_;Con.ArgProof proof;_] -> proof
+ | _ -> assert false;
+ (*
+ List.map (ContentPp.parg 0) conclude.Con.conclude_args;
+ assert false *)) in
+ match proof.Con.proof_context with
+ `Declaration decl::`Hypothesis hyp::tl
+ | `Hypothesis decl::`Hypothesis hyp::tl ->
+ let get_name decl =
+ (match decl.Con.dec_name with
+ None -> "_"
+ | Some s -> s) in
+ let presdecl =
+ B.H ([],
+ [(B.b_kw "let");
+ B.skip;
+ B.Object ([], P.Mi([],get_name decl));
+ B.Text([],":"); term2pres decl.Con.dec_type]) in
+ let suchthat =
+ B.H ([],
+ [(B.b_kw "such that");
+ B.skip;
+ B.Text([],"(");
+ B.Object ([], P.Mi([],get_name hyp));
+ B.Text([],")");
+ B.skip;
+ term2pres hyp.Con.dec_type]) in
+ (* let body = proof2pres {proof with Con.proof_context = tl} in *)
+ let body = conclude2pres proof.Con.proof_conclude false true in
+ let presacontext =
+ acontext2pres proof.Con.proof_apply_context body false in
+ B.V
+ ([],
+ [presdecl;
+ suchthat;
+ presacontext]);
+ | _ -> assert false
+
+ in
+ proof2pres p
+
+exception ToDo
+
+let counter = ref 0
+
+let conjecture2pres term2pres (id, n, context, ty) =
+ B.b_indent
+ (B.b_hv [Some "helm", "xref", id]
+ ((B.b_toggle [
+ B.b_h [] [B.b_text [] "{...}"; B.b_space];
+ B.b_hv [] (List.map
+ (function
+ | None ->
+ B.b_h []
+ [ B.b_object (p_mi [] "_") ;
+ B.b_object (p_mo [] ":?") ;
+ B.b_object (p_mi [] "_")]
+ | Some (`Declaration d)
+ | Some (`Hypothesis d) ->
+ let { Content.dec_name =
+ dec_name ; Content.dec_type = ty } = d
+ in
+ B.b_h []
+ [ B.b_object
+ (p_mi []
+ (match dec_name with
+ None -> "_"
+ | Some n -> n));
+ B.b_text [] ":";
+ term2pres ty ]
+ | Some (`Definition d) ->
+ let
+ { Content.def_name = def_name ;
+ Content.def_term = bo } = d
+ in
+ B.b_h []
+ [ B.b_object (p_mi []
+ (match def_name with
+ None -> "_"
+ | Some n -> n)) ;
+ B.b_text [] (Utf8Macro.unicode_of_tex "\\Assign");
+ term2pres bo]
+ | Some (`Proof p) ->
+ let proof_name = p.Content.proof_name in
+ B.b_h []
+ [ B.b_object (p_mi []
+ (match proof_name with
+ None -> "_"
+ | Some n -> n)) ;
+ B.b_text [] (Utf8Macro.unicode_of_tex "\\Assign");
+ proof2pres term2pres p])
+ (List.rev context)) ] ::
+ [ B.b_h []
+ [ B.b_text [] (Utf8Macro.unicode_of_tex "\\vdash");
+ B.b_object (p_mi [] (string_of_int n)) ;
+ B.b_text [] ":" ;
+ term2pres ty ]])))
+
+let metasenv2pres term2pres = function
+ | None -> []
+ | Some metasenv' ->
+ (* Conjectures are in their own table to make *)
+ (* diffing the DOM trees easier. *)
+ [B.b_v []
+ ((B.b_kw ("Conjectures:" ^
+ (let _ = incr counter; in (string_of_int !counter)))) ::
+ (List.map (conjecture2pres term2pres) metasenv'))]
+
+let params2pres params =
+ let param2pres uri =
+ B.b_text [Some "xlink", "href", UriManager.string_of_uri uri]
+ (UriManager.name_of_uri uri)
+ in
+ let rec spatiate = function
+ | [] -> []
+ | hd :: [] -> [hd]
+ | hd :: tl -> hd :: B.b_text [] ", " :: spatiate tl
+ in
+ match params with
+ | [] -> []
+ | p ->
+ let params = spatiate (List.map param2pres p) in
+ [B.b_space;
+ B.b_h [] (B.b_text [] "[" :: params @ [ B.b_text [] "]" ])]
+
+let recursion_kind2pres params kind =
+ let kind =
+ match kind with
+ | `Recursive _ -> "Recursive definition"
+ | `CoRecursive -> "CoRecursive definition"
+ | `Inductive _ -> "Inductive definition"
+ | `CoInductive _ -> "CoInductive definition"
+ in
+ B.b_h [] (B.b_kw kind :: params2pres params)
+
+let inductive2pres term2pres ind =
+ let constructor2pres decl =
+ B.b_h [] [
+ B.b_text [] ("| " ^ get_name decl.Content.dec_name ^ ":");
+ B.b_space;
+ term2pres decl.Content.dec_type
+ ]
+ in
+ B.b_v []
+ (B.b_h [] [
+ B.b_kw (ind.Content.inductive_name ^ " of arity");
+ B.smallskip;
+ term2pres ind.Content.inductive_type ]
+ :: List.map constructor2pres ind.Content.inductive_constructors)
+
+let joint_def2pres term2pres def =
+ match def with
+ | `Inductive ind -> inductive2pres term2pres ind
+ | _ -> assert false (* ZACK or raise ToDo? *)
+
+let content2pres term2pres (id,params,metasenv,obj) =
+ match obj with
+ | `Def (Content.Const, thesis, `Proof p) ->
+ let name = get_name p.Content.proof_name in
+ B.b_v
+ [Some "helm","xref","id"]
+ ([ B.b_h [] (B.b_kw ("Proof " ^ name) :: params2pres params);
+ B.b_kw "Thesis:";
+ B.indent (term2pres thesis) ] @
+ metasenv2pres term2pres metasenv @
+ [proof2pres term2pres p])
+ | `Def (_, ty, `Definition body) ->
+ let name = get_name body.Content.def_name in
+ B.b_v
+ [Some "helm","xref","id"]
+ ([B.b_h [] (B.b_kw ("Definition " ^ name) :: params2pres params);
+ B.b_kw "Type:";
+ B.indent (term2pres ty)] @
+ metasenv2pres term2pres metasenv @
+ [B.b_kw "Body:"; term2pres body.Content.def_term])
+ | `Decl (_, `Declaration decl)
+ | `Decl (_, `Hypothesis decl) ->
+ let name = get_name decl.Content.dec_name in
+ B.b_v
+ [Some "helm","xref","id"]
+ ([B.b_h [] (B.b_kw ("Axiom " ^ name) :: params2pres params);
+ B.b_kw "Type:";
+ B.indent (term2pres decl.Content.dec_type)] @
+ metasenv2pres term2pres metasenv)
+ | `Joint joint ->
+ B.b_v []
+ (recursion_kind2pres params joint.Content.joint_kind
+ :: List.map (joint_def2pres term2pres) joint.Content.joint_defs)
+ | _ -> raise ToDo
+
+let content2pres ~ids_to_inner_sorts =
+ content2pres
+ (fun annterm ->
+ let ast, ids_to_uris =
+ TermAcicContent.ast_of_acic ids_to_inner_sorts annterm
+ in
+ CicNotationPres.box_of_mpres
+ (CicNotationPres.render ids_to_uris
+ (TermContentPres.pp_ast ast)))
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(**************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(**************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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)
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+type xml_attribute = string option * string * string
+type markup = [ `MathML | `BoxML ]
+
+let color1 = "blue"
+(* let color2 = "red" *)
+let color2 = "blue"
+
+let keyword_attributes = function
+ | `MathML -> [ None, "mathcolor", color1 ]
+ | `BoxML -> [ None, "color", color1 ]
+
+let builtin_symbol_attributes = function
+ | `MathML -> [ None, "mathcolor", color1 ]
+ | `BoxML -> [ None, "color", color1 ]
+
+let object_keyword_attributes = function
+ | `MathML -> [ None, "mathcolor", color2 ]
+ | `BoxML -> [ None, "color", color2 ]
+
+let symbol_attributes _ = []
+let ident_attributes _ = []
+let number_attributes _ = []
+
+let spacing_attributes _ = [ None, "spacing", "0.5em" ]
+let indent_attributes _ = [ None, "indent", "0.5em" ]
+let small_skip_attributes _ = [ None, "width", "0.5em" ]
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(***************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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)))
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(***************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 []
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 -> ()
+
--- /dev/null
+componentsConf.cmo: componentsConf.cmi
+componentsConf.cmx: componentsConf.cmi
+hExtlib.cmo: componentsConf.cmi hExtlib.cmi
+hExtlib.cmx: componentsConf.cmx hExtlib.cmi
+hMarshal.cmo: hExtlib.cmi hMarshal.cmi
+hMarshal.cmx: hExtlib.cmx hMarshal.cmi
+patternMatcher.cmo: patternMatcher.cmi
+patternMatcher.cmx: patternMatcher.cmi
+hLog.cmo: hLog.cmi
+hLog.cmx: hLog.cmi
+trie.cmo: trie.cmi
+trie.cmx: trie.cmi
--- /dev/null
+PACKAGE = extlib
+PREDICATES =
+
+INTERFACE_FILES = \
+ componentsConf.mli \
+ hExtlib.mli \
+ hMarshal.mli \
+ patternMatcher.mli \
+ hLog.mli \
+ trie.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = \
+ $(INTERFACE_FILES:%.mli=%.ml)
+EXTRA_OBJECTS_TO_INSTALL =
+EXTRA_OBJECTS_TO_CLEAN =
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2006, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+let debug = @DEBUG@
+let profiling = debug
+
--- /dev/null
+(* Copyright (C) 2006, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+val debug: bool
+val profiling: bool
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+(** PROFILING *)
+
+let profiling_enabled = ComponentsConf.profiling
+
+let profiling_printings = ref (fun () -> true)
+let set_profiling_printings f = profiling_printings := f
+
+type profiler = { profile : 'a 'b. ('a -> 'b) -> 'a -> 'b }
+let profile ?(enable = true) =
+ if profiling_enabled && enable then
+ function s ->
+ let total = ref 0.0 in
+ let profile f x =
+ let before = Unix.gettimeofday () in
+ try
+ let res = f x in
+ let after = Unix.gettimeofday () in
+ total := !total +. (after -. before);
+ res
+ with
+ exc ->
+ let after = Unix.gettimeofday () in
+ total := !total +. (after -. before);
+ raise exc
+ in
+ at_exit
+ (fun () ->
+ if !profiling_printings () then
+ prerr_endline
+ ("!! TOTAL TIME SPENT IN " ^ s ^ ": " ^ string_of_float !total));
+ { profile = profile }
+ else
+ function _ -> { profile = fun f x -> f x }
+
+(** {2 Optional values} *)
+
+let map_option f = function None -> None | Some v -> Some (f v)
+let iter_option f = function None -> () | Some v -> f v
+let unopt = function None -> failwith "unopt: None" | Some v -> v
+
+(** {2 String processing} *)
+
+let split ?(sep = ' ') s =
+ let pieces = ref [] in
+ let rec aux idx =
+ match (try Some (String.index_from s idx sep) with Not_found -> None) with
+ | Some pos ->
+ pieces := String.sub s idx (pos - idx) :: !pieces;
+ aux (pos + 1)
+ | None -> pieces := String.sub s idx (String.length s - idx) :: !pieces
+ in
+ aux 0;
+ List.rev !pieces
+
+let trim_blanks s =
+ let rec find_left idx =
+ match s.[idx] with
+ | ' ' | '\t' | '\r' | '\n' -> find_left (idx + 1)
+ | _ -> idx
+ in
+ let rec find_right idx =
+ match s.[idx] with
+ | ' ' | '\t' | '\r' | '\n' -> find_right (idx - 1)
+ | _ -> idx
+ in
+ let s_len = String.length s in
+ let left, right = find_left 0, find_right (s_len - 1) in
+ String.sub s left (right - left + 1)
+
+(** {2 Char processing} *)
+
+let is_alpha c =
+ let code = Char.code c in
+ (code >= 65 && code <= 90) || (code >= 97 && code <= 122)
+
+let is_digit c =
+ let code = Char.code c in
+ code >= 48 && code <= 57
+
+let is_blank c =
+ let code = Char.code c in
+ code = 9 || code = 10 || code = 13 || code = 32
+
+let is_alphanum c = is_alpha c || is_digit c
+
+(** {2 List processing} *)
+
+let rec list_uniq ?(eq=(=)) = function
+ | [] -> []
+ | h::[] -> [h]
+ | h1::h2::tl when eq h1 h2 -> list_uniq ~eq (h2 :: tl)
+ | h1::tl (* when h1 <> h2 *) -> h1 :: list_uniq ~eq tl
+
+let rec filter_map f =
+ function
+ | [] -> []
+ | hd :: tl ->
+ (match f hd with
+ | None -> filter_map f tl
+ | Some v -> v :: filter_map f tl)
+
+let list_concat ?(sep = []) =
+ let rec aux acc =
+ function
+ | [] -> []
+ | [ last ] -> List.flatten (List.rev (last :: acc))
+ | hd :: tl -> aux ([sep; hd] @ acc) tl
+ in
+ aux []
+
+let rec list_findopt f l =
+ let rec aux = function
+ | [] -> None
+ | x::tl ->
+ (match f x with
+ | None -> aux tl
+ | Some _ as rc -> rc)
+ in
+ aux l
+
+(** {2 File predicates} *)
+
+let is_dir fname =
+ try
+ (Unix.stat fname).Unix.st_kind = Unix.S_DIR
+ with Unix.Unix_error _ -> false
+
+let is_regular fname =
+ try
+ (Unix.stat fname).Unix.st_kind = Unix.S_REG
+ with Unix.Unix_error _ -> false
+
+let mkdir path =
+ let components = split ~sep:'/' path in
+ let rec aux where = function
+ | [] -> ()
+ | piece::tl ->
+ let path =
+ if where = "" then piece else where ^ "/" ^ piece in
+ (try
+ Unix.mkdir path 0o755
+ with
+ | Unix.Unix_error (Unix.EEXIST,_,_) -> ()
+ | Unix.Unix_error (e,_,_) ->
+ raise
+ (Failure
+ ("Unix.mkdir " ^ path ^ " 0o755 :" ^ (Unix.error_message e))));
+ aux path tl
+ in
+ let where = if path.[0] = '/' then "/" else "" in
+ aux where components
+
+(** {2 Filesystem} *)
+
+let input_file fname =
+ let size = (Unix.stat fname).Unix.st_size in
+ let buf = Buffer.create size in
+ let ic = open_in fname in
+ Buffer.add_channel buf ic size;
+ close_in ic;
+ Buffer.contents buf
+
+let input_all ic =
+ let size = 10240 in
+ let buf = Buffer.create size in
+ let s = String.create size in
+ (try
+ while true do
+ let bytes = input ic s 0 size in
+ if bytes = 0 then raise End_of_file
+ else Buffer.add_substring buf s 0 bytes
+ done
+ with End_of_file -> ());
+ Buffer.contents buf
+
+let output_file ~filename ~text =
+ let oc = open_out filename in
+ output_string oc text;
+ close_out oc
+
+let blank_split s =
+ let len = String.length s in
+ let buf = Buffer.create 0 in
+ let rec aux acc i =
+ if i >= len
+ then begin
+ if Buffer.length buf > 0
+ then List.rev (Buffer.contents buf :: acc)
+ else List.rev acc
+ end else begin
+ if is_blank s.[i] then
+ if Buffer.length buf > 0 then begin
+ let s = Buffer.contents buf in
+ Buffer.clear buf;
+ aux (s :: acc) (i + 1)
+ end else
+ aux acc (i + 1)
+ else begin
+ Buffer.add_char buf s.[i];
+ aux acc (i + 1)
+ end
+ end
+ in
+ aux [] 0
+
+ (* Rules: * "~name" -> home dir of "name"
+ * "~" -> value of $HOME if defined, home dir of the current user otherwise *)
+let tilde_expand s =
+ let get_home login = (Unix.getpwnam login).Unix.pw_dir in
+ let expand_one s =
+ let len = String.length s in
+ if len > 0 && s.[0] = '~' then begin
+ let login_len = ref 1 in
+ while !login_len < len && is_alphanum (s.[!login_len]) do
+ incr login_len
+ done;
+ let login = String.sub s 1 (!login_len - 1) in
+ try
+ let home =
+ if login = "" then
+ try Sys.getenv "HOME" with Not_found -> get_home (Unix.getlogin ())
+ else
+ get_home login
+ in
+ home ^ String.sub s !login_len (len - !login_len)
+ with Not_found | Invalid_argument _ -> s
+ end else
+ s
+ in
+ String.concat " " (List.map expand_one (blank_split s))
+
+let find ?(test = fun _ -> true) path =
+ let rec aux acc todo =
+ match todo with
+ | [] -> acc
+ | path :: tl ->
+ try
+ let handle = Unix.opendir path in
+ let dirs = ref [] in
+ let matching_files = ref [] in
+ (try
+ while true do
+ match Unix.readdir handle with
+ | "." | ".." -> ()
+ | entry ->
+ let qentry = path ^ "/" ^ entry in
+ (try
+ if is_dir qentry then
+ dirs := qentry :: !dirs
+ else if test qentry then
+ matching_files := qentry :: !matching_files;
+ with Unix.Unix_error _ -> ())
+ done
+ with End_of_file -> Unix.closedir handle);
+ aux (!matching_files @ acc) (!dirs @ tl)
+ with Unix.Unix_error _ -> aux acc tl
+ in
+ aux [] [path]
+
+let safe_remove fname = if Sys.file_exists fname then Sys.remove fname
+
+let is_dir_empty d =
+ let od = Unix.opendir d in
+ let rec aux () =
+ let name = Unix.readdir od in
+ if name <> "." && name <> ".." then false else aux () in
+ let res = try aux () with End_of_file -> true in
+ Unix.closedir od;
+ res
+
+let safe_rmdir d = try Unix.rmdir d with Unix.Unix_error _ -> ()
+
+let rec rmdir_descend d =
+ if is_dir_empty d then
+ begin
+ safe_rmdir d;
+ rmdir_descend (Filename.dirname d)
+ end
+
+
+(** {2 Exception handling} *)
+
+let finally at_end f arg =
+ let res =
+ try f arg
+ with exn -> at_end (); raise exn
+ in
+ at_end ();
+ res
+
+(** {2 Localized exceptions } *)
+
+exception Localized of Token.flocation * exn
+
+let loc_of_floc = function
+ | { Lexing.pos_cnum = loc_begin }, { Lexing.pos_cnum = loc_end } ->
+ (loc_begin, loc_end)
+
+let floc_of_loc (loc_begin, loc_end) =
+ let floc_begin =
+ { Lexing.pos_fname = ""; Lexing.pos_lnum = -1; Lexing.pos_bol = -1;
+ Lexing.pos_cnum = loc_begin }
+ in
+ let floc_end = { floc_begin with Lexing.pos_cnum = loc_end } in
+ (floc_begin, floc_end)
+
+let dummy_floc = floc_of_loc (-1, -1)
+
+let raise_localized_exception ~offset floc exn =
+ let (x, y) = loc_of_floc floc in
+ let x = offset + x in
+ let y = offset + y in
+ let flocb,floce = floc in
+ let floc =
+ { flocb with Lexing.pos_cnum = x }, { floce with Lexing.pos_cnum = y }
+ in
+ raise (Localized (floc, exn))
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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))
+ ()
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(*
+ * 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+http_getter_env.cmi: http_getter_types.cmo
+http_getter_common.cmi: http_getter_types.cmo
+http_getter.cmi: http_getter_types.cmo
+http_getter_wget.cmo: http_getter_types.cmo http_getter_wget.cmi
+http_getter_wget.cmx: http_getter_types.cmx http_getter_wget.cmi
+http_getter_logger.cmo: http_getter_logger.cmi
+http_getter_logger.cmx: http_getter_logger.cmi
+http_getter_misc.cmo: http_getter_logger.cmi http_getter_misc.cmi
+http_getter_misc.cmx: http_getter_logger.cmx http_getter_misc.cmi
+http_getter_const.cmo: http_getter_const.cmi
+http_getter_const.cmx: http_getter_const.cmi
+http_getter_env.cmo: http_getter_types.cmo http_getter_misc.cmi \
+ http_getter_logger.cmi http_getter_const.cmi http_getter_env.cmi
+http_getter_env.cmx: http_getter_types.cmx http_getter_misc.cmx \
+ http_getter_logger.cmx http_getter_const.cmx http_getter_env.cmi
+http_getter_storage.cmo: http_getter_wget.cmi http_getter_types.cmo \
+ http_getter_misc.cmi http_getter_env.cmi http_getter_storage.cmi
+http_getter_storage.cmx: http_getter_wget.cmx http_getter_types.cmx \
+ http_getter_misc.cmx http_getter_env.cmx http_getter_storage.cmi
+http_getter_common.cmo: http_getter_types.cmo http_getter_misc.cmi \
+ http_getter_logger.cmi http_getter_env.cmi http_getter_common.cmi
+http_getter_common.cmx: http_getter_types.cmx http_getter_misc.cmx \
+ http_getter_logger.cmx http_getter_env.cmx http_getter_common.cmi
+http_getter.cmo: http_getter_wget.cmi http_getter_types.cmo \
+ http_getter_storage.cmi http_getter_misc.cmi http_getter_logger.cmi \
+ http_getter_env.cmi http_getter_const.cmi http_getter_common.cmi \
+ http_getter.cmi
+http_getter.cmx: http_getter_wget.cmx http_getter_types.cmx \
+ http_getter_storage.cmx http_getter_misc.cmx http_getter_logger.cmx \
+ http_getter_env.cmx http_getter_const.cmx http_getter_common.cmx \
+ http_getter.cmi
--- /dev/null
+#use "topfind";;
+#require "helm-getter";;
+Helm_registry.load_from "sample.conf.xml";;
--- /dev/null
+
+PACKAGE = getter
+
+INTERFACE_FILES = \
+ http_getter_wget.mli \
+ http_getter_logger.mli \
+ http_getter_misc.mli \
+ http_getter_const.mli \
+ http_getter_env.mli \
+ http_getter_storage.mli \
+ http_getter_common.mli \
+ http_getter.mli \
+ $(NULL)
+
+IMPLEMENTATION_FILES = \
+ http_getter_types.ml \
+ $(INTERFACE_FILES:%.mli=%.ml)
+
+include ../../Makefile.defs
+include ../Makefile.common
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 = Http_getter_env.get_dtd_dir () ^ "/" ^ uri in
+ if not (Sys.file_exists fname) then raise (Dtd_not_found uri);
+ fname
+ end
+
+let clean_cache () =
+ if remote () then
+ clean_cache_remote ()
+ else
+ Http_getter_storage.clean_cache ()
+
+let (++) (oldann, oldtypes, oldbody, oldtree)
+ (newann, newtypes, newbody, newtree) =
+ ((if newann > oldann then newann else oldann),
+ (if newtypes > oldtypes then newtypes else oldtypes),
+ (if newbody > oldbody then newbody else oldbody),
+ (if newtree > oldtree then newtree else oldtree))
+
+let store_obj tbl o =
+(* prerr_endline ("Http_getter.store_obj " ^ o); *)
+ if Pcre.pmatch ~rex:showable_file_RE o then begin
+ let basepart = Pcre.replace ~rex:basepart_RE ~templ:"$1" o in
+ let no_flags = false, No, No, No in
+ let oldflags =
+ try
+ Hashtbl.find tbl basepart
+ with Not_found -> (* no ann, no types, no body, no proof tree *)
+ no_flags
+ in
+ let newflags =
+ match o with
+ | s when Pcre.pmatch ~rex:types_RE s -> (false, Yes, No, No)
+ | s when Pcre.pmatch ~rex:types_ann_RE s -> (true, Ann, No, No)
+ | s when Pcre.pmatch ~rex:body_RE s -> (false, No, Yes, No)
+ | s when Pcre.pmatch ~rex:body_ann_RE s -> (true, No, Ann, No)
+ | s when Pcre.pmatch ~rex:proof_tree_RE s -> (false, No, No, Yes)
+ | s when Pcre.pmatch ~rex:proof_tree_ann_RE s -> (true, No, No, Ann)
+ | s -> no_flags
+ in
+ Hashtbl.replace tbl basepart (oldflags ++ newflags)
+ end
+
+let store_dir set_ref d =
+ set_ref := StringSet.add (List.hd (Pcre.split ~rex:slash_RE d)) !set_ref
+
+let collect_ls_items dirs_set objs_tbl =
+ let items = ref [] in
+ StringSet.iter (fun dir -> items := Ls_section dir :: !items) dirs_set;
+ Http_getter_misc.hashtbl_sorted_iter
+ (fun uri (annflag, typesflag, bodyflag, treeflag) ->
+ items :=
+ Ls_object {
+ uri = uri; ann = annflag;
+ types = typesflag; body = bodyflag; proof_tree = treeflag
+ } :: !items)
+ objs_tbl;
+ List.rev !items
+
+let contains_object = (<>) []
+
+ (** non regexp-aware version of ls *)
+let rec dumb_ls uri_prefix =
+(* prerr_endline ("Http_getter.dumb_ls " ^ uri_prefix); *)
+ if is_cic_obj_uri uri_prefix then begin
+ let dirs = ref StringSet.empty in
+ let objs = Hashtbl.create 17 in
+ List.iter
+ (fun fname ->
+ if ends_with_slash fname then
+ store_dir dirs fname
+ else
+ try
+ store_obj objs (strip_suffix ~suffix:xml_suffix fname)
+ with Invalid_argument _ -> ())
+ (Http_getter_storage.ls uri_prefix);
+ collect_ls_items !dirs objs
+ end else if is_theory_uri uri_prefix then begin
+ let items = ref [] in
+ let add_theory fname =
+ items :=
+ Ls_object {
+ uri = fname; ann = false; types = No; body = No; proof_tree = No }
+ :: !items
+ in
+ let cic_uri_prefix =
+ Pcre.replace_first ~rex:heading_theory_RE ~templ:"cic:" uri_prefix
+ in
+ List.iter
+ (fun fname ->
+ if ends_with_slash fname then
+ items := Ls_section (strip_trailing_slash fname) :: !items
+ else
+ try
+ let fname = strip_suffix ~suffix:xml_suffix fname in
+ let theory_name = strip_suffix ~suffix:theory_suffix fname in
+ let sub_theory = normalize_dir cic_uri_prefix ^ theory_name ^ "/" in
+ if is_empty_theory sub_theory then add_theory fname
+ with Invalid_argument _ -> ())
+ (Http_getter_storage.ls uri_prefix);
+ (try
+ if contains_object (dumb_ls cic_uri_prefix)
+ && exists (strip_trailing_slash uri_prefix ^ theory_suffix)
+ then
+ add_theory "index.theory";
+ with Unresolvable_URI _ -> ());
+ !items
+ end else
+ raise (Invalid_URI uri_prefix)
+
+and is_empty_theory uri_prefix =
+(* prerr_endline ("is_empty_theory " ^ uri_prefix); *)
+ not (contains_object (dumb_ls uri_prefix))
+
+ (* handle simple regular expressions of the form "...(..|..|..)..." on cic
+ * uris, not meant to be a real implementation of regexp. The only we use is
+ * "(cic|theory):/..." *)
+let explode_ls_regexp regexp =
+ try
+ let len = String.length regexp in
+ let lparen_idx = String.index regexp '(' in
+ let rparen_idx = String.index_from regexp lparen_idx ')' in
+ let choices_str = (* substring between parens, parens excluded *)
+ String.sub regexp (lparen_idx + 1) (rparen_idx - lparen_idx - 1)
+ in
+ let choices = Pcre.split ~rex:pipe_RE choices_str in
+ let prefix = String.sub regexp 0 lparen_idx in
+ let suffix = String.sub regexp (rparen_idx + 1) (len - (rparen_idx + 1)) in
+ List.map (fun choice -> prefix ^ choice ^ suffix) choices
+ with Not_found -> [regexp]
+
+let merge_results results =
+ let rec aux objects_acc dirs_acc = function
+ | [] -> dirs_acc @ objects_acc
+ | Ls_object _ as obj :: tl -> aux (obj :: objects_acc) dirs_acc tl
+ | Ls_section _ as dir :: tl ->
+ if List.mem dir dirs_acc then (* filters out dir duplicates *)
+ aux objects_acc dirs_acc tl
+ else
+ aux objects_acc (dir :: dirs_acc) tl
+ in
+ aux [] [] (List.concat results)
+
+let ls regexp =
+ if remote () then
+ ls_remote regexp
+ else
+ let prefixes = explode_ls_regexp regexp in
+ merge_results (List.map dumb_ls prefixes)
+
+let getalluris () =
+ let rec aux acc = function
+ | [] -> acc
+ | dir :: todo ->
+ let acc', todo' =
+ List.fold_left
+ (fun (acc, subdirs) result ->
+ match result with
+ | Ls_object obj -> (dir ^ obj.uri) :: acc, subdirs
+ | Ls_section sect -> acc, (dir ^ sect ^ "/") :: subdirs)
+ (acc, todo)
+ (dumb_ls dir)
+ in
+ aux acc' todo'
+ in
+ aux [] ["cic:/"] (* trailing slash required *)
+
+(* Shorthands from now on *)
+
+let getxml' uri = getxml (UriManager.string_of_uri uri)
+let resolve' uri = resolve (UriManager.string_of_uri uri)
+let exists' uri = exists (UriManager.string_of_uri uri)
+
+let tilde_expand_key k =
+ try
+ Helm_registry.set k (HExtlib.tilde_expand (Helm_registry.get k))
+ with Helm_registry.Key_not_found _ -> ()
+
+let init () =
+ List.iter tilde_expand_key ["getter.cache_dir"; "getter.dtd_dir"];
+ Http_getter_logger.set_log_level
+ (Helm_registry.get_opt_default Helm_registry.int ~default:1
+ "getter.log_level");
+ Http_getter_logger.set_log_file
+ (Helm_registry.get_opt Helm_registry.string "getter.log_file")
+
--- /dev/null
+(*
+ * 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
+
--- /dev/null
+(*
+ * 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 (Http_getter_env.get_dtd_dir ())
+ in
+ fun line -> Pcre.replace ~rex ~templ line
+
+let patch_entity = patch_system "ENTITY"
+let patch_doctype = patch_system "DOCTYPE"
+
+let patch_xmlbase =
+ let rex = Pcre.regexp "^(\\s*<\\w[^ ]*)(\\s|>)" in
+ fun xmlbases baseurl baseuri s ->
+ let s' =
+ Pcre.replace ~rex
+ ~templ:(sprintf "$1 xml:base=\"%s\" helm:base=\"%s\"$2" baseurl baseuri)
+ s
+ in
+ if s <> s' then xmlbases := None;
+ s'
+
+let patch_dtd = patch_entity
+let patch_xml ?via_http ?xmlbases () =
+ let xmlbases = ref xmlbases in
+ fun line ->
+ match !xmlbases with
+ | None -> patch_doctype ?via_http () (patch_entity ?via_http () line)
+ | Some (xmlbaseuri, xmlbaseurl) ->
+ patch_xmlbase xmlbases xmlbaseurl xmlbaseuri
+ (patch_doctype ?via_http () (patch_entity ?via_http () line))
+
+let return_file
+ ~fname ?contype ?contenc ?patch_fun ?(gunzip = false) ?(via_http = true)
+ ~enc outchan
+=
+ if via_http then begin
+ let headers =
+ match (contype, contenc) with
+ | (Some t, Some e) -> ["Content-Encoding", e; "Content-Type", t]
+ | (Some t, None) -> ["Content-Type" , t]
+ | (None, Some e) -> ["Content-Encoding", e]
+ | (None, None) -> []
+ in
+ Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
+ Http_daemon.send_headers headers outchan;
+ Http_daemon.send_CRLF outchan
+ end;
+ match gunzip, patch_fun with
+ | true, Some patch_fun ->
+ Http_getter_logger.log ~level:2
+ "Patch required, uncompress/compress cycle needed :-(";
+ (* gunzip needed, uncompress file, apply patch_fun to it, compress the
+ * result and sent it to client *)
+ let (tmp1, tmp2) =
+ (Http_getter_misc.tempfile (), Http_getter_misc.tempfile ())
+ in
+ (try
+ Http_getter_misc.gunzip ~keep:true ~output:tmp1 fname; (* gunzip tmp1 *)
+ let new_file = open_out tmp2 in
+ Http_getter_misc.iter_file (* tmp2 = patch(tmp1) *)
+ (fun line ->
+ output_string new_file (patch_fun line ^ "\n");
+ flush outchan)
+ tmp1;
+ close_out new_file;
+ Http_getter_misc.gzip ~output:tmp1 tmp2;(* tmp1 = gzip(tmp2); rm tmp2 *)
+ Http_getter_misc.iter_file (* send tmp1 to client as is*)
+ (fun line -> output_string outchan (line ^ "\n"); flush outchan)
+ tmp1;
+ Sys.remove tmp1 (* rm tmp1 *)
+ with e ->
+ Sys.remove tmp1;
+ raise e)
+ | false, Some patch_fun ->
+ (match enc with
+ | `Normal ->
+ Http_getter_misc.iter_file
+ (fun line -> output_string outchan (patch_fun (line ^ "\n")))
+ fname
+ | `Gzipped -> assert false)
+ (* dangerous case, if this happens it needs to be investigated *)
+ | _, None -> Http_getter_misc.iter_file_data (output_string outchan) fname
+;;
+
--- /dev/null
+(*
+ * 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
+
--- /dev/null
+(*
+ * 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[&format=(normal|gz)][&patch_dtd=(yes|no)]</kbd></b><br />
+ </p>
+ <p>
+ <b><kbd>resolve?uri=URI</kbd></b><br />
+ </p>
+ <p>
+ <b><kbd>getdtd?uri=URI[&patch_dtd=(yes|no)]</kbd></b><br />
+ </p>
+ <p>
+ <b><kbd>getxslt?uri=URI[&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&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 />
+"
+
--- /dev/null
+(*
+ * 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
+
--- /dev/null
+(*
+ * 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 (
+ match Helm_registry.get_opt Helm_registry.get_string "getter.dtd_dir" with
+ | None -> None
+ | Some dir -> Some (normalize_dir dir))
+let dtd_base_urls = lazy (
+ let rex = Pcre.regexp "/*$" in
+ let raw_urls =
+ match
+ Helm_registry.get_list Helm_registry.string "getter.dtd_base_urls"
+ with
+ | [] -> ["http://helm.cs.unibo.it/dtd"; "http://mowgli.cs.unibo.it/dtd"]
+ | urls -> urls
+ in
+ List.map (Pcre.replace ~rex) raw_urls)
+let port = lazy (
+ Helm_registry.get_opt_default Helm_registry.int ~default:58081 "getter.port")
+
+let parse_prefix_attrs s =
+ List.fold_right
+ (fun s acc ->
+ match s with
+ | "ro" -> `Read_only :: acc
+ | "legacy" -> `Legacy :: acc
+ | s ->
+ Http_getter_logger.log ("ignoring unknown attribute: " ^ s);
+ acc)
+ (Pcre.split s) []
+
+let prefixes = lazy (
+ let prefixes = Helm_registry.get_list Helm_registry.string "getter.prefix" in
+ List.fold_left
+ (fun acc prefix ->
+ let subs = Pcre.extract ~rex:prefix_RE prefix in
+ try
+ (subs.(1), (subs.(2), parse_prefix_attrs subs.(3))) :: acc
+ with Invalid_argument _ ->
+ Http_getter_logger.log ("skipping invalid prefix: " ^ prefix);
+ acc)
+ [] prefixes)
+
+let host = lazy (Http_getter_misc.backtick "hostname -f")
+
+let my_own_url =
+ lazy
+ (let (host, port) = (Lazy.force host, Lazy.force port) in
+ sprintf "http://%s%s" (* without trailing '/' *)
+ host (if port = 80 then "" else (sprintf ":%d" port)))
+
+let env_to_string () =
+ let pp_attr = function `Read_only -> "ro" | `Legacy -> "legacy" in
+ let pp_prefix (uri_prefix, (url_prefix, attrs)) =
+ sprintf " %s -> %s [%s]" uri_prefix url_prefix
+ (String.concat "," (List.map pp_attr attrs)) in
+ let pp_prefixes prefixes =
+ match prefixes with
+ | [] -> ""
+ | l -> "\n" ^ String.concat "\n" (List.map pp_prefix l)
+ in
+ sprintf
+"HTTP Getter %s
+
+prefixes:%s
+dtd_dir:\t%s
+host:\t\t%s
+port:\t\t%d
+my_own_url:\t%s
+dtd_base_urls:\t%s
+log_file:\t%s
+log_level:\t%d
+"
+ version
+ (pp_prefixes (Lazy.force prefixes))
+ (match Lazy.force dtd_dir with Some dir -> dir | None -> "NONE")
+ (Lazy.force host) (Lazy.force port)
+ (Lazy.force my_own_url) (String.concat " " (Lazy.force dtd_base_urls))
+ (match Http_getter_logger.get_log_file () with None -> "None" | Some f -> f)
+ (Http_getter_logger.get_log_level ())
+
+let get_dtd_dir () =
+ match Lazy.force dtd_dir with
+ | None -> raise (Internal_error "dtd_dir is not available")
+ | Some dtd_dir -> dtd_dir
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Http_getter_types
+
+ (** {2 general information} *)
+
+val version : string (* getter version *)
+
+ (** {2 environment gathered data} *)
+ (** all *_dir values are returned with trailing "/" *)
+
+val cache_dir : string lazy_t (* cache root *)
+val dtd_dir : string option lazy_t (* DTDs' root directory *)
+val port : int lazy_t (* port on which getter listens *)
+val dtd_base_urls : string list lazy_t (* base URLs for document patching *)
+val prefixes : (string * (string * prefix_attr list)) list lazy_t
+ (* prefix map uri -> url + attrs *)
+
+ (* {2 derived data} *)
+
+val host : string lazy_t (* host on which getter listens *)
+val my_own_url : string lazy_t (* URL at which contact getter *)
+
+ (* {2 misc} *)
+
+val env_to_string : unit -> string (* dump a textual representation of the
+ current http_getter settings on an output
+ channel *)
+
+val get_dtd_dir : unit -> string
+
--- /dev/null
+(*
+ * 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
+
--- /dev/null
+(*
+ * 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
+
--- /dev/null
+(*
+ * 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
+
--- /dev/null
+(*
+ * 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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)))
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(*
+ * 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 ]
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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
+
--- /dev/null
+#!/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;
+}
--- /dev/null
+<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>
--- /dev/null
+(* $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 -> ())
+
--- /dev/null
+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
--- /dev/null
+PACKAGE = grafite
+PREDICATES =
+
+INTERFACE_FILES = \
+ grafiteAstPp.mli \
+ grafiteMarshal.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = \
+ grafiteAst.ml \
+ $(INTERFACE_FILES:%.mli=%.ml)
+
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2004, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+type direction = [ `LeftToRight | `RightToLeft ]
+
+type loc = Token.flocation
+
+type ('term, 'lazy_term, 'ident) pattern =
+ 'lazy_term option * ('ident * 'term) list * 'term option
+
+type ('term, 'ident) type_spec =
+ | Ident of 'ident
+ | Type of UriManager.uri * int
+
+type 'lazy_term reduction =
+ [ `Demodulate
+ | `Normalize
+ | `Reduce
+ | `Simpl
+ | `Unfold of 'lazy_term option
+ | `Whd ]
+
+type ('term, 'lazy_term, 'reduction, 'ident) tactic =
+ | Absurd of loc * 'term
+ | Apply of loc * 'term
+ | Assumption of loc
+ | Auto of loc * int option * int option * string option * string option
+ (* depth, width, paramodulation, full *) (* ALB *)
+ | Change of loc * ('term, 'lazy_term, 'ident) pattern * 'lazy_term
+ | Clear of loc * 'ident
+ | ClearBody of loc * 'ident
+ | Compare of loc * 'term
+ | Constructor of loc * int
+ | Contradiction of loc
+ | Cut of loc * 'ident option * 'term
+ | DecideEquality of loc
+ | Decompose of loc * ('term, 'ident) type_spec list * 'ident * 'ident list
+ | Discriminate of loc * 'term
+ | Elim of loc * 'term * 'term option * int option * 'ident list
+ | ElimType of loc * 'term * 'term option * int option * 'ident list
+ | Exact of loc * 'term
+ | Exists of loc
+ | Fail of loc
+ | Fold of loc * 'reduction * 'lazy_term * ('term, 'lazy_term, 'ident) pattern
+ | Fourier of loc
+ | FwdSimpl of loc * string * 'ident list
+ | Generalize of loc * ('term, 'lazy_term, 'ident) pattern * 'ident option
+ | Goal of loc * int (* change current goal, argument is goal number 1-based *)
+ | IdTac of loc
+ | Injection of loc * 'term
+ | Intros of loc * int option * 'ident list
+ | Inversion of loc * 'term
+ | LApply of loc * int option * 'term list * 'term * 'ident option
+ | Left of loc
+ | LetIn of loc * 'term * 'ident
+ | Reduce of loc * 'reduction * ('term, 'lazy_term, 'ident) pattern
+ | Reflexivity of loc
+ | Replace of loc * ('term, 'lazy_term, 'ident) pattern * 'lazy_term
+ | Rewrite of loc * direction * 'term *
+ ('term, 'lazy_term, 'ident) pattern
+ | Right of loc
+ | Ring of loc
+ | Split of loc
+ | Symmetry of loc
+ | Transitivity of loc * 'term
+
+type search_kind = [ `Locate | `Hint | `Match | `Elim ]
+
+type print_kind = [ `Env | `Coer ]
+
+type 'term macro =
+ (* Whelp's stuff *)
+ | WHint of loc * 'term
+ | WMatch of loc * 'term
+ | WInstance of loc * 'term
+ | WLocate of loc * string
+ | WElim of loc * 'term
+ (* real macros *)
+(* | Abort of loc *)
+ | Print of loc * string
+ | Check of loc * 'term
+ | Hint of loc
+ | Quit of loc
+(* | Redo of loc * int option
+ | Undo of loc * int option *)
+(* | Print of loc * print_kind *)
+ | Search_pat of loc * search_kind * string (* searches with string pattern *)
+ | Search_term of loc * search_kind * 'term (* searches with term pattern *)
+
+(** To be increased each time the command type below changes, used for "safe"
+ * marshalling *)
+let magic = 5
+
+type 'obj command =
+ | Default of loc * string * UriManager.uri list
+ | Include of loc * string
+ | Set of loc * string * string
+ | Drop of loc
+ | Qed of loc
+ | Coercion of loc * UriManager.uri * bool (* add composites *)
+ | Obj of loc * 'obj
+
+type ('term, 'lazy_term, 'reduction, 'ident) tactical =
+ | Tactic of loc * ('term, 'lazy_term, 'reduction, 'ident) tactic
+ | Do of loc * int * ('term, 'lazy_term, 'reduction, 'ident) tactical
+ | Repeat of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical
+ | Seq of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list
+ (* sequential composition *)
+ | Then of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical *
+ ('term, 'lazy_term, 'reduction, 'ident) tactical list
+ | First of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list
+ (* try a sequence of loc * tactical until one succeeds, fail otherwise *)
+ | Try of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical
+ (* try a tactical and mask failures *)
+ | Solve of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical list
+
+ | Dot of loc
+ | Semicolon of loc
+ | Branch of loc
+ | Shift of loc
+ | Pos of loc * int
+ | Merge of loc
+ | Focus of loc * int list
+ | Unfocus of loc
+ | Skip of loc
+
+let is_punctuation =
+ function
+ | Dot _ | Semicolon _ | Branch _ | Shift _ | Merge _ | Pos _ -> true
+ | _ -> false
+
+type ('term, 'lazy_term, 'reduction, 'obj, 'ident) code =
+ | Command of loc * 'obj command
+ | Macro of loc * 'term macro
+ | Tactical of loc * ('term, 'lazy_term, 'reduction, 'ident) tactical
+ * ('term, 'lazy_term, 'reduction, 'ident) tactical option(* punctuation *)
+
+type ('term, 'lazy_term, 'reduction, 'obj, 'ident) comment =
+ | Note of loc * string
+ | Code of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) code
+
+type ('term, 'lazy_term, 'reduction, 'obj, 'ident) statement =
+ | Executable of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) code
+ | Comment of loc * ('term, 'lazy_term, 'reduction, 'obj, 'ident) comment
--- /dev/null
+(* Copyright (C) 2004, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+open GrafiteAst
+
+let tactical_terminator = ""
+let tactic_terminator = tactical_terminator
+let command_terminator = tactical_terminator
+
+let pp_idents idents = "[" ^ String.concat "; " idents ^ "]"
+
+let pp_reduction_kind ~term_pp = function
+ | `Demodulate -> "demodulate"
+ | `Normalize -> "normalize"
+ | `Reduce -> "reduce"
+ | `Simpl -> "simplify"
+ | `Unfold (Some t) -> "unfold " ^ term_pp t
+ | `Unfold None -> "unfold"
+ | `Whd -> "whd"
+
+let pp_tactic_pattern ~term_pp ~lazy_term_pp (what, hyp, goal) =
+ let what_text =
+ match what with
+ | None -> ""
+ | Some t -> sprintf "in match (%s) " (lazy_term_pp t) in
+ let hyp_text =
+ String.concat " "
+ (List.map (fun (name, p) -> sprintf "%s:(%s)" name (term_pp p)) hyp) in
+ let goal_text =
+ match goal with
+ | None -> ""
+ | Some t -> sprintf "\\vdash (%s)" (term_pp t) in
+ sprintf "%sin %s%s" what_text hyp_text goal_text
+
+let pp_intros_specs = function
+ | None, [] -> ""
+ | Some num, [] -> Printf.sprintf " names %i" num
+ | None, idents -> Printf.sprintf " names %s" (pp_idents idents)
+ | Some num, idents -> Printf.sprintf " names %i %s" num (pp_idents idents)
+
+let terms_pp ~term_pp terms = String.concat ", " (List.map term_pp terms)
+
+let rec pp_tactic ~term_pp ~lazy_term_pp =
+ let pp_reduction_kind = pp_reduction_kind ~term_pp in
+ let pp_tactic_pattern = pp_tactic_pattern ~lazy_term_pp ~term_pp in
+ function
+ | Absurd (_, term) -> "absurd" ^ term_pp term
+ | Apply (_, term) -> "apply " ^ term_pp term
+ | Auto _ -> "auto"
+ | Assumption _ -> "assumption"
+ | Change (_, where, with_what) ->
+ sprintf "change %s with %s" (pp_tactic_pattern where) (lazy_term_pp with_what)
+ | Clear (_,id) -> sprintf "clear %s" id
+ | ClearBody (_,id) -> sprintf "clearbody %s" id
+ | Compare (_,term) -> "compare " ^ term_pp term
+ | Constructor (_,n) -> "constructor " ^ string_of_int n
+ | Contradiction _ -> "contradiction"
+ | Cut (_, ident, term) ->
+ "cut " ^ term_pp term ^
+ (match ident with None -> "" | Some id -> " as " ^ id)
+ | DecideEquality _ -> "decide equality"
+ | Decompose (_, [], what, names) ->
+ sprintf "decompose %s%s" what (pp_intros_specs (None, names))
+ | Decompose (_, types, what, names) ->
+ let to_ident = function
+ | Ident id -> id
+ | Type _ -> assert false
+ in
+ let types = List.rev_map to_ident types in
+ sprintf "decompose %s %s%s" (pp_idents types) what (pp_intros_specs (None, names))
+ | Discriminate (_, term) -> "discriminate " ^ term_pp term
+ | Elim (_, term, using, num, idents) ->
+ sprintf "elim " ^ term_pp term ^
+ (match using with None -> "" | Some term -> " using " ^ term_pp term)
+ ^ pp_intros_specs (num, idents)
+ | ElimType (_, term, using, num, idents) ->
+ sprintf "elim type " ^ term_pp term ^
+ (match using with None -> "" | Some term -> " using " ^ term_pp term)
+ ^ pp_intros_specs (num, idents)
+ | Exact (_, term) -> "exact " ^ term_pp term
+ | Exists _ -> "exists"
+ | Fold (_, kind, term, pattern) ->
+ sprintf "fold %s %s %s" (pp_reduction_kind kind)
+ (lazy_term_pp term) (pp_tactic_pattern pattern)
+ | FwdSimpl (_, hyp, idents) ->
+ sprintf "fwd %s%s" hyp
+ (match idents with [] -> "" | idents -> " " ^ pp_idents idents)
+ | Generalize (_, pattern, ident) ->
+ sprintf "generalize %s%s" (pp_tactic_pattern pattern)
+ (match ident with None -> "" | Some id -> " as " ^ id)
+ | Goal (_, n) -> "goal " ^ string_of_int n
+ | Fail _ -> "fail"
+ | Fourier _ -> "fourier"
+ | IdTac _ -> "id"
+ | Injection (_, term) -> "injection " ^ term_pp term
+ | Intros (_, None, []) -> "intro"
+ | Inversion (_, term) -> "inversion " ^ term_pp term
+ | Intros (_, num, idents) ->
+ sprintf "intros%s%s"
+ (match num with None -> "" | Some num -> " " ^ string_of_int num)
+ (match idents with [] -> "" | idents -> " " ^ pp_idents idents)
+ | LApply (_, level_opt, terms, term, ident_opt) ->
+ sprintf "lapply %s%s%s%s"
+ (match level_opt with None -> "" | Some i -> " depth = " ^ string_of_int i ^ " ")
+ (term_pp term)
+ (match terms with [] -> "" | _ -> " to " ^ terms_pp ~term_pp terms)
+ (match ident_opt with None -> "" | Some ident -> " using " ^ ident)
+ | Left _ -> "left"
+ | LetIn (_, term, ident) -> sprintf "let %s in %s" (term_pp term) ident
+ | Reduce (_, kind, pat) ->
+ sprintf "%s %s" (pp_reduction_kind kind) (pp_tactic_pattern pat)
+ | Reflexivity _ -> "reflexivity"
+ | Replace (_, pattern, t) ->
+ sprintf "replace %s with %s" (pp_tactic_pattern pattern) (lazy_term_pp t)
+ | Rewrite (_, pos, t, pattern) ->
+ sprintf "rewrite %s %s %s"
+ (if pos = `LeftToRight then ">" else "<")
+ (term_pp t)
+ (pp_tactic_pattern pattern)
+ | Right _ -> "right"
+ | Ring _ -> "ring"
+ | Split _ -> "split"
+ | Symmetry _ -> "symmetry"
+ | Transitivity (_, term) -> "transitivity " ^ term_pp term
+
+let pp_search_kind = function
+ | `Locate -> "locate"
+ | `Hint -> "hint"
+ | `Match -> "match"
+ | `Elim -> "elim"
+ | `Instance -> "instance"
+
+let pp_macro ~term_pp = function
+ (* Whelp *)
+ | WInstance (_, term) -> "whelp instance " ^ term_pp term
+ | WHint (_, t) -> "whelp hint " ^ term_pp t
+ | WLocate (_, s) -> "whelp locate " ^ s
+ | WElim (_, t) -> "whelp elim " ^ term_pp t
+ | WMatch (_, term) -> "whelp match " ^ term_pp term
+ (* real macros *)
+ | Check (_, term) -> sprintf "Check %s" (term_pp term)
+ | Hint _ -> "hint"
+ | Search_pat (_, kind, pat) ->
+ sprintf "search %s \"%s\"" (pp_search_kind kind) pat
+ | Search_term (_, kind, term) ->
+ sprintf "search %s %s" (pp_search_kind kind) (term_pp term)
+ | Print (_, name) -> sprintf "Print \"%s\"" name
+ | Quit _ -> "Quit"
+
+let pp_associativity = function
+ | Gramext.LeftA -> "left associative"
+ | Gramext.RightA -> "right associative"
+ | Gramext.NonA -> "non associative"
+
+let pp_precedence i = sprintf "with precedence %d" i
+
+let pp_dir_opt = function
+ | None -> ""
+ | Some `LeftToRight -> "> "
+ | Some `RightToLeft -> "< "
+
+let pp_default what uris =
+ sprintf "default \"%s\" %s" what
+ (String.concat " " (List.map UriManager.string_of_uri uris))
+
+let pp_coercion uri do_composites =
+ sprintf "coercion %s (* %s *)" (UriManager.string_of_uri uri)
+ (if do_composites then "compounds" else "no compounds")
+
+let pp_command ~obj_pp = function
+ | Include (_,path) -> "include " ^ path
+ | Qed _ -> "qed"
+ | Drop _ -> "drop"
+ | Set (_, name, value) -> sprintf "set \"%s\" \"%s\"" name value
+ | Coercion (_, uri, do_composites) -> pp_coercion uri do_composites
+ | Obj (_,obj) -> obj_pp obj
+ | Default (_,what,uris) ->
+ pp_default what uris
+
+let rec pp_tactical ~term_pp ~lazy_term_pp =
+ let pp_tactic = pp_tactic ~lazy_term_pp ~term_pp in
+ let pp_tacticals = pp_tacticals ~lazy_term_pp ~term_pp in
+ function
+ | Tactic (_, tac) -> pp_tactic tac
+ | Do (_, count, tac) ->
+ sprintf "do %d %s" count (pp_tactical ~term_pp ~lazy_term_pp tac)
+ | Repeat (_, tac) -> "repeat " ^ pp_tactical ~term_pp ~lazy_term_pp tac
+ | Seq (_, tacs) -> pp_tacticals ~sep:"; " tacs
+ | Then (_, tac, tacs) ->
+ sprintf "%s; [%s]" (pp_tactical ~term_pp ~lazy_term_pp tac)
+ (pp_tacticals ~sep:" | " tacs)
+ | First (_, tacs) -> sprintf "tries [%s]" (pp_tacticals ~sep:" | " tacs)
+ | Try (_, tac) -> "try " ^ pp_tactical ~term_pp ~lazy_term_pp tac
+ | Solve (_, tac) -> sprintf "solve [%s]" (pp_tacticals ~sep:" | " tac)
+
+ | Dot _ -> "."
+ | Semicolon _ -> ";"
+ | Branch _ -> "["
+ | Shift _ -> "|"
+ | Pos (_, i) -> sprintf "%d:" i
+ | Merge _ -> "]"
+ | Focus (_, goals) ->
+ sprintf "focus %s" (String.concat " " (List.map string_of_int goals))
+ | Unfocus _ -> "unfocus"
+ | Skip _ -> "skip"
+
+and pp_tacticals ~term_pp ~lazy_term_pp ~sep tacs =
+ String.concat sep (List.map (pp_tactical~lazy_term_pp ~term_pp) tacs)
+
+let pp_executable ~term_pp ~lazy_term_pp ~obj_pp =
+ function
+ | Macro (_, macro) -> pp_macro ~term_pp macro
+ | Tactical (_, tac, Some punct) ->
+ pp_tactical ~lazy_term_pp ~term_pp tac
+ ^ pp_tactical ~lazy_term_pp ~term_pp punct
+ | Tactical (_, tac, None) -> pp_tactical ~lazy_term_pp ~term_pp tac
+ | Command (_, cmd) -> pp_command ~obj_pp cmd
+
+let pp_comment ~term_pp ~lazy_term_pp ~obj_pp =
+ function
+ | Note (_,str) -> sprintf "(* %s *)" str
+ | Code (_,code) ->
+ sprintf "(** %s. **)" (pp_executable ~term_pp ~lazy_term_pp ~obj_pp code)
+
+let pp_statement ~term_pp ~lazy_term_pp ~obj_pp =
+ function
+ | Executable (_, ex) -> pp_executable ~lazy_term_pp ~term_pp ~obj_pp ex
+ | Comment (_, c) -> pp_comment ~term_pp ~lazy_term_pp ~obj_pp c
--- /dev/null
+(* 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+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
--- /dev/null
+PACKAGE = grafite_engine
+PREDICATES =
+
+INTERFACE_FILES = \
+ grafiteTypes.mli \
+ grafiteSync.mli \
+ grafiteMisc.mli \
+ grafiteEngine.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+exception Drop
+exception IncludedFileNotCompiled of string (* file name *)
+exception Macro of
+ GrafiteAst.loc *
+ (Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro)
+exception ReadOnlyUri of string
+
+type options = {
+ do_heavy_checks: bool ;
+ clean_baseuri: bool
+}
+
+(** create a ProofEngineTypes.mk_fresh_name_type function which uses given
+ * names as long as they are available, then it fallbacks to name generation
+ * using FreshNamesGenerator module *)
+let namer_of names =
+ let len = List.length names in
+ let count = ref 0 in
+ fun metasenv context name ~typ ->
+ if !count < len then begin
+ let name = Cic.Name (List.nth names !count) in
+ incr count;
+ name
+ end else
+ FreshNamesGenerator.mk_fresh_name ~subst:[] metasenv context name ~typ
+
+let tactic_of_ast ast =
+ let module PET = ProofEngineTypes in
+ match ast with
+ | GrafiteAst.Absurd (_, term) -> Tactics.absurd term
+ | GrafiteAst.Apply (_, term) -> Tactics.apply term
+ | GrafiteAst.Assumption _ -> Tactics.assumption
+ | GrafiteAst.Auto (_,depth,width,paramodulation,full) ->
+ AutoTactic.auto_tac ?depth ?width ?paramodulation ?full
+ ~dbd:(LibraryDb.instance ()) ()
+ | GrafiteAst.Change (_, pattern, with_what) ->
+ Tactics.change ~pattern with_what
+ | GrafiteAst.Clear (_,id) -> Tactics.clear id
+ | GrafiteAst.ClearBody (_,id) -> Tactics.clearbody id
+ | GrafiteAst.Contradiction _ -> Tactics.contradiction
+ | GrafiteAst.Compare (_, term) -> Tactics.compare term
+ | GrafiteAst.Constructor (_, n) -> Tactics.constructor n
+ | GrafiteAst.Cut (_, ident, term) ->
+ let names = match ident with None -> [] | Some id -> [id] in
+ Tactics.cut ~mk_fresh_name_callback:(namer_of names) term
+ | GrafiteAst.DecideEquality _ -> Tactics.decide_equality
+ | GrafiteAst.Decompose (_, types, what, names) ->
+ let to_type = function
+ | GrafiteAst.Type (uri, typeno) -> uri, typeno
+ | GrafiteAst.Ident _ -> assert false
+ in
+ let user_types = List.rev_map to_type types in
+ let dbd = LibraryDb.instance () in
+ let mk_fresh_name_callback = namer_of names in
+ Tactics.decompose ~mk_fresh_name_callback ~dbd ~user_types what
+ | GrafiteAst.Discriminate (_,term) -> Tactics.discriminate term
+ | GrafiteAst.Elim (_, what, using, depth, names) ->
+ Tactics.elim_intros ?using ?depth ~mk_fresh_name_callback:(namer_of names)
+ what
+ | GrafiteAst.ElimType (_, what, using, depth, names) ->
+ Tactics.elim_type ?using ?depth ~mk_fresh_name_callback:(namer_of names)
+ what
+ | GrafiteAst.Exact (_, term) -> Tactics.exact term
+ | GrafiteAst.Exists _ -> Tactics.exists
+ | GrafiteAst.Fail _ -> Tactics.fail
+ | GrafiteAst.Fold (_, reduction_kind, term, pattern) ->
+ let reduction =
+ match reduction_kind with
+ | `Demodulate ->
+ GrafiteTypes.command_error "demodulation can't be folded"
+ | `Normalize ->
+ PET.const_lazy_reduction
+ (CicReduction.normalize ~delta:false ~subst:[])
+ | `Reduce -> PET.const_lazy_reduction ProofEngineReduction.reduce
+ | `Simpl -> PET.const_lazy_reduction ProofEngineReduction.simpl
+ | `Unfold None ->
+ PET.const_lazy_reduction (ProofEngineReduction.unfold ?what:None)
+ | `Unfold (Some lazy_term) ->
+ (fun context metasenv ugraph ->
+ let what, metasenv, ugraph = lazy_term context metasenv ugraph in
+ ProofEngineReduction.unfold ~what, metasenv, ugraph)
+ | `Whd ->
+ PET.const_lazy_reduction (CicReduction.whd ~delta:false ~subst:[])
+ in
+ Tactics.fold ~reduction ~term ~pattern
+ | GrafiteAst.Fourier _ -> Tactics.fourier
+ | GrafiteAst.FwdSimpl (_, hyp, names) ->
+ Tactics.fwd_simpl ~mk_fresh_name_callback:(namer_of names)
+ ~dbd:(LibraryDb.instance ()) hyp
+ | GrafiteAst.Generalize (_,pattern,ident) ->
+ let names = match ident with None -> [] | Some id -> [id] in
+ Tactics.generalize ~mk_fresh_name_callback:(namer_of names) pattern
+ | GrafiteAst.Goal (_, n) -> Tactics.set_goal n
+ | GrafiteAst.IdTac _ -> Tactics.id
+ | GrafiteAst.Injection (_,term) -> Tactics.injection term
+ | GrafiteAst.Intros (_, None, names) ->
+ PrimitiveTactics.intros_tac ~mk_fresh_name_callback:(namer_of names) ()
+ | GrafiteAst.Intros (_, Some num, names) ->
+ PrimitiveTactics.intros_tac ~howmany:num
+ ~mk_fresh_name_callback:(namer_of names) ()
+ | GrafiteAst.Inversion (_, term) ->
+ Tactics.inversion term
+ | GrafiteAst.LApply (_, how_many, to_what, what, ident) ->
+ let names = match ident with None -> [] | Some id -> [id] in
+ Tactics.lapply ~mk_fresh_name_callback:(namer_of names) ?how_many
+ ~to_what what
+ | GrafiteAst.Left _ -> Tactics.left
+ | GrafiteAst.LetIn (loc,term,name) ->
+ Tactics.letin term ~mk_fresh_name_callback:(namer_of [name])
+ | GrafiteAst.Reduce (_, reduction_kind, pattern) ->
+ (match reduction_kind with
+ | `Demodulate -> Tactics.demodulate ~dbd:(LibraryDb.instance ()) ~pattern
+ | `Normalize -> Tactics.normalize ~pattern
+ | `Reduce -> Tactics.reduce ~pattern
+ | `Simpl -> Tactics.simpl ~pattern
+ | `Unfold what -> Tactics.unfold ~pattern what
+ | `Whd -> Tactics.whd ~pattern)
+ | GrafiteAst.Reflexivity _ -> Tactics.reflexivity
+ | GrafiteAst.Replace (_, pattern, with_what) ->
+ Tactics.replace ~pattern ~with_what
+ | GrafiteAst.Rewrite (_, direction, t, pattern) ->
+ EqualityTactics.rewrite_tac ~direction ~pattern t
+ | GrafiteAst.Right _ -> Tactics.right
+ | GrafiteAst.Ring _ -> Tactics.ring
+ | GrafiteAst.Split _ -> Tactics.split
+ | GrafiteAst.Symmetry _ -> Tactics.symmetry
+ | GrafiteAst.Transitivity (_, term) -> Tactics.transitivity term
+
+(* maybe we only need special cases for apply and goal *)
+let classify_tactic tactic =
+ match tactic with
+ (* tactics that can't close the goal (return a goal we want to "select") *)
+ | GrafiteAst.Rewrite _
+ | GrafiteAst.Split _
+ | GrafiteAst.Replace _
+ | GrafiteAst.Reduce _
+ | GrafiteAst.Injection _
+ | GrafiteAst.IdTac _
+ | GrafiteAst.Generalize _
+ | GrafiteAst.Elim _
+ | GrafiteAst.Cut _
+ | GrafiteAst.Decompose _ -> true, true
+ (* tactics we don't want to reorder goals. I think only Goal needs this. *)
+ | GrafiteAst.Goal _ -> false, true
+ (* tactics like apply *)
+ | _ -> true, false
+
+let reorder_metasenv start refine tactic goals current_goal always_opens_a_goal=
+ let module PEH = ProofEngineHelpers in
+(* let print_m name metasenv =
+ prerr_endline (">>>>> " ^ name);
+ prerr_endline (CicMetaSubst.ppmetasenv [] metasenv)
+ in *)
+ (* phase one calculates:
+ * new_goals_from_refine: goals added by refine
+ * head_goal: the first goal opened by ythe tactic
+ * other_goals: other goals opened by the tactic
+ *)
+ let new_goals_from_refine = PEH.compare_metasenvs start refine in
+ let new_goals_from_tactic = PEH.compare_metasenvs refine tactic in
+ let head_goal, other_goals, goals =
+ match goals with
+ | [] -> None,[],goals
+ | hd::tl ->
+ (* assert (List.mem hd new_goals_from_tactic);
+ * invalidato dalla goal_tac
+ * *)
+ Some hd, List.filter ((<>) hd) new_goals_from_tactic, List.filter ((<>)
+ hd) goals
+ in
+ let produced_goals =
+ match head_goal with
+ | None -> new_goals_from_refine @ other_goals
+ | Some x -> x :: new_goals_from_refine @ other_goals
+ in
+ (* extract the metas generated by refine and tactic *)
+ let metas_for_tactic_head =
+ match head_goal with
+ | None -> []
+ | Some head_goal -> List.filter (fun (n,_,_) -> n = head_goal) tactic in
+ let metas_for_tactic_goals =
+ List.map
+ (fun x -> List.find (fun (metano,_,_) -> metano = x) tactic)
+ goals
+ in
+ let metas_for_refine_goals =
+ List.filter (fun (n,_,_) -> List.mem n new_goals_from_refine) tactic in
+ let produced_metas, goals =
+ let produced_metas =
+ if always_opens_a_goal then
+ metas_for_tactic_head @ metas_for_refine_goals @
+ metas_for_tactic_goals
+ else begin
+(* print_m "metas_for_refine_goals" metas_for_refine_goals;
+ print_m "metas_for_tactic_head" metas_for_tactic_head;
+ print_m "metas_for_tactic_goals" metas_for_tactic_goals; *)
+ metas_for_refine_goals @ metas_for_tactic_head @
+ metas_for_tactic_goals
+ end
+ in
+ let goals = List.map (fun (metano, _, _) -> metano) produced_metas in
+ produced_metas, goals
+ in
+ (* residual metas, preserving the original order *)
+ let before, after =
+ let rec split e =
+ function
+ | [] -> [],[]
+ | (metano, _, _) :: tl when metano = e ->
+ [], List.map (fun (x,_,_) -> x) tl
+ | (metano, _, _) :: tl -> let b, a = split e tl in metano :: b, a
+ in
+ let find n metasenv =
+ try
+ Some (List.find (fun (metano, _, _) -> metano = n) metasenv)
+ with Not_found -> None
+ in
+ let extract l =
+ List.fold_right
+ (fun n acc ->
+ match find n tactic with
+ | Some x -> x::acc
+ | None -> acc
+ ) l [] in
+ let before_l, after_l = split current_goal start in
+ let before_l =
+ List.filter (fun x -> not (List.mem x produced_goals)) before_l in
+ let after_l =
+ List.filter (fun x -> not (List.mem x produced_goals)) after_l in
+ let before = extract before_l in
+ let after = extract after_l in
+ before, after
+ in
+(* |+ DEBUG CODE +|
+ print_m "BEGIN" start;
+ prerr_endline ("goal was: " ^ string_of_int current_goal);
+ prerr_endline ("and metas from refine are:");
+ List.iter
+ (fun t -> prerr_string (" " ^ string_of_int t))
+ new_goals_from_refine;
+ prerr_endline "";
+ print_m "before" before;
+ print_m "metas_for_tactic_head" metas_for_tactic_head;
+ print_m "metas_for_refine_goals" metas_for_refine_goals;
+ print_m "metas_for_tactic_goals" metas_for_tactic_goals;
+ print_m "produced_metas" produced_metas;
+ print_m "after" after;
+|+ FINE DEBUG CODE +| *)
+ before @ produced_metas @ after, goals
+
+let apply_tactic ~disambiguate_tactic tactic (status, goal) =
+(* prerr_endline "apply_tactic"; *)
+(* prerr_endline (Continuationals.Stack.pp (GrafiteTypes.get_stack status)); *)
+ let starting_metasenv = GrafiteTypes.get_proof_metasenv status in
+ let before = List.map (fun g, _, _ -> g) starting_metasenv in
+(* prerr_endline "disambiguate"; *)
+ let status, tactic = disambiguate_tactic status goal tactic in
+ let metasenv_after_refinement = GrafiteTypes.get_proof_metasenv status in
+ let proof = GrafiteTypes.get_current_proof status in
+ let proof_status = proof, goal in
+ let needs_reordering, always_opens_a_goal = classify_tactic tactic in
+ let tactic = tactic_of_ast tactic in
+ (* apply tactic will change the lexicon_status ... *)
+(* prerr_endline "apply_tactic bassa"; *)
+ let (proof, opened) = ProofEngineTypes.apply_tactic tactic proof_status in
+ let after = ProofEngineTypes.goals_of_proof proof in
+ let opened_goals, closed_goals = Tacticals.goals_diff ~before ~after ~opened in
+(* prerr_endline("before: " ^ String.concat ", " (List.map string_of_int before));
+prerr_endline("after: " ^ String.concat ", " (List.map string_of_int after));
+prerr_endline("opened: " ^ String.concat ", " (List.map string_of_int opened)); *)
+(* prerr_endline("opened_goals: " ^ String.concat ", " (List.map string_of_int opened_goals));
+prerr_endline("closed_goals: " ^ String.concat ", " (List.map string_of_int closed_goals)); *)
+ let proof, opened_goals =
+ if needs_reordering then begin
+ let uri, metasenv_after_tactic, t, ty = proof in
+(* prerr_endline ("goal prima del riordino: " ^ String.concat " " (List.map string_of_int (ProofEngineTypes.goals_of_proof proof))); *)
+ let reordered_metasenv, opened_goals =
+ reorder_metasenv
+ starting_metasenv
+ metasenv_after_refinement metasenv_after_tactic
+ opened goal always_opens_a_goal
+ in
+ let proof' = uri, reordered_metasenv, t, ty in
+(* prerr_endline ("goal dopo il riordino: " ^ String.concat " " (List.map string_of_int (ProofEngineTypes.goals_of_proof proof'))); *)
+ proof', opened_goals
+ end
+ else
+ proof, opened_goals
+ in
+ let incomplete_proof =
+ match status.GrafiteTypes.proof_status with
+ | GrafiteTypes.Incomplete_proof p -> p
+ | _ -> assert false
+ in
+ { status with GrafiteTypes.proof_status =
+ GrafiteTypes.Incomplete_proof
+ { incomplete_proof with GrafiteTypes.proof = proof } },
+ opened_goals, closed_goals
+
+type eval_ast =
+ {ea_go:
+ 'term 'lazy_term 'reduction 'obj 'ident.
+ disambiguate_tactic:
+ (GrafiteTypes.status ->
+ ProofEngineTypes.goal ->
+ ('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic ->
+ GrafiteTypes.status *
+ (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) ->
+
+ disambiguate_command:
+ (GrafiteTypes.status ->
+ 'obj GrafiteAst.command ->
+ GrafiteTypes.status * Cic.obj GrafiteAst.command) ->
+
+ disambiguate_macro:
+ (GrafiteTypes.status ->
+ 'term GrafiteAst.macro ->
+ Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) ->
+
+ ?do_heavy_checks:bool ->
+ ?clean_baseuri:bool ->
+ GrafiteTypes.status ->
+ ('term, 'lazy_term, 'reduction, 'obj, 'ident) GrafiteAst.statement ->
+ GrafiteTypes.status * UriManager.uri list
+ }
+
+type 'a eval_command =
+ {ec_go: 'term 'obj.
+ disambiguate_command:
+ (GrafiteTypes.status ->
+ 'obj GrafiteAst.command ->
+ GrafiteTypes.status * Cic.obj GrafiteAst.command) ->
+ options -> GrafiteTypes.status -> 'obj GrafiteAst.command ->
+ GrafiteTypes.status * UriManager.uri list
+ }
+
+type 'a eval_executable =
+ {ee_go: 'term 'lazy_term 'reduction 'obj 'ident.
+ disambiguate_tactic:
+ (GrafiteTypes.status ->
+ ProofEngineTypes.goal ->
+ ('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic ->
+ GrafiteTypes.status *
+ (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) ->
+
+ disambiguate_command:
+ (GrafiteTypes.status ->
+ 'obj GrafiteAst.command ->
+ GrafiteTypes.status * Cic.obj GrafiteAst.command) ->
+
+ disambiguate_macro:
+ (GrafiteTypes.status ->
+ 'term GrafiteAst.macro ->
+ Cic.context -> GrafiteTypes.status * Cic.term GrafiteAst.macro) ->
+
+ options ->
+ GrafiteTypes.status ->
+ ('term, 'lazy_term, 'reduction, 'obj, 'ident) GrafiteAst.code ->
+ GrafiteTypes.status * UriManager.uri list
+ }
+
+type 'a eval_from_moo =
+ { efm_go: GrafiteTypes.status -> string -> GrafiteTypes.status }
+
+let coercion_moo_statement_of uri =
+ GrafiteAst.Coercion (HExtlib.dummy_floc, uri, false)
+
+let eval_coercion status ~add_composites uri =
+ let basedir = Helm_registry.get "matita.basedir" in
+ let status,compounds =
+ prerr_endline "evaluating a coercion command";
+ GrafiteSync.add_coercion ~basedir ~add_composites status uri in
+ let moo_content = coercion_moo_statement_of uri in
+ let status = GrafiteTypes.add_moo_content [moo_content] status in
+ {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof},
+ compounds
+
+let eval_tactical ~disambiguate_tactic status tac =
+ let apply_tactic = apply_tactic ~disambiguate_tactic in
+ let module MatitaStatus =
+ struct
+ type input_status = GrafiteTypes.status * ProofEngineTypes.goal
+
+ type output_status =
+ GrafiteTypes.status * ProofEngineTypes.goal list * ProofEngineTypes.goal list
+
+ type tactic = input_status -> output_status
+
+ let id_tactic = apply_tactic (GrafiteAst.IdTac HExtlib.dummy_floc)
+ let mk_tactic tac = tac
+ let apply_tactic tac = tac
+ let goals (_, opened, closed) = opened, closed
+ let set_goals (opened, closed) (status, _, _) = (status, opened, closed)
+ let get_stack (status, _) = GrafiteTypes.get_stack status
+
+ let set_stack stack (status, opened, closed) =
+ GrafiteTypes.set_stack stack status, opened, closed
+
+ let inject (status, _) = (status, [], [])
+ let focus goal (status, _, _) = (status, goal)
+ end
+ in
+ let module MatitaTacticals = Tacticals.Make (MatitaStatus) in
+ let rec tactical_of_ast l tac =
+ match tac with
+ | GrafiteAst.Tactic (loc, tactic) ->
+ MatitaTacticals.tactic (MatitaStatus.mk_tactic (apply_tactic tactic))
+ | GrafiteAst.Seq (loc, tacticals) -> (* tac1; tac2; ... *)
+ assert (l > 0);
+ MatitaTacticals.seq ~tactics:(List.map (tactical_of_ast (l+1)) tacticals)
+ | GrafiteAst.Do (loc, n, tactical) ->
+ MatitaTacticals.do_tactic ~n ~tactic:(tactical_of_ast (l+1) tactical)
+ | GrafiteAst.Repeat (loc, tactical) ->
+ MatitaTacticals.repeat_tactic ~tactic:(tactical_of_ast (l+1) tactical)
+ | GrafiteAst.Then (loc, tactical, tacticals) -> (* tac; [ tac1 | ... ] *)
+ assert (l > 0);
+ MatitaTacticals.thens ~start:(tactical_of_ast (l+1) tactical)
+ ~continuations:(List.map (tactical_of_ast (l+1)) tacticals)
+ | GrafiteAst.First (loc, tacticals) ->
+ MatitaTacticals.first
+ ~tactics:(List.map (fun t -> "", tactical_of_ast (l+1) t) tacticals)
+ | GrafiteAst.Try (loc, tactical) ->
+ MatitaTacticals.try_tactic ~tactic:(tactical_of_ast (l+1) tactical)
+ | GrafiteAst.Solve (loc, tacticals) ->
+ MatitaTacticals.solve_tactics
+ ~tactics:(List.map (fun t -> "", tactical_of_ast (l+1) t) tacticals)
+
+ | GrafiteAst.Skip loc -> MatitaTacticals.skip
+ | GrafiteAst.Dot loc -> MatitaTacticals.dot
+ | GrafiteAst.Semicolon loc -> MatitaTacticals.semicolon
+ | GrafiteAst.Branch loc -> MatitaTacticals.branch
+ | GrafiteAst.Shift loc -> MatitaTacticals.shift
+ | GrafiteAst.Pos (loc, i) -> MatitaTacticals.pos i
+ | GrafiteAst.Merge loc -> MatitaTacticals.merge
+ | GrafiteAst.Focus (loc, goals) -> MatitaTacticals.focus goals
+ | GrafiteAst.Unfocus loc -> MatitaTacticals.unfocus
+ in
+ let status, _, _ = tactical_of_ast 0 tac (status, ~-1) in
+ let status = (* is proof completed? *)
+ match status.GrafiteTypes.proof_status with
+ | GrafiteTypes.Incomplete_proof
+ { GrafiteTypes.stack = stack; proof = proof }
+ when Continuationals.Stack.is_empty stack ->
+ { status with GrafiteTypes.proof_status = GrafiteTypes.Proof proof }
+ | _ -> status
+ in
+ status
+
+let eval_comment status c = status
+
+(* since the record syntax allows to declare coercions, we have to put this
+ * information inside the moo *)
+let add_coercions_of_record_to_moo obj lemmas status =
+ let attributes = CicUtil.attributes_of_obj obj in
+ let is_record = function `Class (`Record att) -> Some att | _-> None in
+ match HExtlib.list_findopt is_record attributes with
+ | None -> status,[]
+ | Some fields ->
+ let is_a_coercion uri =
+ try
+ let obj,_ =
+ CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri in
+ let attrs = CicUtil.attributes_of_obj obj in
+ List.mem (`Class `Projection) attrs
+ with Not_found -> assert false
+ in
+ (* looking at the fields we can know the 'wanted' coercions, but not the
+ * actually generated ones. So, only the intersection between the wanted
+ * and the actual should be in the moo as coercion, while everithing in
+ * lemmas should go as aliases *)
+ let wanted_coercions =
+ HExtlib.filter_map
+ (function
+ | (name,true) ->
+ Some
+ (UriManager.uri_of_string
+ (GrafiteTypes.qualify status name ^ ".con"))
+ | _ -> None)
+ fields
+ in
+ prerr_endline "wanted coercions:";
+ List.iter
+ (fun u -> prerr_endline (UriManager.string_of_uri u))
+ wanted_coercions;
+ let coercions, moo_content =
+ List.split
+ (HExtlib.filter_map
+ (fun uri ->
+ let is_a_wanted_coercion =
+ List.exists (UriManager.eq uri) wanted_coercions in
+ if is_a_coercion uri && is_a_wanted_coercion then
+ Some (uri, coercion_moo_statement_of uri)
+ else
+ None)
+ lemmas)
+ in
+ prerr_endline "actual coercions:";
+ List.iter
+ (fun u -> prerr_endline (UriManager.string_of_uri u))
+ coercions;
+ let status = GrafiteTypes.add_moo_content moo_content status in
+ {status with
+ GrafiteTypes.coercions = coercions @ status.GrafiteTypes.coercions},
+ lemmas
+
+let add_obj uri obj status =
+ let basedir = Helm_registry.get "matita.basedir" in
+ let status,lemmas = GrafiteSync.add_obj ~basedir uri obj status in
+ status, lemmas
+
+let rec eval_command = {ec_go = fun ~disambiguate_command opts status cmd ->
+ let status,cmd = disambiguate_command status cmd in
+ let basedir = Helm_registry.get "matita.basedir" in
+ let status,uris =
+ match cmd with
+ | GrafiteAst.Default (loc, what, uris) as cmd ->
+ LibraryObjects.set_default what uris;
+ GrafiteTypes.add_moo_content [cmd] status,[]
+ | GrafiteAst.Include (loc, baseuri) ->
+ let moopath = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in
+ if not (Sys.file_exists moopath) then
+ raise (IncludedFileNotCompiled moopath);
+ let status = eval_from_moo.efm_go status moopath in
+ status,[]
+ | GrafiteAst.Set (loc, name, value) ->
+ if name = "baseuri" then begin
+ let value =
+ let v = Http_getter_misc.strip_trailing_slash value in
+ try
+ ignore (String.index v ' ');
+ GrafiteTypes.command_error "baseuri can't contain spaces"
+ with Not_found -> v
+ in
+ if Http_getter_storage.is_read_only value then begin
+ HLog.error (sprintf "uri %s belongs to a read-only repository" value);
+ raise (ReadOnlyUri value)
+ end;
+ if not (GrafiteMisc.is_empty value) && opts.clean_baseuri then begin
+ HLog.message ("baseuri " ^ value ^ " is not empty");
+ HLog.message ("cleaning baseuri " ^ value);
+ LibraryClean.clean_baseuris ~basedir [value];
+ end;
+ end;
+ GrafiteTypes.set_option status name value,[]
+ | GrafiteAst.Drop loc -> raise Drop
+ | GrafiteAst.Qed loc ->
+ let uri, metasenv, bo, ty =
+ match status.GrafiteTypes.proof_status with
+ | GrafiteTypes.Proof (Some uri, metasenv, body, ty) ->
+ uri, metasenv, body, ty
+ | GrafiteTypes.Proof (None, metasenv, body, ty) ->
+ raise (GrafiteTypes.Command_error
+ ("Someone allows to start a theorem without giving the "^
+ "name/uri. This should be fixed!"))
+ | _->
+ raise
+ (GrafiteTypes.Command_error "You can't Qed an incomplete theorem")
+ in
+ if metasenv <> [] then
+ raise
+ (GrafiteTypes.Command_error
+ "Proof not completed! metasenv is not empty!");
+ let name = UriManager.name_of_uri uri in
+ let obj = Cic.Constant (name,Some bo,ty,[],[]) in
+ let status, lemmas = add_obj uri obj status in
+ {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof},
+ uri::lemmas
+ | GrafiteAst.Coercion (loc, uri, add_composites) ->
+ eval_coercion status ~add_composites uri
+ | GrafiteAst.Obj (loc,obj) ->
+ let ext,name =
+ match obj with
+ Cic.Constant (name,_,_,_,_)
+ | Cic.CurrentProof (name,_,_,_,_,_) -> ".con",name
+ | Cic.InductiveDefinition (types,_,_,_) ->
+ ".ind",
+ (match types with (name,_,_,_)::_ -> name | _ -> assert false)
+ | _ -> assert false in
+ let uri =
+ UriManager.uri_of_string (GrafiteTypes.qualify status name ^ ext)
+ in
+ let metasenv = GrafiteTypes.get_proof_metasenv status in
+ match obj with
+ | Cic.CurrentProof (_,metasenv',bo,ty,_,_) ->
+ let name = UriManager.name_of_uri uri in
+ if not(CicPp.check name ty) then
+ HLog.error ("Bad name: " ^ name);
+ if opts.do_heavy_checks then
+ begin
+ let dbd = LibraryDb.instance () in
+ let similar = Whelp.match_term ~dbd ty in
+ let similar_len = List.length similar in
+ if similar_len> 30 then
+ (HLog.message
+ ("Duplicate check will compare your theorem with " ^
+ string_of_int similar_len ^
+ " theorems, this may take a while."));
+ let convertible =
+ List.filter (
+ fun u ->
+ let t = CicUtil.term_of_uri u in
+ let ty',g =
+ CicTypeChecker.type_of_aux'
+ metasenv' [] t CicUniv.empty_ugraph
+ in
+ fst(CicReduction.are_convertible [] ty' ty g))
+ similar
+ in
+ (match convertible with
+ | [] -> ()
+ | x::_ ->
+ HLog.warn
+ ("Theorem already proved: " ^ UriManager.string_of_uri x ^
+ "\nPlease use a variant."));
+ end;
+ assert (metasenv = metasenv');
+ let initial_proof = (Some uri, metasenv, bo, ty) in
+ let initial_stack = Continuationals.Stack.of_metasenv metasenv in
+ { status with GrafiteTypes.proof_status =
+ GrafiteTypes.Incomplete_proof
+ { GrafiteTypes.proof = initial_proof; stack = initial_stack } },
+ []
+ | _ ->
+ if metasenv <> [] then
+ raise (GrafiteTypes.Command_error (
+ "metasenv not empty while giving a definition with body: " ^
+ CicMetaSubst.ppmetasenv [] metasenv));
+ let status, lemmas = add_obj uri obj status in
+ let status,new_lemmas =
+ add_coercions_of_record_to_moo obj lemmas status
+ in
+ {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof},
+ uri::new_lemmas@lemmas
+ in
+ match status.GrafiteTypes.proof_status with
+ GrafiteTypes.Intermediate _ ->
+ {status with GrafiteTypes.proof_status = GrafiteTypes.No_proof},uris
+ | _ -> status,uris
+
+} and eval_executable = {ee_go = fun ~disambiguate_tactic ~disambiguate_command ~disambiguate_macro opts status ex ->
+ match ex with
+ | GrafiteAst.Tactical (_, tac, None) ->
+ eval_tactical ~disambiguate_tactic status tac,[]
+ | GrafiteAst.Tactical (_, tac, Some punct) ->
+ let status = eval_tactical ~disambiguate_tactic status tac in
+ eval_tactical ~disambiguate_tactic status punct,[]
+ | GrafiteAst.Command (_, cmd) ->
+ eval_command.ec_go ~disambiguate_command opts status cmd
+ | GrafiteAst.Macro (loc, macro) ->
+ raise (Macro (loc,disambiguate_macro status macro))
+
+} and eval_from_moo = {efm_go = fun status fname ->
+ let ast_of_cmd cmd =
+ GrafiteAst.Executable (HExtlib.dummy_floc,
+ GrafiteAst.Command (HExtlib.dummy_floc,
+ cmd))
+ in
+ let moo = GrafiteMarshal.load_moo fname in
+ List.fold_left
+ (fun status ast ->
+ let ast = ast_of_cmd ast in
+ let status,lemmas =
+ eval_ast.ea_go
+ ~disambiguate_tactic:(fun status _ tactic -> status,tactic)
+ ~disambiguate_command:(fun status cmd -> status,cmd)
+ ~disambiguate_macro:(fun _ _ -> assert false)
+ status ast
+ in
+ assert (lemmas=[]);
+ status)
+ status moo
+} and eval_ast = {ea_go = fun ~disambiguate_tactic ~disambiguate_command ~disambiguate_macro ?(do_heavy_checks=false) ?(clean_baseuri=true) status st
+->
+ let opts = {
+ do_heavy_checks = do_heavy_checks ;
+ clean_baseuri = clean_baseuri }
+ in
+ match st with
+ | GrafiteAst.Executable (_,ex) ->
+ eval_executable.ee_go ~disambiguate_tactic ~disambiguate_command
+ ~disambiguate_macro opts status ex
+ | GrafiteAst.Comment (_,c) -> eval_comment status c,[]
+}
+
+let eval_ast = eval_ast.ea_go
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 ^ "/"))
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 = [];
+ }
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
--- /dev/null
+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
--- /dev/null
+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
+ @echo " OCAMLC $<"
+ @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
+print_grammar: print_grammar.ml $(PACKAGE).cma
+ @echo " OCAMLC $<"
+ @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
+test_dep: test_dep.ml $(PACKAGE).cma
+ @echo " OCAMLC $<"
+ @$(OCAMLC) $(LOCAL_LINKOPTS) -o $@ $<
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+exception BaseUriNotSetYet
+
+let singleton = function
+ | [x], _ -> x
+ | _ -> assert false
+
+ (** @param term not meaningful when context is given *)
+let disambiguate_term lexicon_status_ref context metasenv term =
+ let lexicon_status = !lexicon_status_ref in
+ let (diff, metasenv, cic, _) =
+ singleton
+ (GrafiteDisambiguator.disambiguate_term ~dbd:(LibraryDb.instance ())
+ ~aliases:lexicon_status.LexiconEngine.aliases
+ ~universe:(Some lexicon_status.LexiconEngine.multi_aliases)
+ ~context ~metasenv term)
+ in
+ let lexicon_status = LexiconEngine.set_proof_aliases lexicon_status diff in
+ lexicon_status_ref := lexicon_status;
+ metasenv,cic
+
+ (** disambiguate_lazy_term (circa): term -> (unit -> status) * lazy_term
+ * rationale: lazy_term will be invoked in different context to obtain a term,
+ * each invocation will disambiguate the term and can add aliases. Once all
+ * disambiguations have been performed, the first returned function can be
+ * used to obtain the resulting aliases *)
+let disambiguate_lazy_term lexicon_status_ref term =
+ (fun context metasenv ugraph ->
+ let lexicon_status = !lexicon_status_ref in
+ let (diff, metasenv, cic, ugraph) =
+ singleton
+ (GrafiteDisambiguator.disambiguate_term ~dbd:(LibraryDb.instance ())
+ ~initial_ugraph:ugraph ~aliases:lexicon_status.LexiconEngine.aliases
+ ~universe:(Some lexicon_status.LexiconEngine.multi_aliases)
+ ~context ~metasenv
+ term) in
+ let lexicon_status = LexiconEngine.set_proof_aliases lexicon_status diff in
+ lexicon_status_ref := lexicon_status;
+ cic, metasenv, ugraph)
+
+let disambiguate_pattern lexicon_status_ref (wanted, hyp_paths, goal_path) =
+ let interp path = Disambiguate.interpretate_path [] path in
+ let goal_path = HExtlib.map_option interp goal_path in
+ let hyp_paths = List.map (fun (name, path) -> name, interp path) hyp_paths in
+ let wanted =
+ match wanted with
+ None -> None
+ | Some wanted ->
+ let wanted = disambiguate_lazy_term lexicon_status_ref wanted in
+ Some wanted
+ in
+ (wanted, hyp_paths, goal_path)
+
+let disambiguate_reduction_kind lexicon_status_ref = function
+ | `Unfold (Some t) ->
+ let t = disambiguate_lazy_term lexicon_status_ref t in
+ `Unfold (Some t)
+ | `Demodulate
+ | `Normalize
+ | `Reduce
+ | `Simpl
+ | `Unfold None
+ | `Whd as kind -> kind
+
+let disambiguate_tactic lexicon_status_ref context metasenv tactic =
+ let disambiguate_term = disambiguate_term lexicon_status_ref in
+ let disambiguate_pattern = disambiguate_pattern lexicon_status_ref in
+ let disambiguate_reduction_kind = disambiguate_reduction_kind lexicon_status_ref in
+ let disambiguate_lazy_term = disambiguate_lazy_term lexicon_status_ref in
+ match tactic with
+ | GrafiteAst.Absurd (loc, term) ->
+ let metasenv,cic = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.Absurd (loc, cic)
+ | GrafiteAst.Apply (loc, term) ->
+ let metasenv,cic = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.Apply (loc, cic)
+ | GrafiteAst.Assumption loc ->
+ metasenv,GrafiteAst.Assumption loc
+ | GrafiteAst.Auto (loc,depth,width,paramodulation,full) ->
+ metasenv,GrafiteAst.Auto (loc,depth,width,paramodulation,full)
+ | GrafiteAst.Change (loc, pattern, with_what) ->
+ let with_what = disambiguate_lazy_term with_what in
+ let pattern = disambiguate_pattern pattern in
+ metasenv,GrafiteAst.Change (loc, pattern, with_what)
+ | GrafiteAst.Clear (loc,id) ->
+ metasenv,GrafiteAst.Clear (loc,id)
+ | GrafiteAst.ClearBody (loc,id) ->
+ metasenv,GrafiteAst.ClearBody (loc,id)
+ | GrafiteAst.Compare (loc,term) ->
+ let metasenv,term = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.Compare (loc,term)
+ | GrafiteAst.Constructor (loc,n) ->
+ metasenv,GrafiteAst.Constructor (loc,n)
+ | GrafiteAst.Contradiction loc ->
+ metasenv,GrafiteAst.Contradiction loc
+ | GrafiteAst.Cut (loc, ident, term) ->
+ let metasenv,cic = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.Cut (loc, ident, cic)
+ | GrafiteAst.DecideEquality loc ->
+ metasenv,GrafiteAst.DecideEquality loc
+ | GrafiteAst.Decompose (loc, types, what, names) ->
+ let disambiguate (metasenv,types) = function
+ | GrafiteAst.Type _ -> assert false
+ | GrafiteAst.Ident id ->
+ (match
+ disambiguate_term context metasenv
+ (CicNotationPt.Ident(id, None))
+ with
+ | metasenv,Cic.MutInd (uri, tyno, _) ->
+ metasenv,(GrafiteAst.Type (uri, tyno) :: types)
+ | _ ->
+ raise (GrafiteDisambiguator.DisambiguationError
+ (0,[[None,lazy "Decompose works only on inductive types"]])))
+ in
+ let metasenv,types =
+ List.fold_left disambiguate (metasenv,[]) types
+ in
+ metasenv,GrafiteAst.Decompose (loc, types, what, names)
+ | GrafiteAst.Discriminate (loc,term) ->
+ let metasenv,term = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.Discriminate(loc,term)
+ | GrafiteAst.Exact (loc, term) ->
+ let metasenv,cic = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.Exact (loc, cic)
+ | GrafiteAst.Elim (loc, what, Some using, depth, idents) ->
+ let metasenv,what = disambiguate_term context metasenv what in
+ let metasenv,using = disambiguate_term context metasenv using in
+ metasenv,GrafiteAst.Elim (loc, what, Some using, depth, idents)
+ | GrafiteAst.Elim (loc, what, None, depth, idents) ->
+ let metasenv,what = disambiguate_term context metasenv what in
+ metasenv,GrafiteAst.Elim (loc, what, None, depth, idents)
+ | GrafiteAst.ElimType (loc, what, Some using, depth, idents) ->
+ let metasenv,what = disambiguate_term context metasenv what in
+ let metasenv,using = disambiguate_term context metasenv using in
+ metasenv,GrafiteAst.ElimType (loc, what, Some using, depth, idents)
+ | GrafiteAst.ElimType (loc, what, None, depth, idents) ->
+ let metasenv,what = disambiguate_term context metasenv what in
+ metasenv,GrafiteAst.ElimType (loc, what, None, depth, idents)
+ | GrafiteAst.Exists loc ->
+ metasenv,GrafiteAst.Exists loc
+ | GrafiteAst.Fail loc ->
+ metasenv,GrafiteAst.Fail loc
+ | GrafiteAst.Fold (loc,red_kind, term, pattern) ->
+ let pattern = disambiguate_pattern pattern in
+ let term = disambiguate_lazy_term term in
+ let red_kind = disambiguate_reduction_kind red_kind in
+ metasenv,GrafiteAst.Fold (loc, red_kind, term, pattern)
+ | GrafiteAst.FwdSimpl (loc, hyp, names) ->
+ metasenv,GrafiteAst.FwdSimpl (loc, hyp, names)
+ | GrafiteAst.Fourier loc ->
+ metasenv,GrafiteAst.Fourier loc
+ | GrafiteAst.Generalize (loc,pattern,ident) ->
+ let pattern = disambiguate_pattern pattern in
+ metasenv,GrafiteAst.Generalize (loc,pattern,ident)
+ | GrafiteAst.Goal (loc, g) ->
+ metasenv,GrafiteAst.Goal (loc, g)
+ | GrafiteAst.IdTac loc ->
+ metasenv,GrafiteAst.IdTac loc
+ | GrafiteAst.Injection (loc, term) ->
+ let metasenv,term = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.Injection (loc,term)
+ | GrafiteAst.Intros (loc, num, names) ->
+ metasenv,GrafiteAst.Intros (loc, num, names)
+ | GrafiteAst.Inversion (loc, term) ->
+ let metasenv,term = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.Inversion (loc, term)
+ | GrafiteAst.LApply (loc, depth, to_what, what, ident) ->
+ let f term to_what =
+ let metasenv,term = disambiguate_term context metasenv term in
+ term :: to_what
+ in
+ let to_what = List.fold_right f to_what [] in
+ let metasenv,what = disambiguate_term context metasenv what in
+ metasenv,GrafiteAst.LApply (loc, depth, to_what, what, ident)
+ | GrafiteAst.Left loc ->
+ metasenv,GrafiteAst.Left loc
+ | GrafiteAst.LetIn (loc, term, name) ->
+ let metasenv,term = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.LetIn (loc,term,name)
+ | GrafiteAst.Reduce (loc, red_kind, pattern) ->
+ let pattern = disambiguate_pattern pattern in
+ let red_kind = disambiguate_reduction_kind red_kind in
+ metasenv,GrafiteAst.Reduce(loc, red_kind, pattern)
+ | GrafiteAst.Reflexivity loc ->
+ metasenv,GrafiteAst.Reflexivity loc
+ | GrafiteAst.Replace (loc, pattern, with_what) ->
+ let pattern = disambiguate_pattern pattern in
+ let with_what = disambiguate_lazy_term with_what in
+ metasenv,GrafiteAst.Replace (loc, pattern, with_what)
+ | GrafiteAst.Rewrite (loc, dir, t, pattern) ->
+ let metasenv,term = disambiguate_term context metasenv t in
+ let pattern = disambiguate_pattern pattern in
+ metasenv,GrafiteAst.Rewrite (loc, dir, term, pattern)
+ | GrafiteAst.Right loc ->
+ metasenv,GrafiteAst.Right loc
+ | GrafiteAst.Ring loc ->
+ metasenv,GrafiteAst.Ring loc
+ | GrafiteAst.Split loc ->
+ metasenv,GrafiteAst.Split loc
+ | GrafiteAst.Symmetry loc ->
+ metasenv,GrafiteAst.Symmetry loc
+ | GrafiteAst.Transitivity (loc, term) ->
+ let metasenv,cic = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.Transitivity (loc, cic)
+
+let disambiguate_obj lexicon_status ~baseuri metasenv obj =
+ let uri =
+ match obj with
+ | CicNotationPt.Inductive (_,(name,_,_,_)::_)
+ | CicNotationPt.Record (_,name,_,_) ->
+ (match baseuri with
+ | Some baseuri ->
+ Some (UriManager.uri_of_string (baseuri ^ "/" ^ name ^ ".ind"))
+ | None -> raise BaseUriNotSetYet)
+ | CicNotationPt.Inductive _ -> assert false
+ | CicNotationPt.Theorem _ -> None in
+ let (diff, metasenv, cic, _) =
+ singleton
+ (GrafiteDisambiguator.disambiguate_obj ~dbd:(LibraryDb.instance ())
+ ~aliases:lexicon_status.LexiconEngine.aliases
+ ~universe:(Some lexicon_status.LexiconEngine.multi_aliases) ~uri obj) in
+ let lexicon_status = LexiconEngine.set_proof_aliases lexicon_status diff in
+ lexicon_status, metasenv, cic
+
+let disambiguate_command lexicon_status ~baseuri metasenv =
+ function
+ | GrafiteAst.Coercion _
+ | GrafiteAst.Default _
+ | GrafiteAst.Drop _
+ | GrafiteAst.Include _
+ | GrafiteAst.Qed _
+ | GrafiteAst.Set _ as cmd ->
+ lexicon_status,metasenv,cmd
+ | GrafiteAst.Obj (loc,obj) ->
+ let lexicon_status,metasenv,obj =
+ disambiguate_obj lexicon_status ~baseuri metasenv obj in
+ lexicon_status, metasenv, GrafiteAst.Obj (loc,obj)
+
+let disambiguate_macro lexicon_status_ref metasenv context macro =
+ let disambiguate_term = disambiguate_term lexicon_status_ref in
+ match macro with
+ | GrafiteAst.WMatch (loc,term) ->
+ let metasenv,term = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.WMatch (loc,term)
+ | GrafiteAst.WInstance (loc,term) ->
+ let metasenv,term = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.WInstance (loc,term)
+ | GrafiteAst.WElim (loc,term) ->
+ let metasenv,term = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.WElim (loc,term)
+ | GrafiteAst.WHint (loc,term) ->
+ let metasenv,term = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.WHint (loc,term)
+ | GrafiteAst.Check (loc,term) ->
+ let metasenv,term = disambiguate_term context metasenv term in
+ metasenv,GrafiteAst.Check (loc,term)
+ | GrafiteAst.Hint _
+ | GrafiteAst.WLocate _ as macro ->
+ metasenv,macro
+ | GrafiteAst.Quit _
+ | GrafiteAst.Print _
+ | GrafiteAst.Search_pat _
+ | GrafiteAst.Search_term _ -> assert false
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+exception Ambiguous_input
+(* the integer is an offset to be added to each location *)
+exception DisambiguationError of
+ int * (Token.flocation option * string Lazy.t) list list
+ (** parameters are: option name, error message *)
+exception Unbound_identifier of string
+
+type choose_uris_callback =
+ id:string -> UriManager.uri list -> UriManager.uri list
+
+type choose_interp_callback = (string * string) list list -> int list
+
+let mono_uris_callback ~id =
+ if Helm_registry.get_opt_default Helm_registry.get_bool ~default:true
+ "matita.auto_disambiguation"
+ then
+ function l -> l
+ else
+ raise Ambiguous_input
+
+let mono_interp_callback _ = raise Ambiguous_input
+
+let _choose_uris_callback = ref mono_uris_callback
+let _choose_interp_callback = ref mono_interp_callback
+let set_choose_uris_callback f = _choose_uris_callback := f
+let set_choose_interp_callback f = _choose_interp_callback := f
+
+module Callbacks =
+ struct
+ let interactive_user_uri_choice ~selection_mode ?ok
+ ?(enable_button_for_non_vars = true) ~title ~msg ~id uris =
+ !_choose_uris_callback ~id uris
+
+ let interactive_interpretation_choice interp =
+ !_choose_interp_callback interp
+
+ let input_or_locate_uri ~(title:string) ?id =
+ (* Zack: I try to avoid using this callback. I therefore assume that
+ * the presence of an identifier that can't be resolved via "locate"
+ * query is a syntax error *)
+ let msg = match id with Some id -> id | _ -> "_" in
+ raise (Unbound_identifier msg)
+ end
+
+module Disambiguator = Disambiguate.Make (Callbacks)
+
+(* implement module's API *)
+
+let disambiguate_thing ~aliases ~universe
+ ~(f:?fresh_instances:bool ->
+ aliases:DisambiguateTypes.environment ->
+ universe:DisambiguateTypes.multiple_environment option ->
+ 'a -> 'b)
+ ~(drop_aliases: 'b -> 'b)
+ ~(drop_aliases_and_clear_diff: 'b -> 'b)
+ (thing: 'a)
+=
+ assert (universe <> None);
+ let library = false, DisambiguateTypes.Environment.empty, None in
+ let multi_aliases = false, DisambiguateTypes.Environment.empty, universe in
+ let mono_aliases = true, aliases, Some DisambiguateTypes.Environment.empty in
+ let passes = (* <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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+module Ast = CicNotationPt
+
+type 'a localized_option =
+ LSome of 'a
+ | LNone of Token.flocation
+
+type statement =
+ include_paths:string list ->
+ LexiconEngine.status ->
+ LexiconEngine.status *
+ (CicNotationPt.term, CicNotationPt.term,
+ CicNotationPt.term GrafiteAst.reduction, CicNotationPt.obj, string)
+ GrafiteAst.statement localized_option
+
+let grammar = CicNotationParser.level2_ast_grammar
+
+let term = CicNotationParser.term
+let statement = Grammar.Entry.create grammar "statement"
+
+let add_raw_attribute ~text t = Ast.AttributedTerm (`Raw text, t)
+
+let default_precedence = 50
+let default_associativity = Gramext.NonA
+
+EXTEND
+ GLOBAL: term statement;
+ arg: [
+ [ LPAREN; names = LIST1 IDENT SEP SYMBOL ",";
+ SYMBOL ":"; ty = term; RPAREN -> names,ty
+ | name = IDENT -> [name],Ast.Implicit
+ ]
+ ];
+ constructor: [ [ name = IDENT; SYMBOL ":"; typ = term -> (name, typ) ] ];
+ tactic_term: [ [ t = term LEVEL "90N" -> t ] ];
+ ident_list0: [ [ LPAREN; idents = LIST0 IDENT; RPAREN -> idents ] ];
+ tactic_term_list1: [
+ [ tactic_terms = LIST1 tactic_term SEP SYMBOL "," -> tactic_terms ]
+ ];
+ reduction_kind: [
+ [ IDENT "demodulate" -> `Demodulate
+ | IDENT "normalize" -> `Normalize
+ | IDENT "reduce" -> `Reduce
+ | IDENT "simplify" -> `Simpl
+ | IDENT "unfold"; t = OPT term -> `Unfold t
+ | IDENT "whd" -> `Whd ]
+ ];
+ sequent_pattern_spec: [
+ [ hyp_paths =
+ LIST0
+ [ id = IDENT ;
+ path = OPT [SYMBOL ":" ; path = tactic_term -> path ] ->
+ (id,match path with Some p -> p | None -> Ast.UserInput) ];
+ goal_path = OPT [ SYMBOL <:unicode<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)))
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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] []
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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)
+
--- /dev/null
+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
--- /dev/null
+
+# Targets description:
+# all (default) -> builds hbugs bytecode library hbugs.cma
+# opt -> builds hbugs native library hbugs.cmxa
+# daemons -> builds hbugs broker and tutors executables
+#
+# start -> starts up broker and tutors
+# stop -> stop broker and tutors
+#
+# broker -> builds broker executable
+# tutors -> builds tutors executables
+# client -> builds hbugs client
+
+PACKAGE = hbugs
+
+IMPLEMENTATION_FILES = \
+ hbugs_misc.ml \
+ hbugs_common.ml \
+ hbugs_id_generator.ml \
+ hbugs_messages.ml \
+ hbugs_client_gui.ml \
+ hbugs_client.ml
+INTERFACE_FILES = \
+ hbugs_types.mli \
+ $(patsubst %.ml, %.mli, $(IMPLEMENTATION_FILES))
+
+include ../../Makefile.defs
+include ../Makefile.common
+include .tutors.ml
+include .generated_tutors.ml
+
+.tutors.ml:
+ echo -n "TUTORS_ML = " > $@
+ scripts/ls_tutors.ml | xargs >> $@
+.generated_tutors.ml:
+ echo -n "GENERATED_TUTORS_ML = " > $@
+ scripts/ls_tutors.ml -auto | xargs >> $@
+
+TUTORS = $(patsubst %.ml, %, $(TUTORS_ML))
+TUTORS_OPT = $(patsubst %, %.opt, $(TUTORS))
+GENERATED_TUTORS = $(patsubst %.ml, %, $(GENERATED_TUTORS_ML))
+
+hbugs_client_gui.ml hbugs_client_gui.mli: hbugs_client_gui.glade
+ lablgladecc2 $< > hbugs_client_gui.ml
+ $(OCAMLC) -i hbugs_client_gui.ml > hbugs_client_gui.mli
+
+clean: clean_mains
+.PHONY: clean_mains
+clean_mains:
+ rm -f $(TUTORS) $(TUTORS_OPT) broker{,.opt} client{,.opt}
+distclean: clean
+ rm -f $(GENERATED_TUTORS_ML) hbugs_client_gui.ml{,i}
+ rm -f .tutors.ml .generated_tutors.ml
+
+MAINS_DEPS = \
+ hbugs_misc.cmo \
+ hbugs_messages.cmo \
+ hbugs_id_generator.cmo
+TUTOR_DEPS = $(MAINS_DEPS) \
+ hbugs_tutors.cmo
+BROKER_DEPS = $(MAINS_DEPS) \
+ hbugs_broker_registry.cmo
+CLIENT_DEPS = $(MAINS_DEPS) \
+ hbugs_client_gui.cmo \
+ hbugs_common.cmo \
+ hbugs_client.cmo
+TUTOR_DEPS_OPT = $(patsubst %.cmo, %.cmx, $(TUTOR_DEPS))
+BROKER_DEPS_OPT = $(patsubst %.cmo, %.cmx, $(BROKER_DEPS))
+CLIENT_DEPS_OPT = $(patsubst %.cmo, %.cmx, $(CLIENT_DEPS))
+$(GENERATED_TUTORS_ML): scripts/build_tutors.ml data/tutors_index.xml data/hbugs_tutor.TPL.ml
+ scripts/build_tutors.ml
+hbugs_tutors.cmo: hbugs_tutors.cmi
+hbugs_broker_registry.cmo: hbugs_broker_registry.cmi
+.PHONY: daemons
+daemons: tutors broker
+.PHONY: tutors
+tutors: all $(TUTORS)
+%_tutor: $(TUTOR_DEPS) %_tutor.ml
+ $(OCAMLC) -linkpkg -o $@ $^
+%_tutor.opt: $(TUTOR_DEPS_OPT) %_tutor.ml
+ $(OCAMLOPT) -linkpkg -o $@ $^
+broker: $(BROKER_DEPS) broker.ml
+ $(OCAMLC) -linkpkg -o $@ $^
+broker.opt: $(BROKER_DEPS_OPT) broker.ml
+ $(OCAMLOPT) -linkpkg -o $@ $^
+client: $(CLIENT_DEPS) client.ml
+ $(OCAMLC) -linkpkg -o $@ $^
+client.opt: $(CLIENT_DEPS_OPT) client.ml
+ $(OCAMLOPT) -linkpkg -o $@ $^
+
+.PHONY: start stop
+start:
+ scripts/brokerctl.sh start
+ scripts/sabba.sh start
+stop:
+ scripts/brokerctl.sh stop
+ scripts/sabba.sh stop
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $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 ()
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+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 () ;;
+
--- /dev/null
+<!--
+ 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>
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Hbugs_types;;
+
+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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $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
+;;
+
--- /dev/null
+
+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
+
--- /dev/null
+<?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>
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $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)
+;;
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Hbugs_types;;
+
+val string_of_hint: hint -> string
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Hbugs_types;;
+
+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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $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));;
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Hbugs_types;;
+
+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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $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)
+;;
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+ (** 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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Hbugs_types;;
+
+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
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+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 *)
+
--- /dev/null
+#!/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
--- /dev/null
+#!/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 ()
+
--- /dev/null
+#!/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 ()
+
--- /dev/null
+#!/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
--- /dev/null
+(* $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 ()
+
--- /dev/null
+<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>
--- /dev/null
+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
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open 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"
+;;
+
--- /dev/null
+domMisc.cmo: domMisc.cmi
+domMisc.cmx: domMisc.cmi
+xml2Gdome.cmo: xml2Gdome.cmi
+xml2Gdome.cmx: xml2Gdome.cmi
--- /dev/null
+PACKAGE = hgdome
+
+# modules which have both a .ml and a .mli
+INTERFACE_FILES = \
+ domMisc.mli \
+ xml2Gdome.mli \
+ $(NULL)
+
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 06/01/2002 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+(* $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"
+
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 15/01/2003 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+val domImpl : Gdome.domImplementation
+
+val 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 *)
+
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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
+;;
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val document_of_xml :
+ Gdome.domImplementation -> Xml.token Stream.t -> Gdome.document
--- /dev/null
+hMysql.cmo: hMysql.cmi
+hMysql.cmx: hMysql.cmi
--- /dev/null
+PACKAGE = hmysql
+PREDICATES =
+
+INTERFACE_FILES = \
+ hMysql.mli
+IMPLEMENTATION_FILES = \
+ $(INTERFACE_FILES:%.mli=%.ml)
+EXTRA_OBJECTS_TO_INSTALL =
+EXTRA_OBJECTS_TO_CLEAN =
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+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
--- /dev/null
+PACKAGE = lexicon
+PREDICATES =
+
+INTERFACE_FILES = \
+ lexiconAstPp.mli \
+ disambiguatePp.mli \
+ lexiconMarshal.mli \
+ cicNotation.mli \
+ lexiconEngine.mli \
+ lexiconSync.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = \
+ lexiconAst.ml \
+ $(INTERFACE_FILES:%.mli=%.ml)
+
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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)
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+exception IncludedFileNotCompiled of string
+
+type status = {
+ aliases: DisambiguateTypes.environment; (** disambiguation aliases *)
+ multi_aliases: DisambiguateTypes.multiple_environment;
+ lexicon_content_rev: LexiconMarshal.lexicon;
+ notation_ids: CicNotation.notation_id list; (** in-scope notation ids *)
+ metadata: LibraryNoDb.metadata list;
+}
+
+val eval_command : status -> LexiconAst.command -> status
+
+val set_proof_aliases:
+ status ->
+ (DisambiguateTypes.Environment.key * DisambiguateTypes.codomain_item) list ->
+ status
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 = [];
+ }
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+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
--- /dev/null
+PACKAGE = library
+PREDICATES =
+
+INTERFACE_FILES = \
+ cicElim.mli \
+ cicRecord.mli \
+ libraryMisc.mli \
+ libraryDb.mli \
+ coercDb.mli \
+ cicCoercion.mli \
+ coercGraph.mli \
+ librarySync.mli \
+ libraryNoDb.mli \
+ libraryClean.mli \
+ $(NULL)
+IMPLEMENTATION_FILES = \
+ $(INTERFACE_FILES:%.mli=%.ml)
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+;;
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* 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))
+
--- /dev/null
+(* 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+type coerc_carr = Uri of UriManager.uri | Sort of Cic.sort | Term of Cic.term
+exception EqCarrNotImplemented of string Lazy.t
+exception EqCarrOnNonMetaClosed
+
+let db = ref []
+
+let coerc_carr_of_term t =
+ try
+ Uri (CicUtil.uri_of_term t)
+ with Invalid_argument _ ->
+ match t with
+ | Cic.Sort s -> Sort s
+ | Cic.Appl ((Cic.Const (uri, _))::_)
+ | Cic.Appl ((Cic.MutInd (uri, _, _))::_)
+ | Cic.Appl ((Cic.MutConstruct (uri, _, _, _))::_) -> Uri uri
+ | t -> Term t
+;;
+
+let name_of_carr = function
+ | Uri u -> UriManager.name_of_uri u
+ | Sort s -> CicPp.ppsort s
+ | Term (Cic.Appl ((Cic.Const (uri, _))::_))
+ | Term (Cic.Appl ((Cic.MutInd (uri, _, _))::_))
+ | Term (Cic.Appl ((Cic.MutConstruct (uri, _, _, _))::_)) ->
+ UriManager.name_of_uri uri
+ | Term t -> (* CicPp.ppterm t *) assert false
+
+let eq_carr src tgt =
+ match src, tgt with
+ | Uri src, Uri tgt -> UriManager.eq src tgt
+ | Sort (Cic.Type _), Sort (Cic.Type _) -> true
+ | Sort src, Sort tgt when src = tgt -> true
+ | Term t1, Term t2 ->
+ if CicUtil.is_meta_closed t1 && CicUtil.is_meta_closed t2 then
+ raise
+ (EqCarrNotImplemented
+ (lazy ("Unsupported carr for coercions: " ^
+ CicPp.ppterm t1 ^ " or " ^ CicPp.ppterm t2)))
+ else raise EqCarrOnNonMetaClosed
+ | _, _ -> false
+
+let to_list () =
+ !db
+
+let add_coercion c =
+ db := c :: !db
+
+let remove_coercion p =
+ db := List.filter (fun u -> not(p u)) !db
+
+let find_coercion f =
+ List.map (fun (_,_,x) -> x) (List.filter (fun (s,t,_) -> f (s,t)) !db)
+
+let is_a_coercion u =
+ List.exists (fun (_,_,x) -> UriManager.eq x u) !db
+
+let get_carr uri =
+ try
+ let src, tgt, _ = List.find (fun (_,_,x) -> UriManager.eq x uri) !db in
+ src, tgt
+ with Not_found -> assert false (* uri must be a coercion *)
+
+let term_of_carr = function
+ | Uri u -> CicUtil.term_of_uri u
+ | Sort s -> Cic.Sort s
+ | Term _ -> assert false
+
+
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+
+ (** 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
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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 *)
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+open Printf ;;
+
+let instance =
+ let dbd = lazy (
+ HMysql.quick_connect
+ ~host:(Helm_registry.get "db.host")
+ ~user:(Helm_registry.get "db.user")
+ ~database:(Helm_registry.get "db.database")
+ ())
+ in
+ fun () -> Lazy.force dbd
+
+
+let xpointer_RE = Pcre.regexp "#.*$"
+let file_scheme_RE = Pcre.regexp "^file://"
+
+let clean_owner_environment () =
+ let dbd = instance () in
+ let obj_tbl = MetadataTypes.obj_tbl () in
+ let sort_tbl = MetadataTypes.sort_tbl () in
+ let rel_tbl = MetadataTypes.rel_tbl () in
+ let name_tbl = MetadataTypes.name_tbl () in
+ let count_tbl = MetadataTypes.count_tbl () in
+ let tbls = [
+ (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ;
+ (name_tbl,`ObjectName) ; (count_tbl,`Count) ]
+ in
+ let statements =
+ (SqlStatements.drop_tables tbls) @ (SqlStatements.drop_indexes tbls)
+ in
+ let owned_uris =
+ try
+ MetadataDb.clean ~dbd
+ with Mysql.Error _ as exn ->
+ match HMysql.errno dbd with
+ | Mysql.No_such_table -> []
+ | _ -> raise exn
+ in
+ List.iter
+ (fun uri ->
+ let uri = Pcre.replace ~rex:xpointer_RE ~templ:"" uri in
+ List.iter
+ (fun suffix ->
+ try
+ HExtlib.safe_remove (Http_getter.resolve (uri ^ suffix))
+ with Http_getter_types.Key_not_found _ -> ())
+ [""; ".body"; ".types"])
+ owned_uris;
+ List.iter (fun statement ->
+ try
+ ignore (HMysql.exec dbd statement)
+ with Mysql.Error _ as exn ->
+ match HMysql.errno dbd with
+ | Mysql.Bad_table_error
+ | Mysql.No_such_index | Mysql.No_such_table -> ()
+ | _ -> raise exn
+ ) statements;
+;;
+
+let create_owner_environment () =
+ let dbd = instance () in
+ let obj_tbl = MetadataTypes.obj_tbl () in
+ let sort_tbl = MetadataTypes.sort_tbl () in
+ let rel_tbl = MetadataTypes.rel_tbl () in
+ let name_tbl = MetadataTypes.name_tbl () in
+ let count_tbl = MetadataTypes.count_tbl () in
+ let tbls = [
+ (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ;
+ (name_tbl,`ObjectName) ; (count_tbl,`Count) ]
+ in
+ let statements =
+ (SqlStatements.create_tables tbls) @ (SqlStatements.create_indexes tbls)
+ in
+ List.iter (fun statement ->
+ try
+ ignore (HMysql.exec dbd statement)
+ with
+ exn ->
+ let status = HMysql.status dbd in
+ match status with
+ | Mysql.StatusError Mysql.Table_exists_error -> ()
+ | Mysql.StatusError Mysql.Dup_keyname -> ()
+ | Mysql.StatusError _ -> raise exn
+ | _ -> ()
+ ) statements
+;;
+
+(* removes uri from the ownerized tables, and returns the list of other objects
+ * (theyr uris) that ref the one removed.
+ * AFAIK there is no need to return it, since the MatitaTypes.staus should
+ * contain all defined objects. but to double check we do not garbage the
+ * metadata...
+ *)
+let remove_uri uri =
+ let obj_tbl = MetadataTypes.obj_tbl () in
+ let sort_tbl = MetadataTypes.sort_tbl () in
+ let rel_tbl = MetadataTypes.rel_tbl () in
+ let name_tbl = MetadataTypes.name_tbl () in
+ (*let conclno_tbl = MetadataTypes.conclno_tbl () in
+ let conclno_hyp_tbl = MetadataTypes.fullno_tbl () in*)
+ let count_tbl = MetadataTypes.count_tbl () in
+
+ let dbd = instance () in
+ let suri = UriManager.string_of_uri uri in
+ let query table suri = sprintf
+ "DELETE FROM %s WHERE source LIKE '%s%%'" table (HMysql.escape suri)
+ in
+ List.iter (fun t ->
+ try
+ ignore (HMysql.exec dbd (query t suri))
+ with
+ exn -> raise exn (* no errors should be accepted *)
+ )
+ [obj_tbl;sort_tbl;rel_tbl;name_tbl;(*conclno_tbl;conclno_hyp_tbl*)count_tbl];
+ (* and now the debug job *)
+ let dbg_q =
+ sprintf "SELECT source FROM %s WHERE h_occurrence LIKE '%s%%'" obj_tbl
+ (HMysql.escape suri)
+ in
+ try
+ let rc = HMysql.exec dbd dbg_q in
+ let l = ref [] in
+ HMysql.iter rc (fun a -> match a.(0) with None ->()|Some a -> l := a:: !l);
+ let l = List.sort Pervasives.compare !l in
+ HExtlib.list_uniq l
+ with
+ exn -> raise exn (* no errors should be accepted *)
+
+let xpointers_of_ind uri =
+ let dbd = instance () in
+ let name_tbl = MetadataTypes.name_tbl () in
+ let query = sprintf
+ "SELECT source FROM %s WHERE source LIKE '%s#xpointer%%'" name_tbl
+ (HMysql.escape (UriManager.string_of_uri uri))
+ in
+ let rc = HMysql.exec dbd query in
+ let l = ref [] in
+ HMysql.iter rc (fun a -> match a.(0) with None ->()|Some a -> l := a:: !l);
+ List.map UriManager.uri_of_string !l
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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"
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+exception AlreadyDefined of UriManager.uri
+
+let auxiliary_lemmas_hashtbl = UriManager.UriHashtbl.create 29
+
+(* uri |--> (derived_coercions_in_the_coercion_DB, derived_coercions_in_lib)
+ *
+ * in case of remove_coercion uri, the first component is removed from the
+ * coercion DB, while the second is passed to remove_obj (and is not [] only if
+ * add_coercion is called with add_composites
+ * *)
+let coercion_hashtbl = UriManager.UriHashtbl.create 3
+
+let rec merge_coercions =
+ let module C = Cic in
+ let aux = (fun (u,t) -> u,merge_coercions t) in
+ function
+ C.Rel _ | C.Sort _ | C.Implicit _ as t -> t
+ | C.Meta (n,subst) ->
+ let subst' =
+ List.map
+ (function None -> None | Some t -> Some (merge_coercions t)) subst
+ in
+ C.Meta (n,subst')
+ | C.Cast (te,ty) -> C.Cast (merge_coercions te, merge_coercions ty)
+ | C.Prod (name,so,dest) ->
+ C.Prod (name, merge_coercions so, merge_coercions dest)
+ | C.Lambda (name,so,dest) ->
+ C.Lambda (name, merge_coercions so, merge_coercions dest)
+ | C.LetIn (name,so,dest) ->
+ C.LetIn (name, merge_coercions so, merge_coercions dest)
+ | Cic.Appl [ c1 ; (Cic.Appl [c2; head]) ] when
+ CoercGraph.is_a_coercion c1 && CoercGraph.is_a_coercion c2 ->
+ let source_carr = CoercGraph.source_of c2 in
+ let tgt_carr = CoercGraph.target_of c1 in
+ (match CoercGraph.look_for_coercion source_carr tgt_carr
+ with
+ | CoercGraph.SomeCoercion c -> Cic.Appl [ c ; head ]
+ | _ -> assert false) (* the composite coercion must exist *)
+ | C.Appl l -> C.Appl (List.map merge_coercions l)
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst = List.map aux exp_named_subst in
+ C.Var (uri, exp_named_subst)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst = List.map aux exp_named_subst in
+ C.Const (uri, exp_named_subst)
+ | C.MutInd (uri,tyno,exp_named_subst) ->
+ let exp_named_subst = List.map aux exp_named_subst in
+ C.MutInd (uri,tyno,exp_named_subst)
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ let exp_named_subst = List.map aux exp_named_subst in
+ C.MutConstruct (uri,tyno,consno,exp_named_subst)
+ | C.MutCase (uri,tyno,out,te,pl) ->
+ let pl = List.map merge_coercions pl in
+ C.MutCase (uri,tyno,merge_coercions out,merge_coercions te,pl)
+ | C.Fix (fno, fl) ->
+ let fl = List.map (fun (name,idx,ty,bo)->(name,idx,merge_coercions ty,merge_coercions bo)) fl in
+ C.Fix (fno, fl)
+ | C.CoFix (fno, fl) ->
+ let fl = List.map (fun (name,ty,bo) -> (name, merge_coercions ty, merge_coercions bo)) fl in
+ C.CoFix (fno, fl)
+
+let merge_coercions_in_obj obj =
+ let module C = Cic in
+ match obj with
+ | C.Constant (id, body, ty, params, attrs) ->
+ let body =
+ match body with
+ | None -> None
+ | Some body -> Some (merge_coercions body)
+ in
+ let ty = merge_coercions ty in
+ C.Constant (id, body, ty, params, attrs)
+ | C.Variable (name, body, ty, params, attrs) ->
+ let body =
+ match body with
+ | None -> None
+ | Some body -> Some (merge_coercions body)
+ in
+ let ty = merge_coercions ty in
+ C.Variable (name, body, ty, params, attrs)
+ | C.CurrentProof (_name, _conjectures, _body, _ty, _params, _attrs) ->
+ assert false
+ | C.InductiveDefinition (indtys, params, leftno, attrs) ->
+ let indtys =
+ List.map
+ (fun (name, ind, arity, cl) ->
+ let arity = merge_coercions arity in
+ let cl = List.map (fun (name, ty) -> (name,merge_coercions ty)) cl in
+ (name, ind, arity, cl))
+ indtys
+ in
+ C.InductiveDefinition (indtys, params, leftno, attrs)
+
+let uris_of_obj uri =
+ let innertypesuri = UriManager.innertypesuri_of_uri uri in
+ let bodyuri = UriManager.bodyuri_of_uri uri in
+ let univgraphuri = UriManager.univgraphuri_of_uri uri in
+ innertypesuri,bodyuri,univgraphuri
+
+let paths_and_uris_of_obj uri ~basedir =
+ let basedir = basedir ^ "/xml" in
+ let innertypesuri, bodyuri, univgraphuri = uris_of_obj uri in
+ let innertypesfilename = Str.replace_first (Str.regexp "^cic:") ""
+ (UriManager.string_of_uri innertypesuri) ^ ".xml.gz" in
+ let innertypespath = basedir ^ "/" ^ innertypesfilename in
+ let xmlfilename = Str.replace_first (Str.regexp "^cic:/") ""
+ (UriManager.string_of_uri uri) ^ ".xml.gz" in
+ let xmlpath = basedir ^ "/" ^ xmlfilename in
+ let xmlbodyfilename = Str.replace_first (Str.regexp "^cic:/") ""
+ (UriManager.string_of_uri uri) ^ ".body.xml.gz" in
+ let xmlbodypath = basedir ^ "/" ^ xmlbodyfilename in
+ let xmlunivgraphfilename = Str.replace_first (Str.regexp "^cic:/") ""
+ (UriManager.string_of_uri univgraphuri) ^ ".xml.gz" in
+ let xmlunivgraphpath = basedir ^ "/" ^ xmlunivgraphfilename in
+ xmlpath, xmlbodypath, innertypespath, bodyuri, innertypesuri,
+ xmlunivgraphpath, univgraphuri
+
+let save_object_to_disk ~basedir uri obj ugraph univlist =
+ let ensure_path_exists path =
+ let dir = Filename.dirname path in
+ HExtlib.mkdir dir
+ in
+ (* generate annobj, ids_to_inner_sorts and ids_to_inner_types *)
+ let annobj = Cic2acic.plain_acic_object_of_cic_object obj in
+ (* prepare XML *)
+ let xml, bodyxml =
+ Cic2Xml.print_object
+ uri ?ids_to_inner_sorts:None ~ask_dtd_to_the_getter:false annobj
+ in
+ let xmlpath, xmlbodypath, innertypespath, bodyuri, innertypesuri,
+ xmlunivgraphpath, univgraphuri =
+ paths_and_uris_of_obj uri basedir
+ in
+ List.iter HExtlib.mkdir (List.map Filename.dirname [xmlpath]);
+ (* now write to disk *)
+ ensure_path_exists xmlpath;
+ Xml.pp ~gzip:true xml (Some xmlpath);
+ CicUniv.write_xml_of_ugraph xmlunivgraphpath ugraph univlist;
+ (* we return a list of uri,path we registered/created *)
+ (uri,xmlpath) ::
+ (univgraphuri,xmlunivgraphpath) ::
+ (* now the optional body, both write and register *)
+ (match bodyxml,bodyuri with
+ None,None -> []
+ | Some bodyxml,Some bodyuri->
+ ensure_path_exists xmlbodypath;
+ Xml.pp ~gzip:true bodyxml (Some xmlbodypath);
+ [bodyuri, xmlbodypath]
+ | _-> assert false)
+
+
+let typecheck_obj =
+ let profiler = HExtlib.profile "add_obj.typecheck_obj" in
+ fun uri obj -> profiler.HExtlib.profile (CicTypeChecker.typecheck_obj uri) obj
+
+let index_obj =
+ let profiler = HExtlib.profile "add_obj.index_obj" in
+ fun ~dbd ~uri ->
+ profiler.HExtlib.profile (fun uri -> MetadataDb.index_obj ~dbd ~uri) uri
+
+let add_single_obj uri obj ~basedir =
+ let obj =
+ if (*List.mem `Generated (CicUtil.attributes_of_obj obj) &&*)
+ not (CoercGraph.is_a_coercion (Cic.Const (uri, [])))
+ then
+ merge_coercions_in_obj obj
+ else
+ obj
+ in
+ let dbd = LibraryDb.instance () in
+ if CicEnvironment.in_library uri then
+ raise (AlreadyDefined uri)
+ else begin
+ (*CicUniv.reset_spent_time ();
+ let before = Unix.gettimeofday () in*)
+ typecheck_obj uri obj; (* 1 *)
+ (*let after = Unix.gettimeofday () in
+ let univ_time = CicUniv.get_spent_time () in
+ let total_time = after -. before in
+ prerr_endline
+ (Printf.sprintf "QED: %%univ = %2.5f, total = %2.5f, univ = %2.5f, %s\n"
+ (univ_time *. 100. /. total_time) (total_time) (univ_time)
+ (UriManager.name_of_uri uri));*)
+ let _, ugraph, univlist =
+ CicEnvironment.get_cooked_obj_with_univlist CicUniv.empty_ugraph uri in
+ try
+ index_obj ~dbd ~uri; (* 2 must be in the env *)
+ try
+ (*3*)
+ let new_stuff = save_object_to_disk ~basedir uri obj ugraph univlist in
+ try
+ HLog.message
+ (Printf.sprintf "%s defined" (UriManager.string_of_uri uri))
+ with exc ->
+ List.iter HExtlib.safe_remove (List.map snd new_stuff); (* -3 *)
+ raise exc
+ with exc ->
+ ignore(LibraryDb.remove_uri uri); (* -2 *)
+ raise exc
+ with exc ->
+ CicEnvironment.remove_obj uri; (* -1 *)
+ raise exc
+ end
+
+let remove_single_obj uri =
+ let derived_uris_of_uri uri =
+ let innertypesuri, bodyuri, univgraphuri = uris_of_obj uri in
+ innertypesuri::univgraphuri::(match bodyuri with None -> [] | Some u -> [u])
+ in
+ let to_remove =
+ uri ::
+ (if UriManager.uri_is_ind uri then LibraryDb.xpointers_of_ind uri else []) @
+ derived_uris_of_uri uri
+ in
+ List.iter
+ (fun uri ->
+ (try
+ let file = Http_getter.resolve' uri in
+ HExtlib.safe_remove file;
+ HExtlib.rmdir_descend (Filename.dirname file)
+ with Http_getter_types.Key_not_found _ -> ());
+ ignore (LibraryDb.remove_uri uri);
+ (*CoercGraph.remove_coercion uri;*)
+ CicEnvironment.remove_obj uri)
+ to_remove
+
+(*** GENERATION OF AUXILIARY LEMMAS ***)
+
+let generate_elimination_principles ~basedir uri =
+ let uris = ref [] in
+ let elim sort =
+ try
+ let uri,obj = CicElim.elim_of ~sort uri 0 in
+ add_single_obj uri obj ~basedir;
+ uris := uri :: !uris
+ with CicElim.Can_t_eliminate -> ()
+ in
+ try
+ List.iter elim [ Cic.Prop; Cic.Set; (Cic.Type (CicUniv.fresh ())) ];
+ !uris
+ with exn ->
+ List.iter remove_single_obj !uris;
+ raise exn
+
+(* COERCIONS ***********************************************************)
+
+let remove_all_coercions () =
+ UriManager.UriHashtbl.clear coercion_hashtbl;
+ CoercDb.remove_coercion (fun (_,_,u1) -> true)
+
+let add_coercion ~basedir ~add_composites uri =
+ let coer_ty,_ =
+ let coer = CicUtil.term_of_uri uri in
+ CicTypeChecker.type_of_aux' [] [] coer CicUniv.empty_ugraph
+ in
+ (* we have to get the source and the tgt type uri
+ * in Coq syntax we have already their names, but
+ * since we don't support Funclass and similar I think
+ * all the coercion should be of the form
+ * (A:?)(B:?)T1->T2
+ * So we should be able to extract them from the coercion type
+ *
+ * Currently only (_:T1)T2 is supported.
+ * should we saturate it with metas in case we insert it?
+ *
+ *)
+ let extract_last_two_p ty =
+ let rec aux = function
+ | Cic.Prod( _, src, Cic.Prod (n,t1,t2)) ->
+ assert false
+ (* not implemented: aux (Cic.Prod(n,t1,t2)) *)
+ | Cic.Prod( _, src, tgt) -> src, tgt
+ | _ -> assert false
+ in
+ aux ty
+ in
+ let ty_src, ty_tgt = extract_last_two_p coer_ty in
+ let src_uri = CoercDb.coerc_carr_of_term (CicReduction.whd [] ty_src) in
+ let tgt_uri = CoercDb.coerc_carr_of_term (CicReduction.whd [] ty_tgt) in
+ let new_coercions = CicCoercion.close_coercion_graph src_uri tgt_uri uri in
+ let composite_uris = List.map (fun (_,_,uri,_) -> uri) new_coercions in
+ (* update the DB *)
+ List.iter
+ (fun (src,tgt,uri,_) -> CoercDb.add_coercion (src,tgt,uri))
+ new_coercions;
+ CoercDb.add_coercion (src_uri, tgt_uri, uri);
+ (* add the composites obj and they eventual lemmas *)
+ let lemmas =
+ if add_composites then
+ List.fold_left
+ (fun acc (_,_,uri,obj) ->
+ add_single_obj ~basedir uri obj;
+ uri::acc)
+ composite_uris new_coercions
+ else
+ []
+ in
+ (* store that composite_uris are related to uri. the first component is the
+ * stuff in the DB while the second is stuff for remove_obj *)
+ prerr_endline ("aggiungo: " ^ string_of_bool add_composites ^ UriManager.string_of_uri uri);
+ List.iter (fun u -> prerr_endline (UriManager.string_of_uri u))
+ composite_uris;
+ UriManager.UriHashtbl.add coercion_hashtbl uri
+ (composite_uris,if add_composites then composite_uris else []);
+ lemmas
+
+let remove_coercion uri =
+ try
+ let (composites_in_db, composites_in_lib) =
+ UriManager.UriHashtbl.find coercion_hashtbl uri
+ in
+ prerr_endline ("removing: " ^UriManager.string_of_uri uri);
+ List.iter (fun u -> prerr_endline (UriManager.string_of_uri u))
+ composites_in_db;
+ UriManager.UriHashtbl.remove coercion_hashtbl uri;
+ CoercDb.remove_coercion (fun (_,_,u) -> UriManager.eq uri u);
+ (* remove from the DB *)
+ List.iter
+ (fun u -> CoercDb.remove_coercion (fun (_,_,u1) -> UriManager.eq u u1))
+ composites_in_db;
+ (* remove composites from the lib *)
+ List.iter remove_single_obj composites_in_lib
+ with
+ Not_found -> () (* mhh..... *)
+
+
+let generate_projections ~basedir uri fields =
+ let uris = ref [] in
+ let projections = CicRecord.projections_of uri (List.map fst fields) in
+ try
+ List.iter2
+ (fun (uri, name, bo) (_name, coercion) ->
+ try
+ let ty, ugraph =
+ CicTypeChecker.type_of_aux' [] [] bo CicUniv.empty_ugraph in
+ let attrs = [`Class `Projection; `Generated] in
+ let obj = Cic.Constant (name,Some bo,ty,[],attrs) in
+ add_single_obj ~basedir uri obj;
+ let composites =
+ if coercion then
+ add_coercion ~basedir ~add_composites:true uri
+ else
+ []
+ in
+ uris := uri :: composites @ !uris
+ with
+ CicTypeChecker.TypeCheckerFailure s ->
+ HLog.message
+ ("Unable to create projection " ^ name ^ " cause: " ^ Lazy.force s);
+ | CicEnvironment.Object_not_found uri ->
+ let depend = UriManager.name_of_uri uri in
+ HLog.message
+ ("Unable to create projection " ^ name ^ " because it requires " ^
+ depend)
+ ) projections fields;
+ !uris
+ with exn ->
+ List.iter remove_single_obj !uris;
+ raise exn
+
+
+let add_obj uri obj ~basedir =
+ add_single_obj uri obj ~basedir;
+ let uris = ref [] in
+ try
+ begin
+ match obj with
+ | Cic.Constant _ -> ()
+ | Cic.InductiveDefinition (_,_,_,attrs) ->
+ uris := !uris @ generate_elimination_principles ~basedir uri;
+ let rec get_record_attrs =
+ function
+ | [] -> None
+ | (`Class (`Record fields))::_ -> Some fields
+ | _::tl -> get_record_attrs tl
+ in
+ (match get_record_attrs attrs with
+ | None -> () (* not a record *)
+ | Some fields ->
+ uris := !uris @ (generate_projections ~basedir uri fields))
+ | Cic.CurrentProof _
+ | Cic.Variable _ -> assert false
+ end;
+ UriManager.UriHashtbl.add auxiliary_lemmas_hashtbl uri !uris;
+ !uris
+ with exn ->
+ List.iter remove_single_obj !uris;
+ raise exn
+
+let remove_obj uri =
+ let uris =
+ try
+ let res = UriManager.UriHashtbl.find auxiliary_lemmas_hashtbl uri in
+ UriManager.UriHashtbl.remove auxiliary_lemmas_hashtbl uri;
+ res
+ with
+ Not_found -> [] (*assert false*)
+ in
+ List.iter remove_single_obj (uri::uris)
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+exception AlreadyDefined of UriManager.uri
+
+val merge_coercions: Cic.term -> Cic.term
+
+(* adds an object to the library together with all auxiliary lemmas on it *)
+(* (e.g. elimination principles, projections, etc.) *)
+(* it returns the list of the uris of the auxiliary lemmas generated *)
+val add_obj: UriManager.uri -> Cic.obj -> basedir:string -> UriManager.uri list
+
+(* inverse of add_obj; *)
+(* Warning: it does not remove the dependencies on the object and on its *)
+(* auxiliary lemmas! *)
+val remove_obj: UriManager.uri -> unit
+
+(* Informs the library that [uri] is a coercion. *)
+(* This can generate some composite coercions that, if [add_composites] *)
+(* is true are added to the library. *)
+(* The list of added objects is returned. *)
+val add_coercion:
+ basedir:string -> add_composites:bool -> UriManager.uri ->
+ UriManager.uri list
+
+(* inverse of add_coercion, removes both the eventually created composite *)
+(* coercions and the information that [uri] and the composites are coercion *)
+val remove_coercion: UriManager.uri -> unit
+
+(* mh... *)
+val remove_all_coercions: unit -> unit
+
--- /dev/null
+(* 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/
+ *)
+
--- /dev/null
+helmLogger.cmo: helmLogger.cmi
+helmLogger.cmx: helmLogger.cmi
--- /dev/null
+
+PACKAGE = logger
+INTERFACE_FILES = \
+ helmLogger.mli
+IMPLEMENTATION_FILES = \
+ $(INTERFACE_FILES:%.mli=%.ml)
+
+include ../../Makefile.defs
+include ../Makefile.common
+
--- /dev/null
+(* $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
+
--- /dev/null
+
+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
+
--- /dev/null
+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
--- /dev/null
+PACKAGE = metadata
+PREDICATES =
+
+INTERFACE_FILES = \
+ sqlStatements.mli \
+ metadataTypes.mli \
+ metadataExtractor.mli \
+ metadataPp.mli \
+ metadataConstraints.mli \
+ metadataDb.mli
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+EXTRA_OBJECTS_TO_INSTALL =
+EXTRA_OBJECTS_TO_CLEAN =
+
+include ../../Makefile.defs
+include ../Makefile.common
+
+all: all_table_creator all_extractor
+opt: opt_table_creator opt_extractor
+
+all_table_creator:
+ @make -C table_creator/ all
+opt_table_creator:
+ @make -C table_creator/ opt
+
+all_extractor:
+ @make -C extractor/ all
+opt_extractor:
+ @make -C extractor/ opt
+
+clean: clean_table_creator clean_extractor
+
+clean_table_creator:
+ @echo " cleaning: table_creator"
+ @make -C table_creator/ clean
+
+clean_extractor:
+ @echo " cleaning: extractor"
+ @make -C extractor/ clean
+
--- /dev/null
+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
--- /dev/null
+
+all: extractor extractor_manager
+ @echo -n
+opt: extractor.opt extractor_manager.opt
+ @echo -n
+
+clean:
+ rm -f *.cm[ixo] *.[ao] extractor extractor.opt *.err *.out extractor_manager extractor_manager.opt
+
+extractor: extractor.ml
+ @echo " OCAMLC $<"
+ @$(OCAMLFIND) ocamlc \
+ -thread -package mysql,helm-metadata -linkpkg -o $@ $<
+
+extractor.opt: extractor.ml
+ @echo " OCAMLOPT $<"
+ @$(OCAMLFIND) ocamlopt \
+ -thread -package mysql,helm-metadata -linkpkg -o $@ $<
+
+extractor_manager: extractor_manager.ml
+ @echo " OCAMLC $<"
+ @$(OCAMLFIND) ocamlc \
+ -thread -package mysql,helm-metadata -linkpkg -o $@ $<
+
+extractor_manager.opt: extractor_manager.ml
+ @echo " OCAMLOPT $<"
+ @$(OCAMLFIND) ocamlopt \
+ -thread -package mysql,helm-metadata -linkpkg -o $@ $<
+
+export: extractor.opt extractor_manager.opt
+ nice -n 20 \
+ time \
+ ./extractor_manager.opt 1>export.out 2>export.err
+
+include .depend
+include ../../../Makefile.defs
--- /dev/null
+<?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>
--- /dev/null
+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 ()
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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 ()
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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
--- /dev/null
+(* 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)
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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))
+*)
+
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 ]
+
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+sql.cmo: sql.cmi
+sql.cmx: sql.cmi
+table_creator.cmo: sql.cmi
+table_creator.cmx: sql.cmx
--- /dev/null
+REQUIRES = mysql helm-metadata
+
+INTERFACE_FILES =
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+EXTRA_OBJECTS_TO_INSTALL =
+EXTRA_OBJECTS_TO_CLEAN = \
+ table_creator table_creator.opt table_destructor table_destructor.opt
+
+all: table_creator table_destructor
+ @echo -n
+opt: table_creator.opt table_destructor.opt
+ @echo -n
+
+table_creator: table_creator.ml ../metadata.cma
+ @echo " OCAMLC $<"
+ @$(OCAMLFIND) ocamlc \
+ -thread -package mysql,helm-metadata -linkpkg -o $@ $<
+
+table_destructor: table_creator
+ @ln -f $< $@
+
+table_creator.opt: table_creator.ml ../metadata.cmxa
+ @echo " OCAMLOPT $<"
+ @$(OCAMLFIND) ocamlopt \
+ -thread -package mysql,helm-metadata -linkpkg -o $@ $<
+
+table_destructor.opt: table_creator.opt
+ @ln -f $< $@
+
+clean:
+ rm -f *.cm[iox] *.a *.o
+ rm -f table_creator table_creator.opt table_destructor table_destructor.opt
+
+include .depend
+include ../../../Makefile.defs
--- /dev/null
+#!/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."
+
--- /dev/null
+
+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 ()
+
+
--- /dev/null
+helm_registry.cmo: helm_registry.cmi
+helm_registry.cmx: helm_registry.cmi
--- /dev/null
+#use "topfind";;
+#require "helm-registry";;
+open Helm_registry;;
+load_from "tests/sample.xml";;
--- /dev/null
+
+PACKAGE = registry
+INTERFACE_FILES = helm_registry.mli
+IMPLEMENTATION_FILES = helm_registry.ml
+
+include ../../Makefile.defs
+include ../Makefile.common
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 ->
+ (try
+ [ Sys.getenv key ]
+ with Not_found -> raise (Key_not_found key))
+ | values, None -> values
+ in
+ List.map (interpolate (key :: stack)) values
+ and interpolate stack value =
+ Str.global_substitute interpolated_key_rex
+ (fun s ->
+ let matched = Str.matched_string s in
+ (* "$(var)" -> "var" *)
+ let key = String.sub matched 2 (String.length matched - 3) in
+ singleton (aux stack key))
+ value
+ in
+ List.map strip_blanks (aux [] key)
+
+let has registry key = Hashtbl.mem registry key
+
+let get_typed registry unmarshaller key =
+ let value = singleton (get registry key) in
+ unmarshaller value
+
+let set_typed registry marshaller ~key ~value =
+ set' ~replace:true registry ~key ~value:(marshaller value)
+
+let get_opt registry unmarshaller key =
+ try
+ Some (unmarshaller (singleton (get registry key)))
+ with Key_not_found _ -> None
+
+let get_opt_default registry unmarshaller ~default key =
+ match get_opt registry unmarshaller key with
+ | None -> default
+ | Some v -> v
+
+let set_opt registry marshaller ~key ~value =
+ match value with
+ | None -> unset registry key
+ | Some value -> set' ~replace:true registry ~key ~value:(marshaller value)
+
+let get_list registry unmarshaller key =
+ try
+ List.map unmarshaller (get registry key)
+ with Key_not_found _ -> []
+
+let get_pair registry fst_unmarshaller snd_unmarshaller key =
+ let v = singleton (get registry key) in
+ match Str.split spaces_rex v with
+ | [fst; snd] -> fst_unmarshaller fst, snd_unmarshaller snd
+ | _ -> raise (Type_error "not a pair")
+
+let set_list registry marshaller ~key ~value =
+ Hashtbl.remove registry key;
+ List.iter
+ (fun v -> set' ~replace:false registry ~key ~value:(marshaller v))
+ value
+
+type xml_tree =
+ | Cdata of string
+ | Element of string * (string * string) list * xml_tree list
+
+let dot_RE = Str.regexp "\\."
+
+let xml_tree_of_registry registry =
+ let has_child name elements =
+ List.exists
+ (function
+ | Element (_, ["name", name'], _) when name = name' -> true
+ | _ -> false)
+ elements
+ in
+ let rec get_child name = function
+ | [] -> assert false
+ | (Element (_, ["name", name'], _) as child) :: tl when name = name' ->
+ child, tl
+ | hd :: tl ->
+ let child, rest = get_child name tl in
+ child, hd :: rest
+ in
+ let rec add_key path value tree =
+ match path, tree with
+ | [key], Element (name, attrs, children) ->
+ Element (name, attrs,
+ Element ("key", ["name", key],
+ [Cdata (strip_blanks value)]) :: children)
+ | dir :: path, Element (name, attrs, children) ->
+ if has_child dir children then
+ let child, rest = get_child dir children in
+ Element (name, attrs, add_key path value child :: rest)
+ else
+ Element (name, attrs,
+ ((add_key path value (Element ("section", ["name", dir], [])))
+ :: children))
+ | _ -> assert false
+ in
+ Hashtbl.fold
+ (fun k v tree -> add_key ((Str.split dot_RE k)) v tree)
+ registry
+ (Element (root_tag, [], []))
+
+let rec stream_of_xml_tree = function
+ | Cdata s -> Xml.xml_cdata s
+ | Element (name, attrs, children) ->
+ Xml.xml_nempty name
+ (List.map (fun (n, v) -> (None, n, v)) attrs)
+ (stream_of_xml_trees children)
+and stream_of_xml_trees = function
+ | [] -> [< >]
+ | hd :: tl -> [< stream_of_xml_tree hd; stream_of_xml_trees tl >]
+
+let save_to registry fname =
+ let token_stream = stream_of_xml_tree (xml_tree_of_registry registry) in
+ let oc = open_out fname in
+ Xml.pp_to_outchan token_stream oc;
+ close_out oc
+
+let rec load_from_absolute ?path registry fname =
+ let _path = ref (match path with None -> [] | Some p -> p)in
+ (* <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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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)
+
--- /dev/null
+<?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="tests/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>
--- /dev/null
+<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>
--- /dev/null
+proofEngineHelpers.cmi: proofEngineTypes.cmi
+continuationals.cmi: proofEngineTypes.cmi
+tacticals.cmi: proofEngineTypes.cmi continuationals.cmi
+reductionTactics.cmi: proofEngineTypes.cmi
+proofEngineStructuralRules.cmi: proofEngineTypes.cmi
+primitiveTactics.cmi: proofEngineTypes.cmi
+metadataQuery.cmi: proofEngineTypes.cmi
+paramodulation/inference.cmi: paramodulation/utils.cmi proofEngineTypes.cmi
+paramodulation/equality_indexing.cmi: paramodulation/utils.cmi \
+ paramodulation/inference.cmi
+paramodulation/indexing.cmi: paramodulation/utils.cmi \
+ paramodulation/inference.cmi paramodulation/equality_indexing.cmi
+paramodulation/saturation.cmi: proofEngineTypes.cmi
+variousTactics.cmi: proofEngineTypes.cmi
+autoTactic.cmi: proofEngineTypes.cmi
+introductionTactics.cmi: proofEngineTypes.cmi
+eliminationTactics.cmi: proofEngineTypes.cmi
+negationTactics.cmi: proofEngineTypes.cmi
+equalityTactics.cmi: proofEngineTypes.cmi
+discriminationTactics.cmi: proofEngineTypes.cmi
+inversion.cmi: proofEngineTypes.cmi
+ring.cmi: proofEngineTypes.cmi
+fourierR.cmi: proofEngineTypes.cmi
+fwdSimplTactic.cmi: proofEngineTypes.cmi
+statefulProofEngine.cmi: proofEngineTypes.cmi
+tactics.cmi: proofEngineTypes.cmi
+proofEngineTypes.cmo: proofEngineTypes.cmi
+proofEngineTypes.cmx: proofEngineTypes.cmi
+proofEngineHelpers.cmo: proofEngineTypes.cmi proofEngineHelpers.cmi
+proofEngineHelpers.cmx: proofEngineTypes.cmx proofEngineHelpers.cmi
+proofEngineReduction.cmo: proofEngineTypes.cmi proofEngineHelpers.cmi \
+ proofEngineReduction.cmi
+proofEngineReduction.cmx: proofEngineTypes.cmx proofEngineHelpers.cmx \
+ proofEngineReduction.cmi
+continuationals.cmo: proofEngineTypes.cmi continuationals.cmi
+continuationals.cmx: proofEngineTypes.cmx continuationals.cmi
+tacticals.cmo: proofEngineTypes.cmi continuationals.cmi tacticals.cmi
+tacticals.cmx: proofEngineTypes.cmx continuationals.cmx tacticals.cmi
+reductionTactics.cmo: proofEngineTypes.cmi proofEngineReduction.cmi \
+ proofEngineHelpers.cmi reductionTactics.cmi
+reductionTactics.cmx: proofEngineTypes.cmx proofEngineReduction.cmx \
+ proofEngineHelpers.cmx reductionTactics.cmi
+proofEngineStructuralRules.cmo: proofEngineTypes.cmi \
+ proofEngineStructuralRules.cmi
+proofEngineStructuralRules.cmx: proofEngineTypes.cmx \
+ proofEngineStructuralRules.cmi
+primitiveTactics.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
+ proofEngineHelpers.cmi primitiveTactics.cmi
+primitiveTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
+ proofEngineHelpers.cmx primitiveTactics.cmi
+hashtbl_equiv.cmo: hashtbl_equiv.cmi
+hashtbl_equiv.cmx: hashtbl_equiv.cmi
+metadataQuery.cmo: proofEngineTypes.cmi primitiveTactics.cmi \
+ hashtbl_equiv.cmi metadataQuery.cmi
+metadataQuery.cmx: proofEngineTypes.cmx primitiveTactics.cmx \
+ hashtbl_equiv.cmx metadataQuery.cmi
+paramodulation/utils.cmo: proofEngineReduction.cmi paramodulation/utils.cmi
+paramodulation/utils.cmx: proofEngineReduction.cmx paramodulation/utils.cmi
+paramodulation/inference.cmo: paramodulation/utils.cmi \
+ proofEngineReduction.cmi proofEngineHelpers.cmi metadataQuery.cmi \
+ paramodulation/inference.cmi
+paramodulation/inference.cmx: paramodulation/utils.cmx \
+ proofEngineReduction.cmx proofEngineHelpers.cmx metadataQuery.cmx \
+ paramodulation/inference.cmi
+paramodulation/equality_indexing.cmo: paramodulation/utils.cmi \
+ paramodulation/inference.cmi paramodulation/equality_indexing.cmi
+paramodulation/equality_indexing.cmx: paramodulation/utils.cmx \
+ paramodulation/inference.cmx paramodulation/equality_indexing.cmi
+paramodulation/indexing.cmo: paramodulation/utils.cmi \
+ paramodulation/inference.cmi paramodulation/equality_indexing.cmi \
+ paramodulation/indexing.cmi
+paramodulation/indexing.cmx: paramodulation/utils.cmx \
+ paramodulation/inference.cmx paramodulation/equality_indexing.cmx \
+ paramodulation/indexing.cmi
+paramodulation/saturation.cmo: paramodulation/utils.cmi reductionTactics.cmi \
+ proofEngineTypes.cmi proofEngineReduction.cmi primitiveTactics.cmi \
+ paramodulation/inference.cmi paramodulation/indexing.cmi \
+ paramodulation/saturation.cmi
+paramodulation/saturation.cmx: paramodulation/utils.cmx reductionTactics.cmx \
+ proofEngineTypes.cmx proofEngineReduction.cmx primitiveTactics.cmx \
+ paramodulation/inference.cmx paramodulation/indexing.cmx \
+ paramodulation/saturation.cmi
+variousTactics.cmo: tacticals.cmi proofEngineTypes.cmi \
+ proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \
+ variousTactics.cmi
+variousTactics.cmx: tacticals.cmx proofEngineTypes.cmx \
+ proofEngineReduction.cmx proofEngineHelpers.cmx primitiveTactics.cmx \
+ variousTactics.cmi
+autoTactic.cmo: paramodulation/saturation.cmi proofEngineTypes.cmi \
+ proofEngineHelpers.cmi primitiveTactics.cmi metadataQuery.cmi \
+ paramodulation/inference.cmi autoTactic.cmi
+autoTactic.cmx: paramodulation/saturation.cmx proofEngineTypes.cmx \
+ proofEngineHelpers.cmx primitiveTactics.cmx metadataQuery.cmx \
+ paramodulation/inference.cmx autoTactic.cmi
+introductionTactics.cmo: proofEngineTypes.cmi primitiveTactics.cmi \
+ introductionTactics.cmi
+introductionTactics.cmx: proofEngineTypes.cmx primitiveTactics.cmx \
+ introductionTactics.cmi
+eliminationTactics.cmo: tacticals.cmi proofEngineTypes.cmi \
+ proofEngineStructuralRules.cmi proofEngineHelpers.cmi \
+ primitiveTactics.cmi eliminationTactics.cmi
+eliminationTactics.cmx: tacticals.cmx proofEngineTypes.cmx \
+ proofEngineStructuralRules.cmx proofEngineHelpers.cmx \
+ primitiveTactics.cmx eliminationTactics.cmi
+negationTactics.cmo: variousTactics.cmi tacticals.cmi proofEngineTypes.cmi \
+ primitiveTactics.cmi eliminationTactics.cmi negationTactics.cmi
+negationTactics.cmx: variousTactics.cmx tacticals.cmx proofEngineTypes.cmx \
+ primitiveTactics.cmx eliminationTactics.cmx negationTactics.cmi
+equalityTactics.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \
+ proofEngineStructuralRules.cmi proofEngineReduction.cmi \
+ proofEngineHelpers.cmi primitiveTactics.cmi introductionTactics.cmi \
+ equalityTactics.cmi
+equalityTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \
+ proofEngineStructuralRules.cmx proofEngineReduction.cmx \
+ proofEngineHelpers.cmx primitiveTactics.cmx introductionTactics.cmx \
+ equalityTactics.cmi
+discriminationTactics.cmo: tacticals.cmi reductionTactics.cmi \
+ proofEngineTypes.cmi primitiveTactics.cmi introductionTactics.cmi \
+ equalityTactics.cmi eliminationTactics.cmi discriminationTactics.cmi
+discriminationTactics.cmx: tacticals.cmx reductionTactics.cmx \
+ proofEngineTypes.cmx primitiveTactics.cmx introductionTactics.cmx \
+ equalityTactics.cmx eliminationTactics.cmx discriminationTactics.cmi
+inversion.cmo: tacticals.cmi proofEngineTypes.cmi proofEngineReduction.cmi \
+ proofEngineHelpers.cmi primitiveTactics.cmi equalityTactics.cmi \
+ inversion.cmi
+inversion.cmx: tacticals.cmx proofEngineTypes.cmx proofEngineReduction.cmx \
+ proofEngineHelpers.cmx primitiveTactics.cmx equalityTactics.cmx \
+ inversion.cmi
+ring.cmo: tacticals.cmi proofEngineTypes.cmi proofEngineStructuralRules.cmi \
+ primitiveTactics.cmi equalityTactics.cmi eliminationTactics.cmi ring.cmi
+ring.cmx: tacticals.cmx proofEngineTypes.cmx proofEngineStructuralRules.cmx \
+ primitiveTactics.cmx equalityTactics.cmx eliminationTactics.cmx ring.cmi
+fourier.cmo: fourier.cmi
+fourier.cmx: fourier.cmi
+fourierR.cmo: tacticals.cmi ring.cmi reductionTactics.cmi \
+ proofEngineTypes.cmi proofEngineHelpers.cmi primitiveTactics.cmi \
+ fourier.cmi equalityTactics.cmi fourierR.cmi
+fourierR.cmx: tacticals.cmx ring.cmx reductionTactics.cmx \
+ proofEngineTypes.cmx proofEngineHelpers.cmx primitiveTactics.cmx \
+ fourier.cmx equalityTactics.cmx fourierR.cmi
+fwdSimplTactic.cmo: tacticals.cmi proofEngineTypes.cmi \
+ proofEngineStructuralRules.cmi proofEngineHelpers.cmi \
+ primitiveTactics.cmi fwdSimplTactic.cmi
+fwdSimplTactic.cmx: tacticals.cmx proofEngineTypes.cmx \
+ proofEngineStructuralRules.cmx proofEngineHelpers.cmx \
+ primitiveTactics.cmx fwdSimplTactic.cmi
+history.cmo: history.cmi
+history.cmx: history.cmi
+statefulProofEngine.cmo: proofEngineTypes.cmi history.cmi \
+ statefulProofEngine.cmi
+statefulProofEngine.cmx: proofEngineTypes.cmx history.cmx \
+ statefulProofEngine.cmi
+tactics.cmo: variousTactics.cmi tacticals.cmi paramodulation/saturation.cmi \
+ ring.cmi reductionTactics.cmi proofEngineStructuralRules.cmi \
+ primitiveTactics.cmi negationTactics.cmi inversion.cmi \
+ introductionTactics.cmi fwdSimplTactic.cmi fourierR.cmi \
+ equalityTactics.cmi eliminationTactics.cmi discriminationTactics.cmi \
+ autoTactic.cmi tactics.cmi
+tactics.cmx: variousTactics.cmx tacticals.cmx paramodulation/saturation.cmx \
+ ring.cmx reductionTactics.cmx proofEngineStructuralRules.cmx \
+ primitiveTactics.cmx negationTactics.cmx inversion.cmx \
+ introductionTactics.cmx fwdSimplTactic.cmx fourierR.cmx \
+ equalityTactics.cmx eliminationTactics.cmx discriminationTactics.cmx \
+ autoTactic.cmx tactics.cmi
--- /dev/null
+PACKAGE = tactics
+
+INTERFACE_FILES = \
+ proofEngineTypes.mli \
+ proofEngineHelpers.mli proofEngineReduction.mli \
+ continuationals.mli \
+ tacticals.mli reductionTactics.mli proofEngineStructuralRules.mli \
+ primitiveTactics.mli hashtbl_equiv.mli metadataQuery.mli \
+ paramodulation/utils.mli \
+ paramodulation/inference.mli\
+ paramodulation/equality_indexing.mli\
+ paramodulation/indexing.mli \
+ paramodulation/saturation.mli \
+ variousTactics.mli autoTactic.mli \
+ introductionTactics.mli eliminationTactics.mli negationTactics.mli \
+ equalityTactics.mli discriminationTactics.mli inversion.mli ring.mli \
+ fourier.mli fourierR.mli fwdSimplTactic.mli history.mli \
+ statefulProofEngine.mli tactics.mli
+
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+
+
+all:
+
+tactics.mli: tactics.ml *Tactics.mli *Tactic.mli fourierR.mli ring.mli paramodulation/indexing.mli
+ @echo " OCAMLC -i $< > $@"
+ $(H)echo "(* GENERATED FILE, DO NOT EDIT *)" > $@
+ $(H)$(OCAMLC) -I paramodulation -i $< >> $@
+
+STATS_EXCLUDE = tactics.mli
+
+include ../../Makefile.defs
+include ../Makefile.common
+
+OCAMLOPTIONS+= -I paramodulation
+OCAMLDEPOPTIONS+= -I paramodulation
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+ let debug = false
+ let debug_print s = if debug then prerr_endline (Lazy.force s)
+
+(* let debug_print = fun _ -> () *)
+
+(* Profiling code
+let new_experimental_hint =
+ let profile = CicUtil.profile "new_experimental_hint" in
+ fun ~dbd ~facts ?signature ~universe status ->
+ profile.profile (MetadataQuery.new_experimental_hint ~dbd ~facts ?signature ~universe) status
+*) let new_experimental_hint = MetadataQuery.new_experimental_hint
+
+(* In this versions of auto_tac we maintain an hash table of all inspected
+ goals. We assume that the context is invariant for application.
+ To this aim, it is essential to sall hint_verbose, that in turns calls
+ apply_verbose. *)
+
+type exitus =
+ No of int
+ | Yes of Cic.term * int
+ | NotYetInspected
+
+let inspected_goals = Hashtbl.create 503;;
+
+let search_theorems_in_context status =
+ let (proof, goal) = status in
+ let module C = Cic in
+ let module R = CicReduction in
+ let module S = CicSubstitution in
+ let module PET = ProofEngineTypes in
+ let module PT = PrimitiveTactics in
+ let _,metasenv,_,_ = proof in
+ let _,context,ty = CicUtil.lookup_meta goal metasenv in
+ let rec find n = function
+ | [] -> []
+ | hd::tl ->
+ let res =
+ (* we should check that the hypothesys has not been cleared *)
+ if List.nth context (n-1) = None then
+ None
+ else
+ try
+ let (subst,(proof, goal_list)) =
+ PT.apply_tac_verbose ~term:(C.Rel n) status
+ in
+ (*
+ let goal_list =
+ List.stable_sort (compare_goal_list proof) goal_list in
+ *)
+ Some (subst,(proof, goal_list))
+ with
+ PET.Fail _ -> None
+ in
+ (match res with
+ | Some res -> res::(find (n+1) tl)
+ | None -> find (n+1) tl)
+ in
+ try
+ find 1 context
+ with Failure s -> []
+;;
+
+
+let compare_goals proof goal1 goal2 =
+ let _,metasenv,_,_ = proof in
+ let (_, ey1, ty1) = CicUtil.lookup_meta goal1 metasenv in
+ let (_, ey2, ty2) = CicUtil.lookup_meta goal2 metasenv in
+ let ty_sort1,_ = CicTypeChecker.type_of_aux' metasenv ey1 ty1
+ CicUniv.empty_ugraph in
+ let ty_sort2,_ = CicTypeChecker.type_of_aux' metasenv ey2 ty2
+ CicUniv.empty_ugraph in
+ let prop1 =
+ let b,_ = CicReduction.are_convertible ey1 (Cic.Sort Cic.Prop) ty_sort1
+ CicUniv.empty_ugraph in
+ if b then 0 else 1
+ in
+ let prop2 =
+ let b,_ = CicReduction.are_convertible ey2 (Cic.Sort Cic.Prop) ty_sort2
+ CicUniv.empty_ugraph in
+ if b then 0 else 1
+ in
+ prop1 - prop2
+
+
+let new_search_theorems f dbd proof goal depth sign =
+ let choices = f (proof,goal)
+ in
+ List.map
+ (function (subst,(proof, goallist)) ->
+ (* let goallist = reorder_goals dbd sign proof goallist in *)
+ let goallist = List.sort (compare_goals proof) goallist in
+ (subst,(proof,(List.map (function g -> (g,depth)) goallist), sign)))
+ choices
+;;
+
+exception NoOtherChoices;;
+
+let rec auto_single dbd proof goal ey ty depth width sign already_seen_goals
+ universe
+ =
+ if depth = 0 then [] else
+ if List.mem ty already_seen_goals then [] else
+ let already_seen_goals = ty::already_seen_goals in
+ let facts = (depth = 1) in
+ let _,metasenv,p,_ = proof in
+ (* first of all we check if the goal has been already
+ inspected *)
+ assert (CicUtil.exists_meta goal metasenv);
+ let exitus =
+ try Hashtbl.find inspected_goals ty
+ with Not_found -> NotYetInspected in
+ let is_meta_closed = CicUtil.is_meta_closed ty in
+ begin
+ match exitus with
+ Yes (bo,_) ->
+ (*
+ debug_print (lazy "ALREADY PROVED!!!!!!!!!!!!!!!!!!!!!!!!!!!!");
+ debug_print (lazy (CicPp.ppterm ty));
+ *)
+ let subst_in =
+ (* if we just apply the subtitution, the type
+ is irrelevant: we may use Implicit, since it will
+ be dropped *)
+ CicMetaSubst.apply_subst
+ [(goal,(ey, bo, Cic.Implicit None))] in
+ let (proof,_) =
+ ProofEngineHelpers.subst_meta_and_metasenv_in_proof
+ proof goal subst_in metasenv in
+ [(subst_in,(proof,[],sign))]
+ | No d when (d >= depth) ->
+ (* debug_print (lazy "PRUNED!!!!!!!!!!!!!!!!!!!!!!!!!!!!"); *)
+ [] (* the empty list means no choices, i.e. failure *)
+ | No _
+ | NotYetInspected ->
+ debug_print (lazy ("CURRENT GOAL = " ^ CicPp.ppterm ty));
+ debug_print (lazy ("CURRENT PROOF = " ^ CicPp.ppterm p));
+ debug_print (lazy ("CURRENT HYP = " ^ CicPp.ppcontext ey));
+ let sign, new_sign =
+ if is_meta_closed then
+ None, Some (MetadataConstraints.signature_of ty)
+ else sign,sign in (* maybe the union ? *)
+ let local_choices =
+ new_search_theorems
+ search_theorems_in_context dbd
+ proof goal (depth-1) new_sign in
+ let global_choices =
+ new_search_theorems
+ (fun status ->
+ List.map snd
+ (new_experimental_hint
+ ~dbd ~facts:facts ?signature:sign ~universe status))
+ dbd proof goal (depth-1) new_sign in
+ let all_choices =
+ local_choices@global_choices in
+ let sorted_choices =
+ List.stable_sort
+ (fun (_, (_, goals1, _)) (_, (_, goals2, _)) ->
+ Pervasives.compare
+ (List.length goals1) (List.length goals2))
+ all_choices in
+ (match (auto_new dbd width already_seen_goals universe sorted_choices)
+ with
+ [] ->
+ (* no proof has been found; we update the
+ hastable *)
+ (* if is_meta_closed then *)
+ Hashtbl.add inspected_goals ty (No depth);
+ []
+ | (subst,(proof,[],sign))::tl1 ->
+ (* a proof for goal has been found:
+ in order to get the proof we apply subst to
+ Meta[goal] *)
+ if is_meta_closed then
+ begin
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable ey in
+ let meta_proof =
+ subst (Cic.Meta(goal,irl)) in
+ Hashtbl.add inspected_goals
+ ty (Yes (meta_proof,depth));
+(*
+ begin
+ let cty,_ =
+ CicTypeChecker.type_of_aux' metasenv ey meta_proof CicUniv.empty_ugraph
+ in
+ if not (cty = ty) then
+ begin
+ debug_print (lazy ("ty = "^CicPp.ppterm ty));
+ debug_print (lazy ("cty = "^CicPp.ppterm cty));
+ assert false
+ end
+ Hashtbl.add inspected_goals
+ ty (Yes (meta_proof,depth));
+ end;
+*)
+ end;
+ (subst,(proof,[],sign))::tl1
+ | _ -> assert false)
+ end
+
+and auto_new dbd width already_seen_goals universe = function
+ | [] -> []
+ | (subst,(proof, goals, sign))::tl ->
+ let _,metasenv,_,_ = proof in
+ let goals'=
+ List.filter (fun (goal, _) -> CicUtil.exists_meta goal metasenv) goals
+ in
+ auto_new_aux dbd
+ width already_seen_goals universe ((subst,(proof, goals', sign))::tl)
+
+and auto_new_aux dbd width already_seen_goals universe = function
+ | [] -> []
+ | (subst,(proof, [], sign))::tl -> (subst,(proof, [], sign))::tl
+ | (subst,(proof, (goal,0)::_, _))::tl ->
+ auto_new dbd width already_seen_goals universe tl
+ | (subst,(proof, goals, _))::tl when
+ (List.length goals) > width ->
+ auto_new dbd width already_seen_goals universe tl
+ | (subst,(proof, (goal,depth)::gtl, sign))::tl ->
+ let _,metasenv,p,_ = proof in
+ let (_, ey ,ty) = CicUtil.lookup_meta goal metasenv in
+ match (auto_single dbd proof goal ey ty depth
+ (width - (List.length gtl)) sign already_seen_goals) universe
+ with
+ [] -> auto_new dbd width already_seen_goals universe tl
+ | (local_subst,(proof,[],sign))::tl1 ->
+ let new_subst f t = f (subst t) in
+ let is_meta_closed = CicUtil.is_meta_closed ty in
+ let all_choices =
+ if is_meta_closed then
+ (new_subst local_subst,(proof,gtl,sign))::tl
+ else
+ let tl2 =
+ (List.map
+ (function (f,(p,l,s)) -> (new_subst f,(p,l@gtl,s))) tl1)
+ in
+ (new_subst local_subst,(proof,gtl,sign))::tl2@tl in
+ auto_new dbd width already_seen_goals universe all_choices
+ | _ -> assert false
+ ;;
+
+let default_depth = 5
+let default_width = 3
+
+(*
+let auto_tac ?(depth=default_depth) ?(width=default_width) ~(dbd:HMysql.dbd)
+ ()
+=
+ let auto_tac dbd (proof,goal) =
+ let universe = MetadataQuery.signature_of_goal ~dbd (proof,goal) in
+ Hashtbl.clear inspected_goals;
+ debug_print (lazy "Entro in Auto");
+ let id t = t in
+ let t1 = Unix.gettimeofday () in
+ match auto_new dbd width [] universe [id,(proof, [(goal,depth)],None)] with
+ [] -> debug_print (lazy "Auto failed");
+ raise (ProofEngineTypes.Fail "No Applicable theorem")
+ | (_,(proof,[],_))::_ ->
+ let t2 = Unix.gettimeofday () in
+ debug_print (lazy "AUTO_TAC HA FINITO");
+ let _,_,p,_ = proof in
+ debug_print (lazy (CicPp.ppterm p));
+ Printf.printf "tempo: %.9f\n" (t2 -. t1);
+ (proof,[])
+ | _ -> assert false
+ in
+ ProofEngineTypes.mk_tactic (auto_tac dbd)
+;;
+*)
+
+(*
+let paramodulation_tactic = ref
+ (fun dbd ?full ?depth ?width status ->
+ raise (ProofEngineTypes.Fail (lazy "Not Ready yet...")));;
+
+let term_is_equality = ref
+ (fun term -> debug_print (lazy "term_is_equality E` DUMMY!!!!"); false);;
+*)
+
+let auto_tac ?(depth=default_depth) ?(width=default_width) ?paramodulation
+ ?full ~(dbd:HMysql.dbd) () =
+ let auto_tac dbd (proof, goal) =
+ let normal_auto () =
+ let universe = MetadataQuery.signature_of_goal ~dbd (proof, goal) in
+ Hashtbl.clear inspected_goals;
+ debug_print (lazy "Entro in Auto");
+ let id t = t in
+ let t1 = Unix.gettimeofday () in
+ match
+ auto_new dbd width [] universe [id, (proof, [(goal, depth)], None)]
+ with
+ [] -> debug_print(lazy "Auto failed");
+ raise (ProofEngineTypes.Fail (lazy "No Applicable theorem"))
+ | (_,(proof,[],_))::_ ->
+ let t2 = Unix.gettimeofday () in
+ debug_print (lazy "AUTO_TAC HA FINITO");
+ let _,_,p,_ = proof in
+ debug_print (lazy (CicPp.ppterm p));
+ debug_print (lazy (Printf.sprintf "tempo: %.9f\n" (t2 -. t1)));
+ (proof,[])
+ | _ -> assert false
+ in
+ let full = match full with None -> false | Some _ -> true in
+ let paramodulation_ok =
+ match paramodulation with
+ | None -> false
+ | Some _ ->
+ let _, metasenv, _, _ = proof in
+ let _, _, meta_goal = CicUtil.lookup_meta goal metasenv in
+ full || (Inference.term_is_equality meta_goal)
+ in
+ if paramodulation_ok then (
+ debug_print (lazy "USO PARAMODULATION...");
+(* try *)
+ Saturation.saturate dbd ~depth ~width ~full (proof, goal)
+(* with ProofEngineTypes.Fail _ -> *)
+(* normal_auto () *)
+ ) else
+ normal_auto ()
+ in
+ ProofEngineTypes.mk_tactic (auto_tac dbd)
+;;
--- /dev/null
+
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val auto_tac:
+ ?depth:int -> ?width:int -> ?paramodulation:string -> ?full:string ->
+ dbd:HMysql.dbd -> unit ->
+ ProofEngineTypes.tactic
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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")
+;;
+
+*)
+
+
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val injection_tac: term:Cic.term -> ProofEngineTypes.tactic
+val discriminate_tac: term:Cic.term -> ProofEngineTypes.tactic
+val decide_equality_tac: ProofEngineTypes.tactic
+val compare_tac: term:Cic.term -> ProofEngineTypes.tactic
+
--- /dev/null
+
+#
+# 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
+
+########################################################################
+
--- /dev/null
+
+\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.
+
--- /dev/null
+%%
+%% 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\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'.
--- /dev/null
+%%
+%% 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'.
--- /dev/null
+\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}
+
--- /dev/null
+%%
+%% 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'.
--- /dev/null
+%%
+%% 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'.
--- /dev/null
+%%
+%% 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'.
--- /dev/null
+%%
+%% 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'.
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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
+*)
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val elim_type_tac:
+ ?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
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+let rec rewrite_tac ~direction ~(pattern: ProofEngineTypes.lazy_pattern) equality =
+ let _rewrite_tac ~direction ~pattern:(wanted,hyps_pat,concl_pat) equality status
+ =
+ let module C = Cic in
+ let module U = UriManager in
+ let module PET = ProofEngineTypes in
+ let module PER = ProofEngineReduction in
+ let module PEH = ProofEngineHelpers in
+ let module PT = PrimitiveTactics in
+ assert (wanted = None); (* this should be checked syntactically *)
+ let proof,goal = status in
+ let curi, metasenv, pbo, pty = proof in
+ let (metano,context,gty) = CicUtil.lookup_meta goal metasenv in
+ match hyps_pat with
+ he::(_::_ as tl) ->
+ PET.apply_tactic
+ (Tacticals.then_
+ (rewrite_tac ~direction
+ ~pattern:(None,[he],None) equality)
+ (rewrite_tac ~direction ~pattern:(None,tl,concl_pat) equality)
+ ) status
+ | [_] as hyps_pat when concl_pat <> None ->
+ PET.apply_tactic
+ (Tacticals.then_
+ (rewrite_tac ~direction
+ ~pattern:(None,hyps_pat,None) equality)
+ (rewrite_tac ~direction ~pattern:(None,[],concl_pat) equality)
+ ) status
+ | _ ->
+ let arg,dir2,tac,concl_pat,gty =
+ match hyps_pat with
+ [] -> None,true,(fun ~term _ -> PT.exact_tac term),concl_pat,gty
+ | [name,pat] ->
+ let rec find_hyp n =
+ function
+ [] -> assert false
+ | Some (Cic.Name s,Cic.Decl ty)::_ when name = s ->
+ Cic.Rel n, CicSubstitution.lift n ty
+ | Some (Cic.Name s,Cic.Def _)::_ -> assert false (*CSC: not implemented yet! But does this make any sense?*)
+ | _::tl -> find_hyp (n+1) tl
+ in
+ let arg,gty = find_hyp 1 context in
+ let dummy = "dummy" in
+ Some arg,false,
+ (fun ~term typ ->
+ Tacticals.seq
+ ~tactics:
+ [ProofEngineStructuralRules.rename name dummy;
+ PT.letin_tac
+ ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name name) term;
+ ProofEngineStructuralRules.clearbody name;
+ ReductionTactics.change_tac
+ ~pattern:
+ (None,[name,Cic.Implicit (Some `Hole)], None)
+ (ProofEngineTypes.const_lazy_term typ);
+ ProofEngineStructuralRules.clear dummy
+ ]),
+ Some pat,gty
+ | _::_ -> assert false
+ in
+ let if_right_to_left do_not_change a b =
+ match direction with
+ | `RightToLeft -> if do_not_change then a else b
+ | `LeftToRight -> if do_not_change then b else a
+ in
+ let ty_eq,ugraph =
+ CicTypeChecker.type_of_aux' metasenv context equality
+ CicUniv.empty_ugraph in
+ let (ty_eq,metasenv',arguments,fresh_meta) =
+ ProofEngineHelpers.saturate_term
+ (ProofEngineHelpers.new_meta_of_proof proof) metasenv context ty_eq 0 in
+ let equality =
+ if List.length arguments = 0 then
+ equality
+ else
+ C.Appl (equality :: arguments) in
+ (* t1x is t2 if we are rewriting in an hypothesis *)
+ let eq_ind, ty, t1, t2, t1x =
+ match ty_eq with
+ | C.Appl [C.MutInd (uri, 0, []); ty; t1; t2]
+ when LibraryObjects.is_eq_URI uri ->
+ let ind_uri =
+ if_right_to_left dir2
+ LibraryObjects.eq_ind_URI LibraryObjects.eq_ind_r_URI
+ in
+ let eq_ind = C.Const (ind_uri uri,[]) in
+ if dir2 then
+ if_right_to_left true (eq_ind,ty,t2,t1,t2) (eq_ind,ty,t1,t2,t1)
+ else
+ if_right_to_left true (eq_ind,ty,t1,t2,t2) (eq_ind,ty,t2,t1,t1)
+ | _ -> raise (PET.Fail (lazy "Rewrite: argument is not a proof of an equality")) in
+ (* now we always do as if direction was `LeftToRight *)
+ let fresh_name =
+ FreshNamesGenerator.mk_fresh_name
+ ~subst:[] metasenv' context C.Anonymous ~typ:ty in
+ let lifted_t1 = CicSubstitution.lift 1 t1x in
+ let lifted_gty = CicSubstitution.lift 1 gty in
+ let lifted_conjecture =
+ metano,(Some (fresh_name,Cic.Decl ty))::context,lifted_gty in
+ let lifted_pattern =
+ let lifted_concl_pat =
+ match concl_pat with
+ | None -> None
+ | Some term -> Some (CicSubstitution.lift 1 term) in
+ Some (fun _ m u -> lifted_t1, m, u),[],lifted_concl_pat
+ in
+ let subst,metasenv',ugraph,_,selected_terms_with_context =
+ ProofEngineHelpers.select
+ ~metasenv:metasenv' ~ugraph ~conjecture:lifted_conjecture
+ ~pattern:lifted_pattern in
+ let metasenv' = CicMetaSubst.apply_subst_metasenv subst metasenv' in
+ let what,with_what =
+ (* Note: Rel 1 does not live in the context context_of_t *)
+ (* The replace_lifting_csc 0 function will take care of lifting it *)
+ (* to context_of_t *)
+ List.fold_right
+ (fun (context_of_t,t) (l1,l2) -> t::l1, Cic.Rel 1::l2)
+ selected_terms_with_context ([],[]) in
+ let t1 = CicMetaSubst.apply_subst subst t1 in
+ let t2 = CicMetaSubst.apply_subst subst t2 in
+ let equality = CicMetaSubst.apply_subst subst equality in
+ let abstr_gty =
+ ProofEngineReduction.replace_lifting_csc 0
+ ~equality:(==) ~what ~with_what:with_what ~where:lifted_gty in
+ let abstr_gty = CicMetaSubst.apply_subst subst abstr_gty in
+ let pred = C.Lambda (fresh_name, ty, abstr_gty) in
+ (* The argument is either a meta if we are rewriting in the conclusion
+ or the hypothesis if we are rewriting in an hypothesis *)
+ let metasenv',arg,newtyp =
+ match arg with
+ None ->
+ let gty' = CicSubstitution.subst t2 abstr_gty in
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context in
+ let metasenv' = (fresh_meta,context,gty')::metasenv' in
+ metasenv', C.Meta (fresh_meta,irl), Cic.Rel (-1) (* dummy term, never used *)
+ | Some arg ->
+ let gty' = CicSubstitution.subst t1 abstr_gty in
+ metasenv',arg,gty'
+ in
+ let exact_proof =
+ C.Appl [eq_ind ; ty ; t2 ; pred ; arg ; t1 ;equality]
+ in
+ let (proof',goals) =
+ PET.apply_tactic
+ (tac ~term:exact_proof newtyp) ((curi,metasenv',pbo,pty),goal)
+ in
+ let goals =
+ goals@(ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv
+ ~newmetasenv:metasenv')
+ in
+ (proof',goals)
+ in
+ ProofEngineTypes.mk_tactic (_rewrite_tac ~direction ~pattern equality)
+
+
+let rewrite_simpl_tac ~direction ~pattern equality =
+ let rewrite_simpl_tac ~direction ~pattern equality status =
+ ProofEngineTypes.apply_tactic
+ (Tacticals.then_
+ ~start:(rewrite_tac ~direction ~pattern equality)
+ ~continuation:
+ (ReductionTactics.simpl_tac
+ ~pattern:(ProofEngineTypes.conclusion_pattern None)))
+ status
+ in
+ ProofEngineTypes.mk_tactic (rewrite_simpl_tac ~direction ~pattern equality)
+;;
+
+let replace_tac ~(pattern: ProofEngineTypes.lazy_pattern) ~with_what =
+ let replace_tac ~(pattern: ProofEngineTypes.lazy_pattern) ~with_what status =
+ let _wanted, hyps_pat, concl_pat = pattern in
+ let (proof, goal) = status in
+ let module C = Cic in
+ let module U = UriManager in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ let uri,metasenv,pbo,pty = proof in
+ let (_,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in
+ assert (hyps_pat = []); (*CSC: not implemented yet *)
+ let context_len = List.length context in
+ let subst,metasenv,u,_,selected_terms_with_context =
+ ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph
+ ~conjecture ~pattern in
+ let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
+ let with_what, metasenv, u = with_what context metasenv u in
+ let with_what = CicMetaSubst.apply_subst subst with_what in
+ let pbo = CicMetaSubst.apply_subst subst pbo in
+ let pty = CicMetaSubst.apply_subst subst pty in
+ let status = (uri,metasenv,pbo,pty),goal in
+ let ty_of_with_what,u =
+ CicTypeChecker.type_of_aux'
+ metasenv context with_what CicUniv.empty_ugraph in
+ let whats =
+ match selected_terms_with_context with
+ [] -> raise (ProofEngineTypes.Fail (lazy "Replace: no term selected"))
+ | l ->
+ List.map
+ (fun (context_of_t,t) ->
+ let t_in_context =
+ try
+ let context_of_t_len = List.length context_of_t in
+ if context_of_t_len = context_len then t
+ else
+ (let t_in_context,subst,metasenv' =
+ CicMetaSubst.delift_rels [] metasenv
+ (context_of_t_len - context_len) t
+ in
+ assert (subst = []);
+ assert (metasenv = metasenv');
+ t_in_context)
+ with
+ CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
+ (*CSC: we could implement something stronger by completely changing
+ the semantics of the tactic *)
+ raise (ProofEngineTypes.Fail
+ (lazy "Replace: one of the selected terms is not closed")) in
+ let ty_of_t_in_context,u = (* TASSI: FIXME *)
+ CicTypeChecker.type_of_aux' metasenv context t_in_context
+ CicUniv.empty_ugraph in
+ let b,u = CicReduction.are_convertible ~metasenv context
+ ty_of_with_what ty_of_t_in_context u in
+ if b then
+ let concl_pat_for_t = ProofEngineHelpers.pattern_of ~term:ty [t] in
+ let pattern_for_t = None,[],Some concl_pat_for_t in
+ t_in_context,pattern_for_t
+ else
+ raise
+ (ProofEngineTypes.Fail
+ (lazy "Replace: one of the selected terms and the term to be replaced with have not convertible types"))
+ ) l in
+ let rec aux n whats status =
+ match whats with
+ [] -> ProofEngineTypes.apply_tactic T.id_tac status
+ | (what,lazy_pattern)::tl ->
+ let what = CicSubstitution.lift n what in
+ let with_what = CicSubstitution.lift n with_what in
+ let ty_of_with_what = CicSubstitution.lift n ty_of_with_what in
+ ProofEngineTypes.apply_tactic
+ (T.thens
+ ~start:(
+ P.cut_tac
+ (C.Appl [
+ (C.MutInd (LibraryObjects.eq_URI (), 0, [])) ;
+ ty_of_with_what ;
+ what ;
+ with_what]))
+ ~continuations:[
+ T.then_
+ ~start:(
+ rewrite_tac ~direction:`LeftToRight ~pattern:lazy_pattern (C.Rel 1))
+ ~continuation:(
+ T.then_
+ ~start:(
+ ProofEngineTypes.mk_tactic
+ (function ((proof,goal) as status) ->
+ let _,metasenv,_,_ = proof in
+ let _,context,_ = CicUtil.lookup_meta goal metasenv in
+ let hyp =
+ try
+ match List.hd context with
+ Some (Cic.Name name,_) -> name
+ | _ -> assert false
+ with (Failure "hd") -> assert false
+ in
+ ProofEngineTypes.apply_tactic
+ (ProofEngineStructuralRules.clear ~hyp) status))
+ ~continuation:(aux_tac (n + 1) tl));
+ T.id_tac])
+ status
+ and aux_tac n tl = ProofEngineTypes.mk_tactic (aux n tl) in
+ aux 0 whats status
+ in
+ ProofEngineTypes.mk_tactic (replace_tac ~pattern ~with_what)
+;;
+
+
+(* All these tacs do is applying the right constructor/theorem *)
+
+let reflexivity_tac =
+ IntroductionTactics.constructor_tac ~n:1
+;;
+
+let symmetry_tac =
+ let symmetry_tac (proof, goal) =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let (_,metasenv,_,_) = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ match (R.whd context ty) with
+ (C.Appl [(C.MutInd (uri, 0, [])); _; _; _])
+ when LibraryObjects.is_eq_URI uri ->
+ ProofEngineTypes.apply_tactic
+ (PrimitiveTactics.apply_tac
+ ~term: (C.Const (LibraryObjects.sym_eq_URI uri, [])))
+ (proof,goal)
+
+ | _ -> raise (ProofEngineTypes.Fail (lazy "Symmetry failed"))
+ in
+ ProofEngineTypes.mk_tactic symmetry_tac
+;;
+
+let transitivity_tac ~term =
+ let transitivity_tac ~term status =
+ let (proof, goal) = status in
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let module T = Tacticals in
+ let (_,metasenv,_,_) = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ match (R.whd context ty) with
+ (C.Appl [(C.MutInd (uri, 0, [])); _; _; _])
+ when LibraryObjects.is_eq_URI uri ->
+ ProofEngineTypes.apply_tactic
+ (T.thens
+ ~start:(PrimitiveTactics.apply_tac
+ ~term: (C.Const (LibraryObjects.trans_eq_URI uri, [])))
+ ~continuations:
+ [PrimitiveTactics.exact_tac ~term ; T.id_tac ; T.id_tac])
+ status
+
+ | _ -> raise (ProofEngineTypes.Fail (lazy "Transitivity failed"))
+ in
+ ProofEngineTypes.mk_tactic (transitivity_tac ~term)
+;;
+
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val rewrite_tac:
+ 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
+
--- /dev/null
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Méthode d'élimination de Fourier *)
+(* Référence:
+Auteur(s) : Fourier, Jean-Baptiste-Joseph
+
+Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
+
+Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
+
+Pages: 326-327
+
+http://gallica.bnf.fr/
+*)
+
+(** @author The Coq Development Team *)
+
+
+(* Un peu de calcul sur les rationnels...
+Les opérations rendent des rationnels normalisés,
+i.e. le numérateur et le dénominateur sont premiers entre eux.
+*)
+
+
+(** Type for coefficents *)
+type rational = {
+num:int; (** Numerator *)
+den:int; (** Denumerator *)
+};;
+
+(** Debug function.
+ @param x the rational to print*)
+let print_rational x =
+ print_int x.num;
+ print_string "/";
+ print_int x.den
+;;
+
+let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);;
+
+(** The constant 0*)
+let r0 = {num=0;den=1};;
+(** The constant 1*)
+let r1 = {num=1;den=1};;
+
+let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in
+ if x.num=0 then r0
+ else (let d=pgcd x.num x.den in
+ let d= (if d<0 then -d else d) in
+ {num=(x.num)/d;den=(x.den)/d});;
+
+(** Calculates the opposite of a rational.
+ @param x The rational
+ @return -x*)
+let rop x = rnorm {num=(-x.num);den=x.den};;
+
+(** Sums two rationals.
+ @param x A rational
+ @param y Another rational
+ @return x+y*)
+let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};;
+(** Substracts two rationals.
+ @param x A rational
+ @param y Another rational
+ @return x-y*)
+let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};;
+(** Multiplyes two rationals.
+ @param x A rational
+ @param y Another rational
+ @return x*y*)
+let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};;
+(** Inverts arational.
+ @param x A rational
+ @return x{^ -1} *)
+let rinv x = rnorm {num=x.den;den=x.num};;
+(** Divides two rationals.
+ @param x A rational
+ @param y Another rational
+ @return x/y*)
+let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};;
+
+let rinf x y = x.num*y.den < y.num*x.den;;
+let rinfeq x y = x.num*y.den <= y.num*x.den;;
+
+
+(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
+c1x1+...+cnxn < d si strict=true, <= sinon,
+hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
+*)
+
+type ineq = {coef:rational list;
+ hist:rational list;
+ strict:bool};;
+
+let pop x l = l:=x::(!l);;
+
+(* sépare la liste d'inéquations s selon que leur premier coefficient est
+négatif, nul ou positif. *)
+let partitionne s =
+ let lpos=ref [] in
+ let lneg=ref [] in
+ let lnul=ref [] in
+ List.iter (fun ie -> match ie.coef with
+ [] -> raise (Failure "empty ineq")
+ |(c::r) -> if rinf c r0
+ then pop ie lneg
+ else if rinf r0 c then pop ie lpos
+ else pop ie lnul)
+ s;
+ [!lneg;!lnul;!lpos]
+;;
+(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
+(add_hist [(equation 1, s1);...;(équation n, sn)])
+=
+[{équation 1, [1;0;...;0], s1};
+ {équation 2, [0;1;...;0], s2};
+ ...
+ {équation n, [0;0;...;1], sn}]
+*)
+let add_hist le =
+ let n = List.length le in
+ let i=ref 0 in
+ List.map (fun (ie,s) ->
+ let h =ref [] in
+ for k=1 to (n-(!i)-1) do pop r0 h; done;
+ pop r1 h;
+ for k=1 to !i do pop r0 h; done;
+ i:=!i+1;
+ {coef=ie;hist=(!h);strict=s})
+ le
+;;
+(* additionne deux inéquations *)
+let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef;
+ hist=List.map2 rplus ie1.hist ie2.hist;
+ strict=ie1.strict || ie2.strict}
+;;
+(* multiplication d'une inéquation par un rationnel (positif) *)
+let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef;
+ hist=List.map (fun x -> rmult a x) ie.hist;
+ strict= ie.strict}
+;;
+(* on enlève le premier coefficient *)
+let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict}
+;;
+(* le premier coefficient: "tête" de l'inéquation *)
+let hd_coef ie = List.hd ie.coef
+;;
+
+(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
+*)
+let deduce_add lneg lpos =
+ let res=ref [] in
+ List.iter (fun i1 ->
+ List.iter (fun i2 ->
+ let a = rop (hd_coef i1) in
+ let b = hd_coef i2 in
+ pop (ie_tl (ie_add (ie_emult b i1)
+ (ie_emult a i2))) res)
+ lpos)
+ lneg;
+ !res
+;;
+(* élimination de la première variable à partir d'une liste d'inéquations:
+opération qu'on itère dans l'algorithme de Fourier.
+*)
+let deduce1 s i=
+ match (partitionne s) with
+ [lneg;lnul;lpos] ->
+ let lnew = deduce_add lneg lpos in
+ (match lneg with [] -> print_string("non posso ridurre "^string_of_int i^"\n")|_->();
+ match lpos with [] -> print_string("non posso ridurre "^string_of_int i^"\n")|_->());
+ (List.map ie_tl lnul)@lnew
+ |_->assert false
+;;
+(* algorithme de Fourier: on élimine successivement toutes les variables.
+*)
+let deduce lie =
+ let n = List.length (fst (List.hd lie)) in
+ let lie=ref (add_hist lie) in
+ for i=1 to n-1 do
+ lie:= deduce1 !lie i;
+ done;
+ !lie
+;;
+
+(* donne [] si le système a des find solutions,
+sinon donne [c,s,lc]
+où lc est la combinaison linéaire des inéquations de départ
+qui donne 0 < c si s=true
+ ou 0 <= c sinon
+cette inéquation étant absurde.
+*)
+(** Tryes to find if the system admits solutions.
+ @param lie the list of inequations
+ @return a list that can be empty if the system has solutions. Otherwise it returns a
+ one elements list [\[(c,s,lc)\]]. {b c} is the rational that can be obtained solving the system,
+ {b s} is true if the inequation that proves that the system is absurd is of type [c < 0], false if
+ [c <= 0], {b lc} is a list of rational that represents the liear combination to obtain the
+ absurd inequation *)
+let unsolvable lie =
+ let lr = deduce lie in
+ let res = ref [] in
+ (try (List.iter (fun e ->
+ match e with
+ {coef=[c];hist=lc;strict=s} ->
+ if (rinf c r0 && (not s)) || (rinfeq c r0 && s)
+ then (res := [c,s,lc];
+ raise (Failure "contradiction found"))
+ |_->assert false)
+ lr)
+ with _ -> ());
+ !res
+;;
+
+(* Exemples:
+
+let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];;
+deduce test1;;
+unsolvable test1;;
+
+let test2=[
+[r1;r1;r0;r0;r0],false;
+[r0;r1;r1;r0;r0],false;
+[r0;r0;r1;r1;r0],false;
+[r0;r0;r0;r1;r1],false;
+[r1;r0;r0;r0;r1],false;
+[rop r1;rop r1;r0;r0;r0],false;
+[r0;rop r1;rop r1;r0;r0],false;
+[r0;r0;rop r1;rop r1;r0],false;
+[r0;r0;r0;rop r1;rop r1],false;
+[rop r1;r0;r0;r0;rop r1],false
+];;
+deduce test2;;
+unsolvable test2;;
+
+*)
--- /dev/null
+type rational = { num : int; den : int; }
+val print_rational : rational -> unit
+val pgcd : int -> int -> int
+val r0 : rational
+val r1 : rational
+val rnorm : rational -> rational
+val rop : rational -> rational
+val rplus : rational -> rational -> rational
+val rminus : rational -> rational -> rational
+val rmult : rational -> rational -> rational
+val rinv : rational -> rational
+val rdiv : rational -> rational -> rational
+val rinf : rational -> rational -> bool
+val rinfeq : rational -> rational -> bool
+type ineq = { coef : rational list; hist : rational list; strict : bool; }
+val pop : 'a -> 'a list ref -> unit
+val partitionne : ineq list -> ineq list list
+val add_hist : (rational list * bool) list -> ineq list
+val ie_add : ineq -> ineq -> ineq
+val ie_emult : rational -> ineq -> ineq
+val ie_tl : ineq -> ineq
+val hd_coef : ineq -> rational
+val deduce_add : ineq list -> ineq list -> ineq list
+val deduce1 : ineq list -> int -> ineq list
+val deduce : (rational list * bool) list -> ineq list
+val unsolvable :
+ (rational list * bool) list -> (rational * bool * rational list) list
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+
+(******************** THE FOURIER TACTIC ***********************)
+
+(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients
+des inéquations et équations sont entiers. En attendant la tactique Field.
+*)
+
+open Fourier
+open ProofEngineTypes
+
+
+let debug x = print_string ("____ "^x) ; flush stdout;;
+
+let debug_pcontext x =
+ let str = ref "" in
+ List.iter (fun y -> match y with Some(Cic.Name(a),_) -> str := !str ^
+ a ^ " " | _ ->()) x ;
+ debug ("contesto : "^ (!str) ^ "\n")
+;;
+
+(******************************************************************************
+Operations on linear combinations.
+
+Opérations sur les combinaisons linéaires affines.
+La partie homogène d'une combinaison linéaire est en fait une table de hash
+qui donne le coefficient d'un terme du calcul des constructions,
+qui est zéro si le terme n'y est pas.
+*)
+
+
+
+(**
+ The type for linear combinations
+*)
+type flin = {fhom:(Cic.term , rational)Hashtbl.t;fcste:rational}
+;;
+
+(**
+ @return an empty flin
+*)
+let flin_zero () = {fhom = Hashtbl.create 50;fcste=r0}
+;;
+
+(**
+ @param f a flin
+ @param x a Cic.term
+ @return the rational associated with x (coefficient)
+*)
+let flin_coef f x =
+ try
+ (Hashtbl.find f.fhom x)
+ with
+ _ -> r0
+;;
+
+(**
+ Adds c to the coefficient of x
+ @param f a flin
+ @param x a Cic.term
+ @param c a rational
+ @return the new flin
+*)
+let flin_add f x c =
+ match x with
+ Cic.Rel(n) ->(
+ let cx = flin_coef f x in
+ Hashtbl.remove f.fhom x;
+ Hashtbl.add f.fhom x (rplus cx c);
+ f)
+ |_->debug ("Internal error in Fourier! this is not a Rel "^CicPp.ppterm x^"\n");
+ let cx = flin_coef f x in
+ Hashtbl.remove f.fhom x;
+ Hashtbl.add f.fhom x (rplus cx c);
+ f
+;;
+(**
+ Adds c to f.fcste
+ @param f a flin
+ @param c a rational
+ @return the new flin
+*)
+let flin_add_cste f c =
+ {fhom=f.fhom;
+ fcste=rplus f.fcste c}
+;;
+
+(**
+ @return a empty flin with r1 in fcste
+*)
+let flin_one () = flin_add_cste (flin_zero()) r1;;
+
+(**
+ Adds two flin
+*)
+let flin_plus f1 f2 =
+ let f3 = flin_zero() in
+ Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
+ Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom;
+ flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste;
+;;
+
+(**
+ Substracts two flin
+*)
+let flin_minus f1 f2 =
+ let f3 = flin_zero() in
+ Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
+ Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom;
+ flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste);
+;;
+
+(**
+ @return a times f
+*)
+let flin_emult a f =
+ let f2 = flin_zero() in
+ Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom;
+ flin_add_cste f2 (rmult a f.fcste);
+;;
+
+
+(*****************************************************************************)
+
+
+(**
+ @param t a term
+ @raise Failure if conversion is impossible
+ @return rational proiection of t
+*)
+let rec rational_of_term t =
+ (* fun to apply f to the first and second rational-term of l *)
+ let rat_of_binop f l =
+ let a = List.hd l and
+ b = List.hd(List.tl l) in
+ f (rational_of_term a) (rational_of_term b)
+ in
+ (* as before, but f is unary *)
+ let rat_of_unop f l =
+ f (rational_of_term (List.hd l))
+ in
+ match t with
+ | Cic.Cast (t1,t2) -> (rational_of_term t1)
+ | Cic.Appl (t1::next) ->
+ (match t1 with
+ Cic.Const (u,boh) ->
+ if UriManager.eq u HelmLibraryObjects.Reals.ropp_URI then
+ rat_of_unop rop next
+ else if UriManager.eq u HelmLibraryObjects.Reals.rinv_URI then
+ rat_of_unop rinv next
+ else if UriManager.eq u HelmLibraryObjects.Reals.rmult_URI then
+ rat_of_binop rmult next
+ else if UriManager.eq u HelmLibraryObjects.Reals.rdiv_URI then
+ rat_of_binop rdiv next
+ else if UriManager.eq u HelmLibraryObjects.Reals.rplus_URI then
+ rat_of_binop rplus next
+ else if UriManager.eq u HelmLibraryObjects.Reals.rminus_URI then
+ rat_of_binop rminus next
+ else failwith "not a rational"
+ | _ -> failwith "not a rational")
+ | Cic.Const (u,boh) ->
+ if UriManager.eq u HelmLibraryObjects.Reals.r1_URI then r1
+ else if UriManager.eq u HelmLibraryObjects.Reals.r0_URI then r0
+ else failwith "not a rational"
+ | _ -> failwith "not a rational"
+;;
+
+(* coq wrapper
+let rational_of_const = rational_of_term;;
+*)
+let fails f a =
+ try
+ ignore (f a);
+ false
+ with
+ _-> true
+ ;;
+
+let rec flin_of_term t =
+ let fl_of_binop f l =
+ let a = List.hd l and
+ b = List.hd(List.tl l) in
+ f (flin_of_term a) (flin_of_term b)
+ in
+ try(
+ match t with
+ | Cic.Cast (t1,t2) -> (flin_of_term t1)
+ | Cic.Appl (t1::next) ->
+ begin
+ match t1 with
+ Cic.Const (u,boh) ->
+ begin
+ if UriManager.eq u HelmLibraryObjects.Reals.ropp_URI then
+ flin_emult (rop r1) (flin_of_term (List.hd next))
+ else if UriManager.eq u HelmLibraryObjects.Reals.rplus_URI then
+ fl_of_binop flin_plus next
+ else if UriManager.eq u HelmLibraryObjects.Reals.rminus_URI then
+ fl_of_binop flin_minus next
+ else if UriManager.eq u HelmLibraryObjects.Reals.rmult_URI then
+ begin
+ let arg1 = (List.hd next) and
+ arg2 = (List.hd(List.tl next))
+ in
+ if fails rational_of_term arg1
+ then
+ if fails rational_of_term arg2
+ then
+ ( (* prodotto tra 2 incognite ????? impossibile*)
+ failwith "Sistemi lineari!!!!\n"
+ )
+ else
+ (
+ match arg1 with
+ Cic.Rel(n) -> (*trasformo al volo*)
+ (flin_add (flin_zero()) arg1 (rational_of_term arg2))
+ |_-> (* test this *)
+ let tmp = flin_of_term arg1 in
+ flin_emult (rational_of_term arg2) (tmp)
+ )
+ else
+ if fails rational_of_term arg2
+ then
+ (
+ match arg2 with
+ Cic.Rel(n) -> (*trasformo al volo*)
+ (flin_add (flin_zero()) arg2 (rational_of_term arg1))
+ |_-> (* test this *)
+ let tmp = flin_of_term arg2 in
+ flin_emult (rational_of_term arg1) (tmp)
+
+ )
+ else
+ ( (*prodotto tra razionali*)
+ (flin_add_cste (flin_zero()) (rmult (rational_of_term arg1) (rational_of_term arg2)))
+ )
+ (*try
+ begin
+ (*let a = rational_of_term arg1 in
+ debug("ho fatto rational of term di "^CicPp.ppterm arg1^
+ " e ho ottenuto "^string_of_int a.num^"/"^string_of_int a.den^"\n");*)
+ let a = flin_of_term arg1
+ try
+ begin
+ let b = (rational_of_term arg2) in
+ debug("ho fatto rational of term di "^CicPp.ppterm arg2^
+ " e ho ottenuto "^string_of_int b.num^"/"^string_of_int b.den^"\n");
+ (flin_add_cste (flin_zero()) (rmult a b))
+ end
+ with
+ _ -> debug ("ho fallito2 su "^CicPp.ppterm arg2^"\n");
+ (flin_add (flin_zero()) arg2 a)
+ end
+ with
+ _-> debug ("ho fallito1 su "^CicPp.ppterm arg1^"\n");
+ (flin_add(flin_zero()) arg1 (rational_of_term arg2))
+ *)
+ end
+ else if UriManager.eq u HelmLibraryObjects.Reals.rinv_URI then
+ let a=(rational_of_term (List.hd next)) in
+ flin_add_cste (flin_zero()) (rinv a)
+ else if UriManager.eq u HelmLibraryObjects.Reals.rdiv_URI then
+ begin
+ let b=(rational_of_term (List.hd(List.tl next))) in
+ try
+ begin
+ let a = (rational_of_term (List.hd next)) in
+ (flin_add_cste (flin_zero()) (rdiv a b))
+ end
+ with
+ _-> (flin_add (flin_zero()) (List.hd next) (rinv b))
+ end
+ else assert false
+ end
+ |_ -> assert false
+ end
+ | Cic.Const (u,boh) ->
+ begin
+ if UriManager.eq u HelmLibraryObjects.Reals.r1_URI then flin_one ()
+ else if UriManager.eq u HelmLibraryObjects.Reals.r0_URI then flin_zero ()
+ else assert false
+ end
+ |_-> assert false)
+ with _ -> debug("eccezione = "^CicPp.ppterm t^"\n");flin_add (flin_zero()) t r1
+;;
+
+(* coq wrapper
+let flin_of_constr = flin_of_term;;
+*)
+
+(**
+ Translates a flin to (c,x) list
+ @param f a flin
+ @return something like (c1,x1)::(c2,x2)::...::(cn,xn)
+*)
+let flin_to_alist f =
+ let res=ref [] in
+ Hashtbl.iter (fun x c -> res:=(c,x)::(!res)) f;
+ !res
+;;
+
+(* Représentation des hypothèses qui sont des inéquations ou des équations.
+*)
+
+(**
+ The structure for ineq
+*)
+type hineq={hname:Cic.term; (* le nom de l'hypothèse *)
+ htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *)
+ hleft:Cic.term;
+ hright:Cic.term;
+ hflin:flin;
+ hstrict:bool}
+;;
+
+(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0
+*)
+
+let ineq1_of_term (h,t) =
+ match t with (* match t *)
+ Cic.Appl (t1::next) ->
+ let arg1= List.hd next in
+ let arg2= List.hd(List.tl next) in
+ (match t1 with (* match t1 *)
+ Cic.Const (u,boh) ->
+ if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI then
+ [{hname=h;
+ htype="Rlt";
+ hleft=arg1;
+ hright=arg2;
+ hflin= flin_minus (flin_of_term arg1)
+ (flin_of_term arg2);
+ hstrict=true}]
+ else if UriManager.eq u HelmLibraryObjects.Reals.rgt_URI then
+ [{hname=h;
+ htype="Rgt";
+ hleft=arg2;
+ hright=arg1;
+ hflin= flin_minus (flin_of_term arg2)
+ (flin_of_term arg1);
+ hstrict=true}]
+ else if UriManager.eq u HelmLibraryObjects.Reals.rle_URI then
+ [{hname=h;
+ htype="Rle";
+ hleft=arg1;
+ hright=arg2;
+ hflin= flin_minus (flin_of_term arg1)
+ (flin_of_term arg2);
+ hstrict=false}]
+ else if UriManager.eq u HelmLibraryObjects.Reals.rge_URI then
+ [{hname=h;
+ htype="Rge";
+ hleft=arg2;
+ hright=arg1;
+ hflin= flin_minus (flin_of_term arg2)
+ (flin_of_term arg1);
+ hstrict=false}]
+ else assert false
+ | Cic.MutInd (u,i,o) ->
+ if UriManager.eq u HelmLibraryObjects.Logic.eq_URI then
+ let t0= arg1 in
+ let arg1= arg2 in
+ let arg2= List.hd(List.tl (List.tl next)) in
+ (match t0 with
+ Cic.Const (u,boh) ->
+ if UriManager.eq u HelmLibraryObjects.Reals.r_URI then
+ [{hname=h;
+ htype="eqTLR";
+ hleft=arg1;
+ hright=arg2;
+ hflin= flin_minus (flin_of_term arg1)
+ (flin_of_term arg2);
+ hstrict=false};
+ {hname=h;
+ htype="eqTRL";
+ hleft=arg2;
+ hright=arg1;
+ hflin= flin_minus (flin_of_term arg2)
+ (flin_of_term arg1);
+ hstrict=false}]
+ else assert false
+ |_-> assert false)
+ else assert false
+ |_-> assert false)(* match t1 *)
+ |_-> assert false (* match t *)
+;;
+(* coq wrapper
+let ineq1_of_constr = ineq1_of_term;;
+*)
+
+(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq)
+*)
+
+let rec print_rl l =
+ match l with
+ []-> ()
+ | a::next -> Fourier.print_rational a ; print_string " " ; print_rl next
+;;
+
+let rec print_sys l =
+ match l with
+ [] -> ()
+ | (a,b)::next -> (print_rl a;
+ print_string (if b=true then "strict\n"else"\n");
+ print_sys next)
+ ;;
+
+(*let print_hash h =
+ Hashtbl.iter (fun x y -> print_string ("("^"-"^","^"-"^")")) h
+;;*)
+
+let fourier_lineq lineq1 =
+ let nvar=ref (-1) in
+ let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *)
+ List.iter (fun f ->
+ Hashtbl.iter (fun x c ->
+ try (Hashtbl.find hvar x;())
+ with _-> nvar:=(!nvar)+1;
+ Hashtbl.add hvar x (!nvar);
+ debug("aggiungo una var "^
+ string_of_int !nvar^" per "^
+ CicPp.ppterm x^"\n"))
+ f.hflin.fhom)
+ lineq1;
+ (*print_hash hvar;*)
+ debug("Il numero di incognite e' "^string_of_int (!nvar+1)^"\n");
+ let sys= List.map (fun h->
+ let v=Array.create ((!nvar)+1) r0 in
+ Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x) <- c)
+ h.hflin.fhom;
+ ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict))
+ lineq1 in
+ debug ("chiamo unsolvable sul sistema di "^
+ string_of_int (List.length sys) ^"\n");
+ print_sys sys;
+ unsolvable sys
+;;
+
+(*****************************************************************************
+Construction de la preuve en cas de succès de la méthode de Fourier,
+i.e. on obtient une contradiction.
+*)
+
+
+let _eqT = Cic.MutInd(HelmLibraryObjects.Logic.eq_URI, 0, []) ;;
+let _False = Cic.MutInd (HelmLibraryObjects.Logic.false_URI, 0, []) ;;
+let _not = Cic.Const (HelmLibraryObjects.Logic.not_URI,[]);;
+let _R0 = Cic.Const (HelmLibraryObjects.Reals.r0_URI,[]);;
+let _R1 = Cic.Const (HelmLibraryObjects.Reals.r1_URI,[]);;
+let _R = Cic.Const (HelmLibraryObjects.Reals.r_URI,[]);;
+let _Rfourier_eqLR_to_le=Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_eqLR_to_le.con"), []) ;;
+let _Rfourier_eqRL_to_le=Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_eqRL_to_le.con"), []) ;;
+let _Rfourier_ge_to_le =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_ge_to_le.con"), []) ;;
+let _Rfourier_gt_to_lt =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_gt_to_lt.con"), []) ;;
+let _Rfourier_le=Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_le.con"), []) ;;
+let _Rfourier_le_le =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_le_le.con"), []) ;;
+let _Rfourier_le_lt =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_le_lt.con"), []) ;;
+let _Rfourier_lt=Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_lt.con"), []) ;;
+let _Rfourier_lt_le =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_lt_le.con"), []) ;;
+let _Rfourier_lt_lt =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_lt_lt.con"), []) ;;
+let _Rfourier_not_ge_lt = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_not_ge_lt.con"), []) ;;
+let _Rfourier_not_gt_le = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_not_gt_le.con"), []) ;;
+let _Rfourier_not_le_gt = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_not_le_gt.con"), []) ;;
+let _Rfourier_not_lt_ge = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_not_lt_ge.con"), []) ;;
+let _Rinv = Cic.Const (HelmLibraryObjects.Reals.rinv_URI, []);;
+let _Rinv_R1 = Cic.Const(HelmLibraryObjects.Reals.rinv_r1_URI, []);;
+let _Rle = Cic.Const (HelmLibraryObjects.Reals.rle_URI, []);;
+let _Rle_mult_inv_pos = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rle_mult_inv_pos.con"), []) ;;
+let _Rle_not_lt = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rle_not_lt.con"), []) ;;
+let _Rle_zero_1 = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rle_zero_1.con"), []) ;;
+let _Rle_zero_pos_plus1 = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rle_zero_pos_plus1.con"), []) ;;
+let _Rlt = Cic.Const (HelmLibraryObjects.Reals.rlt_URI, []);;
+let _Rlt_mult_inv_pos = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rlt_mult_inv_pos.con"), []) ;;
+let _Rlt_not_le = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rlt_not_le.con"), []) ;;
+let _Rlt_zero_1 = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rlt_zero_1.con"), []) ;;
+let _Rlt_zero_pos_plus1 = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rlt_zero_pos_plus1.con"), []) ;;
+let _Rminus = Cic.Const (HelmLibraryObjects.Reals.rminus_URI, []);;
+let _Rmult = Cic.Const (HelmLibraryObjects.Reals.rmult_URI, []);;
+let _Rnot_le_le =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rnot_le_le.con"), []) ;;
+let _Rnot_lt0 = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rnot_lt0.con"), []) ;;
+let _Rnot_lt_lt =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rnot_lt_lt.con"), []) ;;
+let _Ropp = Cic.Const (HelmLibraryObjects.Reals.ropp_URI, []);;
+let _Rplus = Cic.Const (HelmLibraryObjects.Reals.rplus_URI, []);;
+
+(******************************************************************************)
+
+let is_int x = (x.den)=1
+;;
+
+(* fraction = couple (num,den) *)
+let rec rational_to_fraction x= (x.num,x.den)
+;;
+
+(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1)))
+*)
+
+let rec int_to_real_aux n =
+ match n with
+ 0 -> _R0 (* o forse R0 + R0 ????? *)
+ | 1 -> _R1
+ | _ -> Cic.Appl [ _Rplus ; _R1 ; int_to_real_aux (n-1) ]
+;;
+
+
+let int_to_real n =
+ let x = int_to_real_aux (abs n) in
+ if n < 0 then
+ Cic.Appl [ _Ropp ; x ]
+ else
+ x
+;;
+
+
+(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1)))
+*)
+
+let rational_to_real x =
+ let (n,d)=rational_to_fraction x in
+ Cic.Appl [ _Rmult ; int_to_real n ; Cic.Appl [ _Rinv ; int_to_real d ] ]
+;;
+
+(* preuve que 0<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 (apply_tactic (PrimitiveTactics.apply_tac ~term:_Rle_not_lt)))
+ ~continuation:(tac_zero_infeq_pos gl (-n,d)))
+ status
+ in
+ mk_tactic (tac_zero_inf_false gl (n,d))
+;;
+
+(* preuve que 0<=n*(1/d) => False ; n est negatif
+*)
+
+let tac_zero_infeq_false gl (n,d) =
+ let tac_zero_infeq_false gl (n,d) status =
+ let (proof, goal) = status in
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+
+ debug("faccio fold di " ^ CicPp.ppterm
+ (Cic.Appl
+ [_Rle ; _R0 ;
+ Cic.Appl
+ [_Rmult ; int_to_real n ; Cic.Appl [_Rinv ; int_to_real d]]
+ ]
+ ) ^ "\n") ;
+ debug("apply di _Rlt_not_le a "^ CicPp.ppterm ty ^"\n");
+ (*CSC: Patch to undo the over-simplification of RewriteSimpl *)
+ apply_tactic
+ (Tacticals.then_
+ ~start:
+ (ReductionTactics.fold_tac
+ ~reduction:(const_lazy_reduction CicReduction.whd)
+ ~pattern:(ProofEngineTypes.conclusion_pattern None)
+ ~term:
+ (const_lazy_term
+ (Cic.Appl
+ [_Rle ; _R0 ;
+ Cic.Appl
+ [_Rmult ; int_to_real n ; Cic.Appl [_Rinv ; int_to_real d]]])))
+ ~continuation:
+ (Tacticals.then_
+ ~start:(PrimitiveTactics.apply_tac ~term:_Rlt_not_le)
+ ~continuation:(tac_zero_inf_pos (-n,d))))
+ status
+ in
+ mk_tactic (tac_zero_infeq_false gl (n,d))
+;;
+
+
+(* *********** ********** ******** ??????????????? *********** **************)
+
+let apply_type_tac ~cast:t ~applist:al =
+ let apply_type_tac ~cast:t ~applist:al (proof,goal) =
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context in
+ let metasenv' = (fresh_meta,context,t)::metasenv in
+ let proof' = curi,metasenv',pbo,pty in
+ let proof'',goals =
+ apply_tactic
+ (PrimitiveTactics.apply_tac
+ (*~term:(Cic.Appl ((Cic.Cast (Cic.Meta (fresh_meta,irl),t))::al)) *)
+ ~term:(Cic.Appl ((Cic.Meta (fresh_meta,irl))::al))) (* ??? *)
+ (proof',goal)
+ in
+ proof'',fresh_meta::goals
+ in
+ mk_tactic (apply_type_tac ~cast:t ~applist:al)
+;;
+
+let my_cut ~term:c =
+ let my_cut ~term:c (proof,goal) =
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context in
+ let metasenv' = (fresh_meta,context,c)::metasenv in
+ let proof' = curi,metasenv',pbo,pty in
+ let proof'',goals =
+ apply_tactic
+ (apply_type_tac
+ ~cast:(Cic.Prod(Cic.Name "Anonymous",c,CicSubstitution.lift 1 ty))
+ ~applist:[Cic.Meta(fresh_meta,irl)])
+ (proof',goal)
+ in
+ (* We permute the generated goals to be consistent with Coq *)
+ match goals with
+ [] -> assert false
+ | he::tl -> proof'',he::fresh_meta::tl
+ in
+ mk_tactic (my_cut ~term:c)
+;;
+
+let exact = PrimitiveTactics.exact_tac;;
+
+let tac_use h =
+ let tac_use h status =
+ let (proof, goal) = status in
+ debug("Inizio TC_USE\n");
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ debug ("hname = "^ CicPp.ppterm h.hname ^"\n");
+ debug ("ty = "^ CicPp.ppterm ty^"\n");
+ apply_tactic
+ (match h.htype with
+ "Rlt" -> exact ~term:h.hname
+ | "Rle" -> exact ~term:h.hname
+ | "Rgt" -> (Tacticals.then_
+ ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_gt_to_lt)
+ ~continuation:(exact ~term:h.hname))
+ | "Rge" -> (Tacticals.then_
+ ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_ge_to_le)
+ ~continuation:(exact ~term:h.hname))
+ | "eqTLR" -> (Tacticals.then_
+ ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_eqLR_to_le)
+ ~continuation:(exact ~term:h.hname))
+ | "eqTRL" -> (Tacticals.then_
+ ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_eqRL_to_le)
+ ~continuation:(exact ~term:h.hname))
+ | _->assert false)
+ status
+ in
+ mk_tactic (tac_use h)
+;;
+
+let is_ineq (h,t) =
+ match t with
+ Cic.Appl ( Cic.Const(u,boh)::next) ->
+ (if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI or
+ UriManager.eq u HelmLibraryObjects.Reals.rgt_URI or
+ UriManager.eq u HelmLibraryObjects.Reals.rle_URI or
+ UriManager.eq u HelmLibraryObjects.Reals.rge_URI then true
+ else if UriManager.eq u HelmLibraryObjects.Logic.eq_URI then
+ (match (List.hd next) with
+ Cic.Const (uri,_) when
+ UriManager.eq uri HelmLibraryObjects.Reals.r_URI
+ -> true
+ | _ -> false)
+ else false)
+ |_->false
+;;
+
+let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;;
+
+let mkAppL a =
+ Cic.Appl(Array.to_list a)
+;;
+
+(* Résolution d'inéquations linéaires dans R *)
+let rec strip_outer_cast c = match c with
+ | Cic.Cast (c,_) -> strip_outer_cast c
+ | _ -> c
+;;
+
+(*let find_in_context id context =
+ let rec find_in_context_aux c n =
+ match c with
+ [] -> failwith (id^" not found in context")
+ | a::next -> (match a with
+ Some (Cic.Name(name),_) when name = id -> n
+ (*? magari al posto di _ qualcosaltro?*)
+ | _ -> find_in_context_aux next (n+1))
+ in
+ find_in_context_aux context 1
+;;
+
+(* mi sembra quadratico *)
+let rec filter_real_hyp context cont =
+ match context with
+ [] -> []
+ | Some(Cic.Name(h),Cic.Decl(t))::next -> (
+ let n = find_in_context h cont in
+ debug("assegno "^string_of_int n^" a "^CicPp.ppterm t^"\n");
+ [(Cic.Rel(n),t)] @ filter_real_hyp next cont)
+ | a::next -> debug(" no\n"); filter_real_hyp next cont
+;;*)
+
+let filter_real_hyp context _ =
+ let rec filter_aux context num =
+ match context with
+ [] -> []
+ | Some(Cic.Name(h),Cic.Decl(t))::next ->
+ [(Cic.Rel(num),t)] @ filter_aux next (num+1)
+ | a::next -> filter_aux next (num+1)
+ in
+ filter_aux context 1
+;;
+
+
+(* lifts everithing at the conclusion level *)
+let rec superlift c n=
+ match c with
+ [] -> []
+ | Some(name,Cic.Decl(a))::next ->
+ [Some(name,Cic.Decl(CicSubstitution.lift n a))]@ superlift next (n+1)
+ | Some(name,Cic.Def(a,None))::next ->
+ [Some(name,Cic.Def((CicSubstitution.lift n a),None))]@ superlift next (n+1)
+ | Some(name,Cic.Def(a,Some ty))::next ->
+ [Some(name,
+ Cic.Def((CicSubstitution.lift n a),Some (CicSubstitution.lift n ty)))
+ ] @ superlift next (n+1)
+ | _::next -> superlift next (n+1) (*?? ??*)
+
+;;
+
+let equality_replace a b =
+ let equality_replace a b status =
+ debug("inizio EQ\n");
+ let module C = Cic in
+ let proof,goal = status in
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ let a_eq_b = C.Appl [ _eqT ; _R ; a ; b ] in
+ let fresh_meta = ProofEngineHelpers.new_meta_of_proof proof in
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context in
+ let metasenv' = (fresh_meta,context,a_eq_b)::metasenv in
+ debug("chamo rewrite tac su"^CicPp.ppterm (C.Meta (fresh_meta,irl)));
+ let (proof,goals) = apply_tactic
+ (EqualityTactics.rewrite_simpl_tac
+ ~direction:`LeftToRight
+ ~pattern:(ProofEngineTypes.conclusion_pattern None)
+ (C.Meta (fresh_meta,irl)))
+ ((curi,metasenv',pbo,pty),goal)
+ in
+ let new_goals = fresh_meta::goals in
+ debug("fine EQ -> goals : "^string_of_int( List.length new_goals) ^" = "
+ ^string_of_int( List.length goals)^"+ meta\n");
+ (proof,new_goals)
+ in
+ mk_tactic (equality_replace a b)
+;;
+
+let tcl_fail a (proof,goal) =
+ match a with
+ 1 -> raise (ProofEngineTypes.Fail (lazy "fail-tactical"))
+ | _ -> (proof,[goal])
+;;
+
+(* Galla: moved in variousTactics.ml
+let assumption_tac (proof,goal)=
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ let num = ref 0 in
+ let tac_list = List.map
+ ( fun x -> num := !num + 1;
+ match x with
+ Some(Cic.Name(nm),t) -> (nm,exact ~term:(Cic.Rel(!num)))
+ | _ -> ("fake",tcl_fail 1)
+ )
+ context
+ in
+ Tacticals.first ~tactics:tac_list (proof,goal)
+;;
+*)
+(* Galla: moved in negationTactics.ml
+(* !!!!! fix !!!!!!!!!! *)
+let contradiction_tac (proof,goal)=
+ Tacticals.then_
+ (*inutile sia questo che quello prima della chiamata*)
+ ~start:PrimitiveTactics.intros_tac
+ ~continuation:(Tacticals.then_
+ ~start:(VariousTactics.elim_type_tac ~term:_False)
+ ~continuation:(assumption_tac))
+ (proof,goal)
+;;
+*)
+
+(* ********************* TATTICA ******************************** *)
+
+let rec fourier (s_proof,s_goal)=
+ let s_curi,s_metasenv,s_pbo,s_pty = s_proof in
+ let s_metano,s_context,s_ty = CicUtil.lookup_meta s_goal s_metasenv in
+ debug ("invoco fourier_tac sul goal "^string_of_int(s_goal)^" e contesto:\n");
+ debug_pcontext s_context;
+
+(* here we need to negate the thesis, but to do this we need to apply the
+ right theoreme,so let's parse our thesis *)
+
+ let th_to_appl = ref _Rfourier_not_le_gt in
+ (match s_ty with
+ Cic.Appl ( Cic.Const(u,boh)::args) ->
+ th_to_appl :=
+ (if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI then
+ _Rfourier_not_ge_lt
+ else if UriManager.eq u HelmLibraryObjects.Reals.rle_URI then
+ _Rfourier_not_gt_le
+ else if UriManager.eq u HelmLibraryObjects.Reals.rgt_URI then
+ _Rfourier_not_le_gt
+ else if UriManager.eq u HelmLibraryObjects.Reals.rge_URI then
+ _Rfourier_not_lt_ge
+ else failwith "fourier can't be applyed")
+ |_-> failwith "fourier can't be applyed");
+ (* fix maybe strip_outer_cast goes here?? *)
+
+ (* now let's change our thesis applying the th and put it with hp *)
+
+ let proof,gl = apply_tactic
+ (Tacticals.then_
+ ~start:(PrimitiveTactics.apply_tac ~term:!th_to_appl)
+ ~continuation:(PrimitiveTactics.intros_tac ()))
+ (s_proof,s_goal)
+ in
+ let goal = if List.length gl = 1 then List.hd gl
+ else failwith "a new goal" in
+
+ debug ("port la tesi sopra e la nego. contesto :\n");
+ debug_pcontext s_context;
+
+ (* now we have all the right environment *)
+
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+
+ (* now we want to convert hp to inequations, but first we must lift
+ everyting to thesis level, so that a variable has the save Rel(n)
+ in each hp ( needed by ineq1_of_term ) *)
+
+ (* ? fix if None ?????*)
+ (* fix change superlift with a real name *)
+
+ let l_context = superlift context 1 in
+ let hyps = filter_real_hyp l_context l_context in
+
+ debug ("trasformo in diseq. "^ string_of_int (List.length hyps)^" ipotesi\n");
+
+ let lineq =ref [] in
+
+ (* transform hyps into inequations *)
+
+ List.iter (fun h -> try (lineq:=(ineq1_of_term h)@(!lineq))
+ with _-> ())
+ hyps;
+
+ debug ("applico fourier a "^ string_of_int (List.length !lineq)^
+ " disequazioni\n");
+
+ let res=fourier_lineq (!lineq) in
+ let tac=ref Tacticals.id_tac in
+ if res=[] then
+ (print_string "Tactic Fourier fails.\n";flush stdout;
+ failwith "fourier_tac fails")
+ else
+ (
+ match res with (*match res*)
+ [(cres,sres,lc)]->
+
+ (* in lc we have the coefficient to "reduce" the system *)
+
+ print_string "Fourier's method can prove the goal...\n";flush stdout;
+
+ debug "I coeff di moltiplicazione rit sono: ";
+
+ let lutil=ref [] in
+ List.iter
+ (fun (h,c) -> if c<>r0 then (lutil:=(h,c)::(!lutil);
+ (* DBG *)Fourier.print_rational(c);print_string " "(* DBG *))
+ )
+ (List.combine (!lineq) lc);
+
+ print_string (" quindi lutil e' lunga "^
+ string_of_int (List.length (!lutil))^"\n");
+
+ (* on construit la combinaison linéaire des inéquation *)
+
+ (match (!lutil) with (*match (!lutil) *)
+ (h1,c1)::lutil ->
+ debug ("elem di lutil ");Fourier.print_rational c1;print_string "\n";
+
+ let s=ref (h1.hstrict) in
+
+
+ let t1 = ref (Cic.Appl [_Rmult;rational_to_real c1;h1.hleft] ) in
+ let t2 = ref (Cic.Appl [_Rmult;rational_to_real c1;h1.hright]) in
+
+ List.iter (fun (h,c) ->
+ s:=(!s)||(h.hstrict);
+ t1:=(Cic.Appl [_Rplus;!t1;Cic.Appl
+ [_Rmult;rational_to_real c;h.hleft ] ]);
+ t2:=(Cic.Appl [_Rplus;!t2;Cic.Appl
+ [_Rmult;rational_to_real c;h.hright] ]))
+ lutil;
+
+ let ineq=Cic.Appl [(if (!s) then _Rlt else _Rle);!t1;!t2 ] in
+ let tc=rational_to_real cres in
+
+
+(* ora ho i termini che descrivono i passi di fourier per risolvere il sistema *)
+
+ debug "inizio a costruire tac1\n";
+ Fourier.print_rational(c1);
+
+ let tac1=ref ( mk_tactic (fun status ->
+ apply_tactic
+ (if h1.hstrict then
+ (Tacticals.thens
+ ~start:(mk_tactic (fun status ->
+ debug ("inizio t1 strict\n");
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ debug ("th = "^ CicPp.ppterm _Rfourier_lt ^"\n");
+ debug ("ty = "^ CicPp.ppterm ty^"\n");
+ apply_tactic
+ (PrimitiveTactics.apply_tac ~term:_Rfourier_lt) status))
+ ~continuations:[tac_use h1;
+ tac_zero_inf_pos (rational_to_fraction c1)])
+ else
+ (Tacticals.thens
+ ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_le)
+ ~continuations:[tac_use h1;tac_zero_inf_pos
+ (rational_to_fraction c1)]))
+ status))
+
+ in
+ s:=h1.hstrict;
+ List.iter (fun (h,c) ->
+ (if (!s) then
+ (if h.hstrict then
+ (debug("tac1 1\n");
+ tac1:=(Tacticals.thens
+ ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_lt_lt)
+ ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
+ (rational_to_fraction c)]))
+ else
+ (debug("tac1 2\n");
+ Fourier.print_rational(c1);
+ tac1:=(Tacticals.thens
+ ~start:(mk_tactic (fun status ->
+ debug("INIZIO TAC 1 2\n");
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ debug ("th = "^ CicPp.ppterm _Rfourier_lt_le ^"\n");
+ debug ("ty = "^ CicPp.ppterm ty^"\n");
+ apply_tactic
+ (PrimitiveTactics.apply_tac ~term:_Rfourier_lt_le)
+ status))
+ ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
+ (rational_to_fraction c)])))
+ else
+ (if h.hstrict then
+ (debug("tac1 3\n");
+ tac1:=(Tacticals.thens
+ ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_le_lt)
+ ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
+ (rational_to_fraction c)]))
+ else
+ (debug("tac1 4\n");
+ tac1:=(Tacticals.thens
+ ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_le_le)
+ ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
+ (rational_to_fraction c)]))));
+ s:=(!s)||(h.hstrict)) (* end fun -> *)
+ lutil;(*end List.iter*)
+
+ let tac2 =
+ if sres then
+ tac_zero_inf_false goal (rational_to_fraction cres)
+ else
+ tac_zero_infeq_false goal (rational_to_fraction cres)
+ in
+ tac:=(Tacticals.thens
+ ~start:(my_cut ~term:ineq)
+ ~continuations:[Tacticals.then_
+ ~start:( mk_tactic (fun status ->
+ let (proof, goal) = status in
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ apply_tactic
+ (ReductionTactics.change_tac
+ ~pattern:(ProofEngineTypes.conclusion_pattern (Some ty))
+ (const_lazy_term (Cic.Appl [ _not; ineq])))
+ status))
+ ~continuation:(Tacticals.then_
+ ~start:(PrimitiveTactics.apply_tac ~term:
+ (if sres then _Rnot_lt_lt else _Rnot_le_le))
+ ~continuation:(Tacticals.thens
+ ~start:(mk_tactic (fun status ->
+ debug("t1 ="^CicPp.ppterm !t1 ^"t2 ="^
+ CicPp.ppterm !t2 ^"tc="^ CicPp.ppterm tc^"\n");
+ let r = apply_tactic
+ (equality_replace (Cic.Appl [_Rminus;!t2;!t1] ) tc)
+ status
+ in
+ (match r with (p,gl) ->
+ debug("eq1 ritorna "^string_of_int(List.length gl)^"\n" ));
+ r))
+ ~continuations:[(Tacticals.thens
+ ~start:(mk_tactic (fun status ->
+ let r = apply_tactic
+ (equality_replace (Cic.Appl[_Rinv;_R1]) _R1)
+ status
+ in
+ (match r with (p,gl) ->
+ debug("eq2 ritorna "^string_of_int(List.length gl)^"\n" ));
+ r))
+ ~continuations:
+ [PrimitiveTactics.apply_tac ~term:_Rinv_R1;
+ Tacticals.first
+ ~tactics:[ "ring",Ring.ring_tac; "id", Tacticals.id_tac]
+ ])
+ ;(*Tacticals.id_tac*)
+ Tacticals.then_
+ ~start:(mk_tactic (fun status ->
+ let (proof, goal) = status in
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ (* check if ty is of type *)
+ let w1 =
+ debug("qui c'e' gia' l'or "^CicPp.ppterm ty^"\n");
+ (match ty with
+ Cic.Prod (Cic.Anonymous,a,b) -> (Cic.Appl [_not;a])
+ |_ -> assert false)
+ in
+ let r = apply_tactic
+ (ReductionTactics.change_tac
+ ~pattern:(ProofEngineTypes.conclusion_pattern (Some ty))
+ (const_lazy_term w1)) status
+ in
+ debug("fine MY_CHNGE\n");
+ r))
+ ~continuation:(*PORTINGTacticals.id_tac*)tac2]))
+ ;(*Tacticals.id_tac*)!tac1]);(*end tac:=*)
+
+ |_-> assert false)(*match (!lutil) *)
+ |_-> assert false); (*match res*)
+ debug ("finalmente applico tac\n");
+ (
+ let r = apply_tactic !tac (proof,goal) in
+ debug("\n\n]]]]]]]]]]]]]]]]]) That's all folks ([[[[[[[[[[[[[[[[[[[\n\n");r
+
+ )
+;;
+
+let fourier_tac = mk_tactic fourier
+
+
--- /dev/null
+(*
+val rewrite_tac: term:Cic.term -> ProofEngineTypes.tactic
+val rewrite_simpl_tac: term:Cic.term -> ProofEngineTypes.tactic
+*)
+val fourier_tac: ProofEngineTypes.tactic
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val 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
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*********************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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
+;;
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*********************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Andrea Asperti *)
+(* 8/09/2004 *)
+(* *)
+(* *)
+(*********************************************************************)
+
+
+val not_a_duplicate : UriManager.uri -> bool
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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) ;;
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val constructor_tac: n:int -> ProofEngineTypes.tactic
+
+val exists_tac: ProofEngineTypes.tactic
+val split_tac: ProofEngineTypes.tactic
+val left_tac: ProofEngineTypes.tactic
+val right_tac: ProofEngineTypes.tactic
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+*
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+exception TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple
+exception NotAnInductiveTypeToEliminate
+
+let debug = false;;
+let debug_print =
+ fun msg -> if debug then prerr_endline (Lazy.force msg) else ()
+
+
+let inside_obj = function
+ | Cic.InductiveDefinition (l,params, nleft, _) ->
+ (l,params,nleft)
+ | _ -> raise (Invalid_argument "Errore in inside_obj")
+
+let term_to_list = function
+ | Cic.Appl l -> l
+ | _ -> raise (Invalid_argument "Errore in term_to_list")
+
+
+let rec baseuri_of_term = function
+ | Cic.Appl l -> baseuri_of_term (List.hd l)
+ | Cic.MutInd (baseuri, tyno, []) -> baseuri
+ | _ -> raise (Invalid_argument "baseuri_of_term")
+
+
+(* prende il numero dei parametri sinistri, la lista dei parametri, la lista
+dei tipi dei parametri, il tipo del GOAL e costruisce il termine per la cut
+ossia DX1 = DX1 -> ... DXn=DXn -> GOALTY *)
+
+let rec foo_cut nleft l param_ty_l body uri_of_eq =
+ if nleft > 0 then foo_cut (nleft-1) (List.tl l) (List.tl param_ty_l) body
+ uri_of_eq
+ else match l with
+ | hd::tl -> Cic.Prod (Cic.Anonymous, Cic.Appl[Cic.MutInd (uri_of_eq ,0,[]);
+ (List.hd param_ty_l) ; hd; hd], foo_cut nleft
+ (List.map (CicSubstitution.lift 1) tl) (List.tl param_ty_l)
+ (CicSubstitution.lift 1 body) uri_of_eq )
+ | [] -> body
+ ;;
+
+(* da una catena di prod costruisce una lista dei termini che lo compongono.*)
+let rec list_of_prod term =
+match term with
+ | Cic.Prod (Cic.Anonymous,src,tgt) -> [src] @ (list_of_prod tgt)
+ | _ -> [term]
+;;
+
+
+let rec cut_first n l =
+ if n>0 then
+ match l with
+ | hd::tl -> cut_first (n-1) tl
+ | [] -> []
+ else l
+;;
+
+
+let rec cut_last l =
+match l with
+ | hd::tl when tl != [] -> hd:: (cut_last tl)
+ | _ -> []
+;;
+
+
+let foo_appl nleft nright_consno term uri =
+ let l = [] in
+ let a = ref l in
+ for n = 1 to nleft do
+ a := !a @ [(Cic.Implicit None)]
+ done;
+ a:= !a @ [term];
+ for n = 1 to nright_consno do
+ a := !a @ [(Cic.Implicit None)]
+ done;
+ Cic.Appl ([Cic.Const(uri,[])] @ !a @ [Cic.Rel 1]) (*L'ipotesi e' sempre Rel 1. (?) *)
+;;
+
+
+let rec foo_prod nright param_ty_l l l2 base_rel body uri_of_eq nleft termty
+ isSetType term =
+ match param_ty_l with
+ | hd::tl -> Cic.Prod (
+ Cic.Anonymous,
+ Cic.Appl[Cic.MutInd(uri_of_eq,0,[]); hd; (List.hd l); Cic.Rel base_rel],
+ foo_prod (nright-1) tl (List.map (CicSubstitution.lift 1) (List.tl l))
+ (List.map (CicSubstitution.lift 1) l2)
+ base_rel (CicSubstitution.lift 1 body)
+ uri_of_eq nleft (CicSubstitution.lift 1 termty)
+ isSetType (CicSubstitution.lift 1 term))
+ | [] -> ProofEngineReduction.replace_lifting
+ ~equality:(ProofEngineReduction.alpha_equivalence)
+ ~what: (if isSetType
+ then ((cut_first (1+nleft) (term_to_list termty) ) @ [term] )
+ else (cut_first (1+nleft) (term_to_list termty) ) )
+ ~with_what: (List.map (CicSubstitution.lift (-1)) l2)
+ ~where:body
+(*TODO lo stesso sottotermine di body puo' essere sia sx che dx!*)
+;;
+
+let rec foo_lambda nright param_ty_l nright_ param_ty_l_ l l2 base_rel body
+ uri_of_eq nleft termty isSetType ty_indty term =
+ (*assert nright >0 *)
+ match param_ty_l with
+ | hd::tl ->Cic.Lambda (
+ (Cic.Name ("lambda" ^ (string_of_int nright))),
+ hd, (* typ *)
+ foo_lambda (nright-1) tl nright_ param_ty_l_
+ (List.map (CicSubstitution.lift 1) l)
+ (List.map (CicSubstitution.lift 1) (l2 @ [Cic.Rel 1]))
+ base_rel (CicSubstitution.lift 1 body)
+ uri_of_eq nleft
+ (CicSubstitution.lift 1 termty)
+ isSetType ty_indty
+ (CicSubstitution.lift 1 term))
+ | [] when isSetType -> Cic.Lambda (
+ (Cic.Name ("lambda" ^ (string_of_int nright))),
+ (ProofEngineReduction.replace_lifting
+ ~equality:(ProofEngineReduction.alpha_equivalence)
+ ~what: (cut_first (1+nleft) (term_to_list termty) )
+ ~with_what: (List.map (CicSubstitution.lift (-1)) l2)
+ ~where:termty), (* tipo di H con i parametri destri sostituiti *)
+ foo_prod nright_ param_ty_l_ (List.map (CicSubstitution.lift 1) l)
+ (List.map (CicSubstitution.lift 1) (l2 @ [Cic.Rel 1]))
+ (base_rel+1) (CicSubstitution.lift 1 body)
+ uri_of_eq nleft
+ (CicSubstitution.lift 1 termty) isSetType
+ (CicSubstitution.lift 1 term))
+ | [] -> foo_prod nright_ param_ty_l_ l l2 base_rel body uri_of_eq nleft
+ termty isSetType term
+;;
+
+let inversion_tac ~term =
+ let module T = CicTypeChecker in
+ let module R = CicReduction in
+ let module C = Cic in
+ let module P = PrimitiveTactics in
+ let module PET = ProofEngineTypes in
+ let module PEH = ProofEngineHelpers in
+ let inversion_tac ~term (proof, goal) =
+ let (_,metasenv,_,_) = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ let uri_of_eq = HelmLibraryObjects.Logic.eq_URI in
+
+ (* dall'indice che indentifica il goal nel metasenv, ritorna il suo tipo, che
+ e' la terza componente della relativa congettura *)
+ let (_,_,body) = CicUtil.lookup_meta goal metasenv in
+ (* estrae il tipo del termine(ipotesi) oggetto di inversion,
+ di solito un Cic.Appl *)
+ let termty,_ = T.type_of_aux' metasenv context term CicUniv.empty_ugraph in
+ let uri = baseuri_of_term termty in
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ let l,params,nleft = inside_obj o in
+ let (_,_,typeno,_) =
+ match termty with
+ C.MutInd (uri,typeno,exp_named_subst) -> (uri,exp_named_subst,typeno,[])
+ | C.Appl ((C.MutInd (uri,typeno,exp_named_subst))::args) ->
+ (uri,exp_named_subst,typeno,args)
+ | _ -> raise NotAnInductiveTypeToEliminate
+ in
+ let eliminator_uri =
+ let buri = UriManager.buri_of_uri uri in
+ let name =
+ match o with
+ C.InductiveDefinition (tys,_,_,_) ->
+ let (name,_,_,_) = List.nth tys typeno in
+ name
+ |_ -> assert false
+ in
+ let ext = "_ind" in
+ UriManager.uri_of_string (buri ^ "/" ^ name ^ ext ^ ".con")
+ in
+ (* il tipo del tipo induttivo da cui viene l'ipotesi oggetto di inversione *)
+ let (_,_,ty_indty,cons_list) = (List.hd l) in
+ (*la lista di Cic.term ricavata dal tipo del tipo induttivo. *)
+ let param_ty_l = list_of_prod ty_indty in
+ let consno = List.length cons_list in
+ let nright= (List.length param_ty_l)- (nleft+1) in
+ let isSetType = ((Pervasives.compare
+ (List.nth param_ty_l ((List.length param_ty_l)-1))
+ (Cic.Sort Cic.Prop)) != 0)
+ in
+ (* eliminiamo la testa di termty, in quanto e' il nome del predicato e non un parametro.*)
+ let cut_term = foo_cut nleft (List.tl (term_to_list termty))
+ (list_of_prod ty_indty) body uri_of_eq in
+ (* cut DXn=DXn \to GOAL *)
+ let proof1,gl1 = PET.apply_tactic (P.cut_tac cut_term) (proof,goal) in
+ (* apply Hcut ; reflexivity (su tutti i goals aperti da apply_tac) *)
+ let proof2, gl2 = PET.apply_tactic
+ (Tacticals.then_
+ ~start: (P.apply_tac (C.Rel 1)) (* apply Hcut *)
+ ~continuation: (EqualityTactics.reflexivity_tac)
+ ) (proof1, (List.hd gl1))
+ in
+ (* apply (ledx_ind( lambda x. lambda y, ...)) *)
+ let (t1,metasenv,t3,t4) = proof2 in
+ let goal2 = List.hd (List.tl gl1) in
+ let (metano,context,_) = CicUtil.lookup_meta goal2 metasenv in
+ let cut_param_ty_l = (cut_first nleft (cut_last param_ty_l)) in
+ (* la lista dei soli parametri destri *)
+ let l= cut_first (1+nleft) (term_to_list termty) in
+ let lambda_t = foo_lambda nright cut_param_ty_l nright cut_param_ty_l l []
+ nright body uri_of_eq nleft termty isSetType ty_indty term in
+ let t = foo_appl nleft (nright+consno) lambda_t eliminator_uri in
+ debug_print (lazy ("Lambda_t: " ^ (CicPp.ppterm t)));
+ debug_print (lazy ("Term: " ^ (CicPp.ppterm termty)));
+ debug_print (lazy ("Body: " ^ (CicPp.ppterm body)));
+ debug_print (lazy ("Right param: " ^ (CicPp.ppterm (Cic.Appl l))));
+
+ let (ref_t,_,metasenv'',_) = CicRefine.type_of_aux' metasenv context t
+ CicUniv.empty_ugraph
+ in
+ let proof2 = (t1,metasenv'',t3,t4) in
+ let proof3,gl3 = PET.apply_tactic (P.apply_tac ref_t) (proof2, goal2) in
+ let new_goals = ProofEngineHelpers.compare_metasenvs
+ ~oldmetasenv:metasenv ~newmetasenv:metasenv''
+ in
+ let patched_new_goals =
+ let (_,metasenv''',_,_) = proof3 in
+ List.filter (function i -> List.exists (function (j,_,_) -> j=i) metasenv''')
+ new_goals @ gl3
+ in
+ (*prerr_endline ("METASENV: " ^ CicMetaSubst.ppmetasenv metasenv []); DEBUG*)
+ (proof3, patched_new_goals)
+in
+ProofEngineTypes.mk_tactic (inversion_tac ~term)
+;;
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val inversion_tac: term: Cic.term -> ProofEngineTypes.tactic
--- /dev/null
+(* 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)
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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)
+;;
+*)
+
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val absurd_tac: term:Cic.term -> ProofEngineTypes.tactic
+val contradiction_tac: ProofEngineTypes.tactic
+
--- /dev/null
+PACKAGE = dummy
+
+LOCALLINKOPTS = -package helm-cic_disambiguation,helm-content_pres,helm-grafite,helm-grafite_parser,helm-tactics
+
+include ../../../Makefile.defs
+include ../../Makefile.common
+
+all $(PACKAGE).cma :saturate
+ @echo -n
+opt $(PACKAGE).cmxa:saturate.opt
+ @echo -n
+
+saturate: saturate_main.ml $(LIBRARIES)
+ @echo " OCAMLC $<"
+ @$(OCAMLC) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $<
+saturate.opt: saturate_main.ml $(LIBRARIES)
+ @echo " OCAMLOPT $<"
+ @$(OCAMLOPT) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $<
+
+clean:
+ rm -f saturate saturate.opt
+
+
--- /dev/null
+make saturate per compilare l'eseguibile da riga di comando (make saturate.opt per la versione ottimizzata)
+
+./saturate -h per vedere una lista di parametri:
+
+./saturate: unknown option `-h'.
+Usage:
+ -full Enable full mode
+ -f Enable/disable full-reduction strategy (default: enabled)
+ -r Weight-Age equality selection ratio (default: 4)
+ -s symbols-based selection ratio (relative to the weight ratio, default: 0)
+ -c Configuration file (for the db connection)
+ -o Term ordering. Possible values are:
+ kbo: Knuth-Bendix ordering
+ nr-kbo: Non-recursive variant of kbo (default)
+ lpo: Lexicographic path ordering
+ -l Time limit in seconds (default: no limit)
+ -w Maximal width (default: 3)
+ -d Maximal depth (default: 3)
+ -retrieve retrieve only
+ -help Display this list of options
+ --help Display this list of options
+
+
+./saturate -l 10 -demod-equalities
+
+dove -l 10 e` il timeout in secondi.
+
+Il programma legge da standard input il teorema, per esempio
+
+\forall n:nat.n + n = 2 * n
+\forall n:R.n + n = 2 * n
+\forall n:R.n+n=n+n
+
+l'input termina con una riga vuota (quindi basta un doppio invio alla fine)
+
+In output, oltre ai vari messaggi di debug, vengono stampati gli insiemi
+active e passive alla fine dell'esecuzione. Consiglio di redirigere l'output
+su file, per esempio usando tee:
+
+./saturate -l 10 -demod-equalities | tee output.txt
+
+Il formato di stampa e` quello per gli oggetti di tipo equality (usa la
+funzione Inference.string_of_equality)
+
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+module Index = Equality_indexing.DT (* discrimination tree based indexing *)
+(*
+module Index = Equality_indexing.DT (* path tree based indexing *)
+*)
+
+let debug_print = Utils.debug_print;;
+
+(*
+for debugging
+let check_equation env equation msg =
+ let w, proof, (eq_ty, left, right, order), metas, args = equation in
+ let metasenv, context, ugraph = env in
+ let metasenv' = metasenv @ metas in
+ try
+ CicTypeChecker.type_of_aux' metasenv' context left ugraph;
+ CicTypeChecker.type_of_aux' metasenv' context right ugraph;
+ ()
+ with
+ CicUtil.Meta_not_found _ as exn ->
+ begin
+ prerr_endline msg;
+ prerr_endline (CicPp.ppterm left);
+ prerr_endline (CicPp.ppterm right);
+ raise exn
+ end
+*)
+
+type retrieval_mode = Matching | Unification;;
+
+let print_candidates mode term res =
+ let _ =
+ match mode with
+ | Matching ->
+ Printf.printf "| candidates Matching %s\n" (CicPp.ppterm term)
+ | Unification ->
+ Printf.printf "| candidates Unification %s\n" (CicPp.ppterm term)
+ in
+ print_endline
+ (String.concat "\n"
+ (List.map
+ (fun (p, e) ->
+ Printf.sprintf "| (%s, %s)" (Utils.string_of_pos p)
+ (Inference.string_of_equality e))
+ res));
+ print_endline "|";
+;;
+
+
+let indexing_retrieval_time = ref 0.;;
+
+
+let apply_subst = CicMetaSubst.apply_subst
+
+let index = Index.index
+let remove_index = Index.remove_index
+let in_index = Index.in_index
+let empty = Index.empty
+let init_index = Index.init_index
+
+(* returns a list of all the equalities in the tree that are in relation
+ "mode" with the given term, where mode can be either Matching or
+ Unification.
+
+ Format of the return value: list of tuples in the form:
+ (position - Left or Right - of the term that matched the given one in this
+ equality,
+ equality found)
+
+ Note that if equality is "left = right", if the ordering is left > right,
+ the position will always be Left, and if the ordering is left < right,
+ position will be Right.
+*)
+let get_candidates mode tree term =
+ let t1 = Unix.gettimeofday () in
+ let res =
+ let s =
+ match mode with
+ | Matching -> Index.retrieve_generalizations tree term
+ | Unification -> Index.retrieve_unifiables tree term
+ in
+ Index.PosEqSet.elements s
+ in
+ (* print_candidates mode term res; *)
+(* print_endline (Discrimination_tree.string_of_discrimination_tree tree); *)
+(* print_newline (); *)
+ let t2 = Unix.gettimeofday () in
+ indexing_retrieval_time := !indexing_retrieval_time +. (t2 -. t1);
+ res
+;;
+
+
+let match_unif_time_ok = ref 0.;;
+let match_unif_time_no = ref 0.;;
+
+
+(*
+ finds the first equality in the index that matches "term", of type "termty"
+ termty can be Implicit if it is not needed. The result (one of the sides of
+ the equality, actually) should be not greater (wrt the term ordering) than
+ term
+
+ Format of the return value:
+
+ (term to substitute, [Cic.Rel 1 properly lifted - see the various
+ build_newtarget functions inside the various
+ demodulation_* functions]
+ substitution used for the matching,
+ metasenv,
+ ugraph, [substitution, metasenv and ugraph have the same meaning as those
+ returned by CicUnification.fo_unif]
+ (equality where the matching term was found, [i.e. the equality to use as
+ rewrite rule]
+ uri [either eq_ind_URI or eq_ind_r_URI, depending on the direction of
+ the equality: this is used to build the proof term, again see one of
+ the build_newtarget functions]
+ ))
+*)
+let rec find_matches metasenv context ugraph lift_amount term termty =
+ let module C = Cic in
+ let module U = Utils in
+ let module S = CicSubstitution in
+ let module M = CicMetaSubst in
+ let module HL = HelmLibraryObjects in
+ let cmp = !Utils.compare_terms in
+ let check = match termty with C.Implicit None -> false | _ -> true in
+ function
+ | [] -> None
+ | candidate::tl ->
+ let pos, (_, proof, (ty, left, right, o), metas, args) = candidate in
+ if check && not (fst (CicReduction.are_convertible
+ ~metasenv context termty ty ugraph)) then (
+ find_matches metasenv context ugraph lift_amount term termty tl
+ ) else
+ let do_match c eq_URI =
+ let subst', metasenv', ugraph' =
+ let t1 = Unix.gettimeofday () in
+ try
+ let r =
+ Inference.matching (metasenv @ metas) context
+ term (S.lift lift_amount c) ugraph
+ in
+ let t2 = Unix.gettimeofday () in
+ match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1);
+ r
+ with
+ | Inference.MatchingFailure as e ->
+ let t2 = Unix.gettimeofday () in
+ match_unif_time_no := !match_unif_time_no +. (t2 -. t1);
+ raise e
+ | CicUtil.Meta_not_found _ as exn ->
+ prerr_endline "zurg";
+ raise exn
+ in
+ Some (C.Rel (1 + lift_amount), subst', metasenv', ugraph',
+ (candidate, eq_URI))
+ in
+ let c, other, eq_URI =
+ if pos = Utils.Left then left, right, Utils.eq_ind_URI ()
+ else right, left, Utils.eq_ind_r_URI ()
+ in
+ if o <> U.Incomparable then
+ try
+ do_match c eq_URI
+ with Inference.MatchingFailure ->
+ find_matches metasenv context ugraph lift_amount term termty tl
+ else
+ let res =
+ try do_match c eq_URI
+ with Inference.MatchingFailure -> None
+ in
+ match res with
+ | Some (_, s, _, _, _) ->
+ let c' = apply_subst s c in
+ (*
+ let other' = U.guarded_simpl context (apply_subst s other) in *)
+ let other' = apply_subst s other in
+ let order = cmp c' other' in
+ if order = U.Gt then
+ res
+ else
+ find_matches
+ metasenv context ugraph lift_amount term termty tl
+ | None ->
+ find_matches metasenv context ugraph lift_amount term termty tl
+;;
+
+
+(*
+ as above, but finds all the matching equalities, and the matching condition
+ can be either Inference.matching or Inference.unification
+*)
+let rec find_all_matches ?(unif_fun=Inference.unification)
+ metasenv context ugraph lift_amount term termty =
+ let module C = Cic in
+ let module U = Utils in
+ let module S = CicSubstitution in
+ let module M = CicMetaSubst in
+ let module HL = HelmLibraryObjects in
+ let cmp = !Utils.compare_terms in
+ function
+ | [] -> []
+ | candidate::tl ->
+ let pos, (_, _, (ty, left, right, o), metas, args) = candidate in
+ let do_match c eq_URI =
+ let subst', metasenv', ugraph' =
+ let t1 = Unix.gettimeofday () in
+ try
+ let r =
+ unif_fun (metasenv @ metas) context
+ term (S.lift lift_amount c) ugraph in
+ let t2 = Unix.gettimeofday () in
+ match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1);
+ r
+ with
+ | Inference.MatchingFailure
+ | CicUnification.UnificationFailure _
+ | CicUnification.Uncertain _ as e ->
+ let t2 = Unix.gettimeofday () in
+ match_unif_time_no := !match_unif_time_no +. (t2 -. t1);
+ raise e
+ in
+ (C.Rel (1 + lift_amount), subst', metasenv', ugraph',
+ (candidate, eq_URI))
+ in
+ let c, other, eq_URI =
+ if pos = Utils.Left then left, right, Utils.eq_ind_URI ()
+ else right, left, Utils.eq_ind_r_URI ()
+ in
+ if o <> U.Incomparable then
+ try
+ let res = do_match c eq_URI in
+ res::(find_all_matches ~unif_fun metasenv context ugraph
+ lift_amount term termty tl)
+ with
+ | Inference.MatchingFailure
+ | CicUnification.UnificationFailure _
+ | CicUnification.Uncertain _ ->
+ find_all_matches ~unif_fun metasenv context ugraph
+ lift_amount term termty tl
+ else
+ try
+ let res = do_match c eq_URI in
+ match res with
+ | _, s, _, _, _ ->
+ let c' = apply_subst s c
+ and other' = apply_subst s other in
+ let order = cmp c' other' in
+ if order <> U.Lt && order <> U.Le then
+ res::(find_all_matches ~unif_fun metasenv context ugraph
+ lift_amount term termty tl)
+ else
+ find_all_matches ~unif_fun metasenv context ugraph
+ lift_amount term termty tl
+ with
+ | Inference.MatchingFailure
+ | CicUnification.UnificationFailure _
+ | CicUnification.Uncertain _ ->
+ find_all_matches ~unif_fun metasenv context ugraph
+ lift_amount term termty tl
+;;
+
+
+(*
+ returns true if target is subsumed by some equality in table
+*)
+let subsumption env table target =
+ let _, _, (ty, left, right, _), tmetas, _ = target in
+ let metasenv, context, ugraph = env in
+ let metasenv = metasenv @ tmetas in
+ let samesubst subst subst' =
+ let tbl = Hashtbl.create (List.length subst) in
+ List.iter (fun (m, (c, t1, t2)) -> Hashtbl.add tbl m (c, t1, t2)) subst;
+ List.for_all
+ (fun (m, (c, t1, t2)) ->
+ try
+ let c', t1', t2' = Hashtbl.find tbl m in
+ if (c = c') && (t1 = t1') && (t2 = t2') then true
+ else false
+ with Not_found ->
+ true)
+ subst'
+ in
+ let leftr =
+ match left with
+ | Cic.Meta _ -> []
+ | _ ->
+ let leftc = get_candidates Matching table left in
+ find_all_matches ~unif_fun:Inference.matching
+ metasenv context ugraph 0 left ty leftc
+ in
+ let rec ok what = function
+ | [] -> false, []
+ | (_, subst, menv, ug, ((pos, (_, _, (_, l, r, o), m, _)), _))::tl ->
+ try
+ let other = if pos = Utils.Left then r else l in
+ let subst', menv', ug' =
+ let t1 = Unix.gettimeofday () in
+ try
+ let r =
+ Inference.matching (metasenv @ menv @ m) context what other ugraph
+ in
+ let t2 = Unix.gettimeofday () in
+ match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1);
+ r
+ with Inference.MatchingFailure as e ->
+ let t2 = Unix.gettimeofday () in
+ match_unif_time_no := !match_unif_time_no +. (t2 -. t1);
+ raise e
+ in
+ if samesubst subst subst' then
+ true, subst
+ else
+ ok what tl
+ with Inference.MatchingFailure ->
+ ok what tl
+ in
+ let r, subst = ok right leftr in
+ let r, s =
+ if r then
+ true, subst
+ else
+ let rightr =
+ match right with
+ | Cic.Meta _ -> []
+ | _ ->
+ let rightc = get_candidates Matching table right in
+ find_all_matches ~unif_fun:Inference.matching
+ metasenv context ugraph 0 right ty rightc
+ in
+ ok left rightr
+ in
+(* (if r then *)
+(* debug_print *)
+(* (lazy *)
+(* (Printf.sprintf "SUBSUMPTION! %s\n%s\n" *)
+(* (Inference.string_of_equality target) (Utils.print_subst s)))); *)
+ r, s
+;;
+
+
+let rec demodulation_aux ?(typecheck=false)
+ metasenv context ugraph table lift_amount term =
+ (* Printf.eprintf "term = %s\n" (CicPp.ppterm term); *)
+
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module M = CicMetaSubst in
+ let module HL = HelmLibraryObjects in
+ let candidates = get_candidates Matching table term in
+ match term with
+ | C.Meta _ -> None
+ | term ->
+ let termty, ugraph =
+ if typecheck then
+ CicTypeChecker.type_of_aux' metasenv context term ugraph
+ else
+ C.Implicit None, ugraph
+ in
+ let res =
+ find_matches metasenv context ugraph lift_amount term termty candidates
+ in
+ if res <> None then
+ res
+ else
+ match term with
+ | C.Appl l ->
+ let res, ll =
+ List.fold_left
+ (fun (res, tl) t ->
+ if res <> None then
+ (res, tl @ [S.lift 1 t])
+ else
+ let r =
+ demodulation_aux metasenv context ugraph table
+ lift_amount t
+ in
+ match r with
+ | None -> (None, tl @ [S.lift 1 t])
+ | Some (rel, _, _, _, _) -> (r, tl @ [rel]))
+ (None, []) l
+ in (
+ match res with
+ | None -> None
+ | Some (_, subst, menv, ug, eq_found) ->
+ Some (C.Appl ll, subst, menv, ug, eq_found)
+ )
+ | C.Prod (nn, s, t) ->
+ let r1 =
+ demodulation_aux metasenv context ugraph table lift_amount s in (
+ match r1 with
+ | None ->
+ let r2 =
+ demodulation_aux metasenv
+ ((Some (nn, C.Decl s))::context) ugraph
+ table (lift_amount+1) t
+ in (
+ match r2 with
+ | None -> None
+ | Some (t', subst, menv, ug, eq_found) ->
+ Some (C.Prod (nn, (S.lift 1 s), t'),
+ subst, menv, ug, eq_found)
+ )
+ | Some (s', subst, menv, ug, eq_found) ->
+ Some (C.Prod (nn, s', (S.lift 1 t)),
+ subst, menv, ug, eq_found)
+ )
+ | C.Lambda (nn, s, t) ->
+ let r1 =
+ demodulation_aux metasenv context ugraph table lift_amount s in (
+ match r1 with
+ | None ->
+ let r2 =
+ demodulation_aux metasenv
+ ((Some (nn, C.Decl s))::context) ugraph
+ table (lift_amount+1) t
+ in (
+ match r2 with
+ | None -> None
+ | Some (t', subst, menv, ug, eq_found) ->
+ Some (C.Lambda (nn, (S.lift 1 s), t'),
+ subst, menv, ug, eq_found)
+ )
+ | Some (s', subst, menv, ug, eq_found) ->
+ Some (C.Lambda (nn, s', (S.lift 1 t)),
+ subst, menv, ug, eq_found)
+ )
+ | t ->
+ None
+;;
+
+
+let build_newtarget_time = ref 0.;;
+
+
+let demod_counter = ref 1;;
+
+(** demodulation, when target is an equality *)
+let rec demodulation_equality newmeta env table sign target =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module M = CicMetaSubst in
+ let module HL = HelmLibraryObjects in
+ let module U = Utils in
+ let metasenv, context, ugraph = env in
+ let w, proof, (eq_ty, left, right, order), metas, args = target in
+ (* first, we simplify *)
+ let right = U.guarded_simpl context right in
+ let left = U.guarded_simpl context left in
+ let w = Utils.compute_equality_weight eq_ty left right in
+ let order = !Utils.compare_terms left right in
+ let target = w, proof, (eq_ty, left, right, order), metas, args in
+
+ let metasenv' = metasenv @ metas in
+
+ let maxmeta = ref newmeta in
+
+ let build_newtarget is_left (t, subst, menv, ug, (eq_found, eq_URI)) =
+ let time1 = Unix.gettimeofday () in
+
+ let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in
+ let ty =
+ try fst (CicTypeChecker.type_of_aux' metasenv context what ugraph)
+ with CicUtil.Meta_not_found _ -> ty
+ in
+ let what, other = if pos = Utils.Left then what, other else other, what in
+ let newterm, newproof =
+ let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in
+ let name = C.Name ("x_Demod_" ^ (string_of_int !demod_counter)) in
+ incr demod_counter;
+ let bo' =
+ let l, r = if is_left then t, S.lift 1 right else S.lift 1 left, t in
+ C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []);
+ S.lift 1 eq_ty; l; r]
+ in
+ if sign = Utils.Positive then
+ (bo,
+ Inference.ProofBlock (
+ subst, eq_URI, (name, ty), bo'(* t' *), eq_found, proof))
+ else
+ let metaproof =
+ incr maxmeta;
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context in
+(* debug_print (lazy (Printf.sprintf "\nADDING META: %d\n" !maxmeta)); *)
+(* print_newline (); *)
+ C.Meta (!maxmeta, irl)
+ in
+ let eq_found =
+ let proof' =
+ let termlist =
+ if pos = Utils.Left then [ty; what; other]
+ else [ty; other; what]
+ in
+ Inference.ProofSymBlock (termlist, proof')
+ in
+ let what, other =
+ if pos = Utils.Left then what, other else other, what
+ in
+ pos, (0, proof', (ty, other, what, Utils.Incomparable),
+ menv', args')
+ in
+ let target_proof =
+ let pb =
+ Inference.ProofBlock (subst, eq_URI, (name, ty), bo',
+ eq_found, Inference.BasicProof metaproof)
+ in
+ match proof with
+ | Inference.BasicProof _ ->
+ print_endline "replacing a BasicProof";
+ pb
+ | Inference.ProofGoalBlock (_, parent_proof) ->
+ print_endline "replacing another ProofGoalBlock";
+ Inference.ProofGoalBlock (pb, parent_proof)
+ | _ -> assert false
+ in
+ let refl =
+ C.Appl [C.MutConstruct (* reflexivity *)
+ (LibraryObjects.eq_URI (), 0, 1, []);
+ eq_ty; if is_left then right else left]
+ in
+ (bo,
+ Inference.ProofGoalBlock (Inference.BasicProof refl, target_proof))
+ in
+ let left, right = if is_left then newterm, right else left, newterm in
+ let m =
+ (Inference.metas_of_term left)
+ @ (Inference.metas_of_term right)
+ @ (Inference.metas_of_term eq_ty) in
+ (* let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metas @ menv') *)
+ let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metasenv' @ menv')
+ and newargs = args
+ in
+ let ordering = !Utils.compare_terms left right in
+
+ let time2 = Unix.gettimeofday () in
+ build_newtarget_time := !build_newtarget_time +. (time2 -. time1);
+
+ let res =
+ let w = Utils.compute_equality_weight eq_ty left right in
+ (w, newproof, (eq_ty, left, right, ordering), newmetasenv, newargs)
+ in
+ !maxmeta, res
+ in
+ let _ =
+ try
+ CicTypeChecker.type_of_aux' metasenv' context left ugraph;
+ CicTypeChecker.type_of_aux' metasenv' context right ugraph;
+ with
+ CicUtil.Meta_not_found _ as exn ->
+ begin
+ prerr_endline "siamo in demodulation_equality 1";
+ prerr_endline (CicPp.ppterm left);
+ prerr_endline (CicPp.ppterm right);
+ raise exn
+ end
+ in
+ let res = demodulation_aux metasenv' context ugraph table 0 left in
+ let newmeta, newtarget =
+ match res with
+ | Some t ->
+ let newmeta, newtarget = build_newtarget true t in
+ if (Inference.is_weak_identity (metasenv', context, ugraph) newtarget) ||
+ (Inference.meta_convertibility_eq target newtarget) then
+ newmeta, newtarget
+ else
+ demodulation_equality newmeta env table sign newtarget
+ | None ->
+ let res = demodulation_aux metasenv' context ugraph table 0 right in
+ match res with
+ | Some t ->
+ let newmeta, newtarget = build_newtarget false t in
+ if (Inference.is_weak_identity (metasenv', context, ugraph) newtarget) ||
+ (Inference.meta_convertibility_eq target newtarget) then
+ newmeta, newtarget
+ else
+ demodulation_equality newmeta env table sign newtarget
+ | None ->
+ newmeta, target
+ in
+ (* newmeta, newtarget *)
+ newmeta,newtarget
+;;
+
+
+(**
+ Performs the beta expansion of the term "term" w.r.t. "table",
+ i.e. returns the list of all the terms t s.t. "(t term) = t2", for some t2
+ in table.
+*)
+let rec betaexpand_term metasenv context ugraph table lift_amount term =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module M = CicMetaSubst in
+ let module HL = HelmLibraryObjects in
+ let candidates = get_candidates Unification table term in
+ let res, lifted_term =
+ match term with
+ | C.Meta (i, l) ->
+ let l', lifted_l =
+ List.fold_right
+ (fun arg (res, lifted_tl) ->
+ match arg with
+ | Some arg ->
+ let arg_res, lifted_arg =
+ betaexpand_term metasenv context ugraph table
+ lift_amount arg in
+ let l1 =
+ List.map
+ (fun (t, s, m, ug, eq_found) ->
+ (Some t)::lifted_tl, s, m, ug, eq_found)
+ arg_res
+ in
+ (l1 @
+ (List.map
+ (fun (l, s, m, ug, eq_found) ->
+ (Some lifted_arg)::l, s, m, ug, eq_found)
+ res),
+ (Some lifted_arg)::lifted_tl)
+ | None ->
+ (List.map
+ (fun (r, s, m, ug, eq_found) ->
+ None::r, s, m, ug, eq_found) res,
+ None::lifted_tl)
+ ) l ([], [])
+ in
+ let e =
+ List.map
+ (fun (l, s, m, ug, eq_found) ->
+ (C.Meta (i, l), s, m, ug, eq_found)) l'
+ in
+ e, C.Meta (i, lifted_l)
+
+ | C.Rel m ->
+ [], if m <= lift_amount then C.Rel m else C.Rel (m+1)
+
+ | C.Prod (nn, s, t) ->
+ let l1, lifted_s =
+ betaexpand_term metasenv context ugraph table lift_amount s in
+ let l2, lifted_t =
+ betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph
+ table (lift_amount+1) t in
+ let l1' =
+ List.map
+ (fun (t, s, m, ug, eq_found) ->
+ C.Prod (nn, t, lifted_t), s, m, ug, eq_found) l1
+ and l2' =
+ List.map
+ (fun (t, s, m, ug, eq_found) ->
+ C.Prod (nn, lifted_s, t), s, m, ug, eq_found) l2 in
+ l1' @ l2', C.Prod (nn, lifted_s, lifted_t)
+
+ | C.Lambda (nn, s, t) ->
+ let l1, lifted_s =
+ betaexpand_term metasenv context ugraph table lift_amount s in
+ let l2, lifted_t =
+ betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph
+ table (lift_amount+1) t in
+ let l1' =
+ List.map
+ (fun (t, s, m, ug, eq_found) ->
+ C.Lambda (nn, t, lifted_t), s, m, ug, eq_found) l1
+ and l2' =
+ List.map
+ (fun (t, s, m, ug, eq_found) ->
+ C.Lambda (nn, lifted_s, t), s, m, ug, eq_found) l2 in
+ l1' @ l2', C.Lambda (nn, lifted_s, lifted_t)
+
+ | C.Appl l ->
+ let l', lifted_l =
+ List.fold_right
+ (fun arg (res, lifted_tl) ->
+ let arg_res, lifted_arg =
+ betaexpand_term metasenv context ugraph table lift_amount arg
+ in
+ let l1 =
+ List.map
+ (fun (a, s, m, ug, eq_found) ->
+ a::lifted_tl, s, m, ug, eq_found)
+ arg_res
+ in
+ (l1 @
+ (List.map
+ (fun (r, s, m, ug, eq_found) ->
+ lifted_arg::r, s, m, ug, eq_found)
+ res),
+ lifted_arg::lifted_tl)
+ ) l ([], [])
+ in
+ (List.map
+ (fun (l, s, m, ug, eq_found) -> (C.Appl l, s, m, ug, eq_found)) l',
+ C.Appl lifted_l)
+
+ | t -> [], (S.lift lift_amount t)
+ in
+ match term with
+ | C.Meta (i, l) -> res, lifted_term
+ | term ->
+ let termty, ugraph =
+ C.Implicit None, ugraph
+(* CicTypeChecker.type_of_aux' metasenv context term ugraph *)
+ in
+ let r =
+ find_all_matches
+ metasenv context ugraph lift_amount term termty candidates
+ in
+ r @ res, lifted_term
+;;
+
+
+let sup_l_counter = ref 1;;
+
+(**
+ superposition_left
+ returns a list of new clauses inferred with a left superposition step
+ the negative equation "target" and one of the positive equations in "table"
+*)
+let superposition_left newmeta (metasenv, context, ugraph) table target =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module M = CicMetaSubst in
+ let module HL = HelmLibraryObjects in
+ let module CR = CicReduction in
+ let module U = Utils in
+ let weight, proof, (eq_ty, left, right, ordering), menv, _ = target in
+ let expansions, _ =
+ let term = if ordering = U.Gt then left else right in
+ betaexpand_term metasenv context ugraph table 0 term
+ in
+ let maxmeta = ref newmeta in
+ let build_new (bo, s, m, ug, (eq_found, eq_URI)) =
+
+(* debug_print (lazy "\nSUPERPOSITION LEFT\n"); *)
+
+ let time1 = Unix.gettimeofday () in
+
+ let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in
+ let what, other = if pos = Utils.Left then what, other else other, what in
+ let newgoal, newproof =
+ let bo' = U.guarded_simpl context (apply_subst s (S.subst other bo)) in
+ let name = C.Name ("x_SupL_" ^ (string_of_int !sup_l_counter)) in
+ incr sup_l_counter;
+ let bo'' =
+ let l, r =
+ if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in
+ C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []);
+ S.lift 1 eq_ty; l; r]
+ in
+ incr maxmeta;
+ let metaproof =
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context in
+ C.Meta (!maxmeta, irl)
+ in
+ let eq_found =
+ let proof' =
+ let termlist =
+ if pos = Utils.Left then [ty; what; other]
+ else [ty; other; what]
+ in
+ Inference.ProofSymBlock (termlist, proof')
+ in
+ let what, other =
+ if pos = Utils.Left then what, other else other, what
+ in
+ pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args')
+ in
+ let target_proof =
+ let pb =
+ Inference.ProofBlock (s, eq_URI, (name, ty), bo'', eq_found,
+ Inference.BasicProof metaproof)
+ in
+ match proof with
+ | Inference.BasicProof _ ->
+(* debug_print (lazy "replacing a BasicProof"); *)
+ pb
+ | Inference.ProofGoalBlock (_, parent_proof) ->
+(* debug_print (lazy "replacing another ProofGoalBlock"); *)
+ Inference.ProofGoalBlock (pb, parent_proof)
+ | _ -> assert false
+ in
+ let refl =
+ C.Appl [C.MutConstruct (* reflexivity *)
+ (LibraryObjects.eq_URI (), 0, 1, []);
+ eq_ty; if ordering = U.Gt then right else left]
+ in
+ (bo',
+ Inference.ProofGoalBlock (Inference.BasicProof refl, target_proof))
+ in
+ let left, right =
+ if ordering = U.Gt then newgoal, right else left, newgoal in
+ let neworder = !Utils.compare_terms left right in
+
+ let time2 = Unix.gettimeofday () in
+ build_newtarget_time := !build_newtarget_time +. (time2 -. time1);
+
+ let res =
+ let w = Utils.compute_equality_weight eq_ty left right in
+ (w, newproof, (eq_ty, left, right, neworder), menv @ menv', [])
+ in
+ res
+ in
+ !maxmeta, List.map build_new expansions
+;;
+
+
+let sup_r_counter = ref 1;;
+
+(**
+ superposition_right
+ returns a list of new clauses inferred with a right superposition step
+ between the positive equation "target" and one in the "table" "newmeta" is
+ the first free meta index, i.e. the first number above the highest meta
+ index: its updated value is also returned
+*)
+let superposition_right newmeta (metasenv, context, ugraph) table target =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module M = CicMetaSubst in
+ let module HL = HelmLibraryObjects in
+ let module CR = CicReduction in
+ let module U = Utils in
+ let _, eqproof, (eq_ty, left, right, ordering), newmetas, args = target in
+ let metasenv' = metasenv @ newmetas in
+ let maxmeta = ref newmeta in
+ let res1, res2 =
+ match ordering with
+ | U.Gt -> fst (betaexpand_term metasenv' context ugraph table 0 left), []
+ | U.Lt -> [], fst (betaexpand_term metasenv' context ugraph table 0 right)
+ | _ ->
+ let res l r =
+ List.filter
+ (fun (_, subst, _, _, _) ->
+ let subst = apply_subst subst in
+ let o = !Utils.compare_terms (subst l) (subst r) in
+ o <> U.Lt && o <> U.Le)
+ (fst (betaexpand_term metasenv' context ugraph table 0 l))
+ in
+ (res left right), (res right left)
+ in
+ let build_new ordering (bo, s, m, ug, (eq_found, eq_URI)) =
+
+ let time1 = Unix.gettimeofday () in
+
+ let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in
+ let what, other = if pos = Utils.Left then what, other else other, what in
+ let newgoal, newproof =
+ (* qua *)
+ let bo' = Utils.guarded_simpl context (apply_subst s (S.subst other bo)) in
+ let name = C.Name ("x_SupR_" ^ (string_of_int !sup_r_counter)) in
+ incr sup_r_counter;
+ let bo'' =
+ let l, r =
+ if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in
+ C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []);
+ S.lift 1 eq_ty; l; r]
+ in
+ bo',
+ Inference.ProofBlock (s, eq_URI, (name, ty), bo'', eq_found, eqproof)
+ in
+ let newmeta, newequality =
+ let left, right =
+ if ordering = U.Gt then newgoal, apply_subst s right
+ else apply_subst s left, newgoal in
+ let neworder = !Utils.compare_terms left right
+ and newmenv = newmetas @ menv'
+ and newargs = args @ args' in
+ let eq' =
+ let w = Utils.compute_equality_weight eq_ty left right in
+ (w, newproof, (eq_ty, left, right, neworder), newmenv, newargs) in
+ let newm, eq' = Inference.fix_metas !maxmeta eq' in
+ newm, eq'
+ in
+ maxmeta := newmeta;
+
+ let time2 = Unix.gettimeofday () in
+ build_newtarget_time := !build_newtarget_time +. (time2 -. time1);
+
+ newequality
+ in
+ let new1 = List.map (build_new U.Gt) res1
+ and new2 = List.map (build_new U.Lt) res2 in
+(*
+ let ok e = not (Inference.is_identity (metasenv, context, ugraph) e) in
+*)
+ let ok e = not (Inference.is_identity (metasenv', context, ugraph) e) in
+ (!maxmeta,
+ (List.filter ok (new1 @ new2)))
+;;
+
+
+(** demodulation, when the target is a goal *)
+let rec demodulation_goal newmeta env table goal =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module M = CicMetaSubst in
+ let module HL = HelmLibraryObjects in
+ let metasenv, context, ugraph = env in
+ let maxmeta = ref newmeta in
+ let proof, metas, term = goal in
+ let term = Utils.guarded_simpl (~debug:true) context term in
+ let goal = proof, metas, term in
+ let metasenv' = metasenv @ metas in
+
+ let build_newgoal (t, subst, menv, ug, (eq_found, eq_URI)) =
+ let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in
+ let what, other = if pos = Utils.Left then what, other else other, what in
+ let ty =
+ try fst (CicTypeChecker.type_of_aux' metasenv context what ugraph)
+ with CicUtil.Meta_not_found _ -> ty
+ in
+ let newterm, newproof =
+ (* qua *)
+ let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in
+ let bo' = apply_subst subst t in
+ let name = C.Name ("x_DemodGoal_" ^ (string_of_int !demod_counter)) in
+ incr demod_counter;
+ let metaproof =
+ incr maxmeta;
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context in
+(* debug_print (lazy (Printf.sprintf "\nADDING META: %d\n" !maxmeta)); *)
+ C.Meta (!maxmeta, irl)
+ in
+ let eq_found =
+ let proof' =
+ let termlist =
+ if pos = Utils.Left then [ty; what; other]
+ else [ty; other; what]
+ in
+ Inference.ProofSymBlock (termlist, proof')
+ in
+ let what, other =
+ if pos = Utils.Left then what, other else other, what
+ in
+ pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args')
+ in
+ let goal_proof =
+ let pb =
+ Inference.ProofBlock (subst, eq_URI, (name, ty), bo',
+ eq_found, Inference.BasicProof metaproof)
+ in
+ let rec repl = function
+ | Inference.NoProof ->
+(* debug_print (lazy "replacing a NoProof"); *)
+ pb
+ | Inference.BasicProof _ ->
+(* debug_print (lazy "replacing a BasicProof"); *)
+ pb
+ | Inference.ProofGoalBlock (_, parent_proof) ->
+(* debug_print (lazy "replacing another ProofGoalBlock"); *)
+ Inference.ProofGoalBlock (pb, parent_proof)
+ | Inference.SubProof (term, meta_index, p) ->
+ Inference.SubProof (term, meta_index, repl p)
+ | _ -> assert false
+ in repl proof
+ in
+ bo, Inference.ProofGoalBlock (Inference.NoProof, goal_proof)
+ in
+ let m = Inference.metas_of_term newterm in
+ (* QUA *)
+ let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (menv @ menv')in
+ !maxmeta, (newproof, newmetasenv, newterm)
+ in
+ let res =
+ demodulation_aux ~typecheck:true metasenv' context ugraph table 0 term
+ in
+ match res with
+ | Some t ->
+ let newmeta, newgoal = build_newgoal t in
+ let _, _, newg = newgoal in
+ if Inference.meta_convertibility term newg then
+ newmeta, newgoal
+ else
+ demodulation_goal newmeta env table newgoal
+ | None ->
+ newmeta, goal
+;;
+
+
+(** demodulation, when the target is a theorem *)
+let rec demodulation_theorem newmeta env table theorem =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module M = CicMetaSubst in
+ let module HL = HelmLibraryObjects in
+ let metasenv, context, ugraph = env in
+ let maxmeta = ref newmeta in
+ let term, termty, metas = theorem in
+ let metasenv' = metasenv @ metas in
+
+ let build_newtheorem (t, subst, menv, ug, (eq_found, eq_URI)) =
+ let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in
+ let what, other = if pos = Utils.Left then what, other else other, what in
+ let newterm, newty =
+ (* qua *)
+ let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in
+ let bo' = apply_subst subst t in
+ let name = C.Name ("x_DemodThm_" ^ (string_of_int !demod_counter)) in
+ incr demod_counter;
+ let newproof =
+ Inference.ProofBlock (subst, eq_URI, (name, ty), bo', eq_found,
+ Inference.BasicProof term)
+ in
+ (Inference.build_proof_term newproof, bo)
+ in
+
+ let m = Inference.metas_of_term newterm in
+ let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metas @ menv') in
+ !maxmeta, (newterm, newty, newmetasenv)
+ in
+ let res =
+ demodulation_aux ~typecheck:true metasenv' context ugraph table 0 termty
+ in
+ match res with
+ | Some t ->
+ let newmeta, newthm = build_newtheorem t in
+ let newt, newty, _ = newthm in
+ if Inference.meta_convertibility termty newty then
+ newmeta, newthm
+ else
+ demodulation_theorem newmeta env table newthm
+ | None ->
+ newmeta, theorem
+;;
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+module Index :
+ sig
+ module PosEqSet : Set.S
+ with type elt = Utils.pos * Inference.equality
+ and type t = Equality_indexing.DT.PosEqSet.t
+ type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t
+ type key = Cic.term
+ end
+
+val index : Index.t -> Inference.equality -> Index.t
+val remove_index : Index.t -> Inference.equality -> Index.t
+val in_index : Index.t -> Inference.equality -> bool
+val empty : Index.t
+val match_unif_time_ok : float ref
+val match_unif_time_no : float ref
+val indexing_retrieval_time : float ref
+val init_index : unit -> unit
+val build_newtarget_time : float ref
+val subsumption :
+ Cic.metasenv * Cic.context * CicUniv.universe_graph ->
+ Index.t ->
+ 'a * 'b * ('c * Index.key * Index.key * 'd) * Cic.metasenv * 'e ->
+ bool * Cic.substitution
+val superposition_left :
+ int ->
+ Cic.metasenv * Cic.context * CicUniv.universe_graph ->
+ Index.t ->
+ 'a * Inference.proof *
+ (Index.key * Index.key * Index.key * Utils.comparison) * Cic.metasenv * 'c ->
+ int *
+ (int * Inference.proof *
+ (Index.key * Index.key * Index.key * Utils.comparison) * Cic.metasenv *
+ 'e list)
+ list
+val superposition_right :
+ int ->
+ Cic.metasenv * Cic.context * CicUniv.universe_graph ->
+ Index.t ->
+ 'a * Inference.proof *
+ (Cic.term * Index.key * Index.key * Utils.comparison) *
+ Cic.metasenv * Cic.term list -> int * Inference.equality list
+val demodulation_equality :
+ int ->
+ Cic.metasenv * Cic.context * CicUniv.universe_graph ->
+ Index.t ->
+ Utils.equality_sign -> Inference.equality -> int * Inference.equality
+val demodulation_goal :
+ int ->
+ Cic.metasenv * Cic.context * CicUniv.universe_graph ->
+ Index.t ->
+ Inference.proof * Cic.metasenv * Index.key ->
+ int * (Inference.proof * Cic.metasenv * Index.key)
+val demodulation_theorem :
+ 'a ->
+ Cic.metasenv * Cic.context * CicUniv.universe_graph ->
+ Index.t ->
+ Cic.term * Index.key * Cic.metasenv ->
+ 'a * (Cic.term * Index.key * Cic.metasenv)
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+open Utils;;
+
+
+type equality =
+ int * (* weight *)
+ proof *
+ (Cic.term * (* type *)
+ Cic.term * (* left side *)
+ Cic.term * (* right side *)
+ Utils.comparison) * (* ordering *)
+ Cic.metasenv * (* environment for metas *)
+ Cic.term list (* arguments *)
+
+and proof =
+ | NoProof (* term is the goal missing a proof *)
+ | BasicProof of Cic.term
+ | ProofBlock of
+ Cic.substitution * UriManager.uri *
+ (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof
+ | ProofGoalBlock of proof * proof
+ | ProofSymBlock of Cic.term list * proof
+ | SubProof of Cic.term * int * proof
+;;
+
+
+let string_of_equality ?env =
+ match env with
+ | None -> (
+ function
+ | w, _, (ty, left, right, o), _, _ ->
+ Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.ppterm ty)
+ (CicPp.ppterm left) (string_of_comparison o) (CicPp.ppterm right)
+ )
+ | Some (_, context, _) -> (
+ let names = names_of_context context in
+ function
+ | w, _, (ty, left, right, o), _, _ ->
+ Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.pp ty names)
+ (CicPp.pp left names) (string_of_comparison o)
+ (CicPp.pp right names)
+ )
+;;
+
+
+let rec string_of_proof = function
+ | NoProof -> "NoProof "
+ | BasicProof t -> "BasicProof " ^ (CicPp.ppterm t)
+ | SubProof (t, i, p) ->
+ Printf.sprintf "SubProof(%s, %s, %s)"
+ (CicPp.ppterm t) (string_of_int i) (string_of_proof p)
+ | ProofSymBlock _ -> "ProofSymBlock"
+ | ProofBlock _ -> "ProofBlock"
+ | ProofGoalBlock (p1, p2) ->
+ Printf.sprintf "ProofGoalBlock(%s, %s)"
+ (string_of_proof p1) (string_of_proof p2)
+;;
+
+
+(* returns an explicit named subst and a list of arguments for sym_eq_URI *)
+let build_ens_for_sym_eq sym_eq_URI termlist =
+ let obj, _ = CicEnvironment.get_obj CicUniv.empty_ugraph sym_eq_URI in
+ match obj with
+ | Cic.Constant (_, _, _, uris, _) ->
+ assert (List.length uris <= List.length termlist);
+ let rec aux = function
+ | [], tl -> [], tl
+ | (uri::uris), (term::tl) ->
+ let ens, args = aux (uris, tl) in
+ (uri, term)::ens, args
+ | _, _ -> assert false
+ in
+ aux (uris, termlist)
+ | _ -> assert false
+;;
+
+
+let build_proof_term ?(noproof=Cic.Implicit None) proof =
+ let rec do_build_proof proof =
+ match proof with
+ | NoProof ->
+ Printf.fprintf stderr "WARNING: no proof!\n";
+ noproof
+ | BasicProof term -> term
+ | ProofGoalBlock (proofbit, proof) ->
+ print_endline "found ProofGoalBlock, going up...";
+ do_build_goal_proof proofbit proof
+ | ProofSymBlock (termlist, proof) ->
+ let proof = do_build_proof proof in
+ let ens, args = build_ens_for_sym_eq (Utils.sym_eq_URI ()) termlist in
+ Cic.Appl ([Cic.Const (Utils.sym_eq_URI (), ens)] @ args @ [proof])
+ | ProofBlock (subst, eq_URI, (name, ty), bo, (pos, eq), eqproof) ->
+ let t' = Cic.Lambda (name, ty, bo) in
+ let proof' =
+ let _, proof', _, _, _ = eq in
+ do_build_proof proof'
+ in
+ let eqproof = do_build_proof eqproof in
+ let _, _, (ty, what, other, _), menv', args' = eq in
+ let what, other =
+ if pos = Utils.Left then what, other else other, what
+ in
+ CicMetaSubst.apply_subst subst
+ (Cic.Appl [Cic.Const (eq_URI, []); ty;
+ what; t'; eqproof; other; proof'])
+ | SubProof (term, meta_index, proof) ->
+ let proof = do_build_proof proof in
+ let eq i = function
+ | Cic.Meta (j, _) -> i = j
+ | _ -> false
+ in
+ ProofEngineReduction.replace
+ ~equality:eq ~what:[meta_index] ~with_what:[proof] ~where:term
+
+ and do_build_goal_proof proofbit proof =
+ match proof with
+ | ProofGoalBlock (pb, p) ->
+ do_build_proof (ProofGoalBlock (replace_proof proofbit pb, p))
+ | _ -> do_build_proof (replace_proof proofbit proof)
+
+ and replace_proof newproof = function
+ | ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof) ->
+ let eqproof' = replace_proof newproof eqproof in
+ ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof')
+ | ProofGoalBlock (pb, p) ->
+ let pb' = replace_proof newproof pb in
+ ProofGoalBlock (pb', p)
+ | BasicProof _ -> newproof
+ | SubProof (term, meta_index, p) ->
+ SubProof (term, meta_index, replace_proof newproof p)
+ | p -> p
+ in
+ do_build_proof proof
+;;
+
+
+let rec metas_of_term = function
+ | Cic.Meta (i, c) -> [i]
+ | Cic.Var (_, ens)
+ | Cic.Const (_, ens)
+ | Cic.MutInd (_, _, ens)
+ | Cic.MutConstruct (_, _, _, ens) ->
+ List.flatten (List.map (fun (u, t) -> metas_of_term t) ens)
+ | Cic.Cast (s, t)
+ | Cic.Prod (_, s, t)
+ | Cic.Lambda (_, s, t)
+ | Cic.LetIn (_, s, t) -> (metas_of_term s) @ (metas_of_term t)
+ | Cic.Appl l -> List.flatten (List.map metas_of_term l)
+ | Cic.MutCase (uri, i, s, t, l) ->
+ (metas_of_term s) @ (metas_of_term t) @
+ (List.flatten (List.map metas_of_term l))
+ | Cic.Fix (i, il) ->
+ List.flatten
+ (List.map (fun (s, i, t1, t2) ->
+ (metas_of_term t1) @ (metas_of_term t2)) il)
+ | Cic.CoFix (i, il) ->
+ List.flatten
+ (List.map (fun (s, t1, t2) ->
+ (metas_of_term t1) @ (metas_of_term t2)) il)
+ | _ -> []
+;;
+
+
+exception NotMetaConvertible;;
+
+let meta_convertibility_aux table t1 t2 =
+ let module C = Cic in
+ let rec aux ((table_l, table_r) as table) t1 t2 =
+ match t1, t2 with
+ | C.Meta (m1, tl1), C.Meta (m2, tl2) ->
+ let m1_binding, table_l =
+ try List.assoc m1 table_l, table_l
+ with Not_found -> m2, (m1, m2)::table_l
+ and m2_binding, table_r =
+ try List.assoc m2 table_r, table_r
+ with Not_found -> m1, (m2, m1)::table_r
+ in
+ if (m1_binding <> m2) || (m2_binding <> m1) then
+ raise NotMetaConvertible
+ else (
+ try
+ List.fold_left2
+ (fun res t1 t2 ->
+ match t1, t2 with
+ | None, Some _ | Some _, None -> raise NotMetaConvertible
+ | None, None -> res
+ | Some t1, Some t2 -> (aux res t1 t2))
+ (table_l, table_r) tl1 tl2
+ with Invalid_argument _ ->
+ raise NotMetaConvertible
+ )
+ | C.Var (u1, ens1), C.Var (u2, ens2)
+ | C.Const (u1, ens1), C.Const (u2, ens2) when (UriManager.eq u1 u2) ->
+ aux_ens table ens1 ens2
+ | C.Cast (s1, t1), C.Cast (s2, t2)
+ | C.Prod (_, s1, t1), C.Prod (_, s2, t2)
+ | C.Lambda (_, s1, t1), C.Lambda (_, s2, t2)
+ | C.LetIn (_, s1, t1), C.LetIn (_, s2, t2) ->
+ let table = aux table s1 s2 in
+ aux table t1 t2
+ | C.Appl l1, C.Appl l2 -> (
+ try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2
+ with Invalid_argument _ -> raise NotMetaConvertible
+ )
+ | C.MutInd (u1, i1, ens1), C.MutInd (u2, i2, ens2)
+ when (UriManager.eq u1 u2) && i1 = i2 -> aux_ens table ens1 ens2
+ | C.MutConstruct (u1, i1, j1, ens1), C.MutConstruct (u2, i2, j2, ens2)
+ when (UriManager.eq u1 u2) && i1 = i2 && j1 = j2 ->
+ aux_ens table ens1 ens2
+ | C.MutCase (u1, i1, s1, t1, l1), C.MutCase (u2, i2, s2, t2, l2)
+ when (UriManager.eq u1 u2) && i1 = i2 ->
+ let table = aux table s1 s2 in
+ let table = aux table t1 t2 in (
+ try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2
+ with Invalid_argument _ -> raise NotMetaConvertible
+ )
+ | C.Fix (i1, il1), C.Fix (i2, il2) when i1 = i2 -> (
+ try
+ List.fold_left2
+ (fun res (n1, i1, s1, t1) (n2, i2, s2, t2) ->
+ if i1 <> i2 then raise NotMetaConvertible
+ else
+ let res = (aux res s1 s2) in aux res t1 t2)
+ table il1 il2
+ with Invalid_argument _ -> raise NotMetaConvertible
+ )
+ | C.CoFix (i1, il1), C.CoFix (i2, il2) when i1 = i2 -> (
+ try
+ List.fold_left2
+ (fun res (n1, s1, t1) (n2, s2, t2) ->
+ let res = aux res s1 s2 in aux res t1 t2)
+ table il1 il2
+ with Invalid_argument _ -> raise NotMetaConvertible
+ )
+ | t1, t2 when t1 = t2 -> table
+ | _, _ -> raise NotMetaConvertible
+
+ and aux_ens table ens1 ens2 =
+ let cmp (u1, t1) (u2, t2) =
+ compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2)
+ in
+ let ens1 = List.sort cmp ens1
+ and ens2 = List.sort cmp ens2 in
+ try
+ List.fold_left2
+ (fun res (u1, t1) (u2, t2) ->
+ if not (UriManager.eq u1 u2) then raise NotMetaConvertible
+ else aux res t1 t2)
+ table ens1 ens2
+ with Invalid_argument _ -> raise NotMetaConvertible
+ in
+ aux table t1 t2
+;;
+
+
+let meta_convertibility_eq eq1 eq2 =
+ let _, _, (ty, left, right, _), _, _ = eq1
+ and _, _, (ty', left', right', _), _, _ = eq2 in
+ if ty <> ty' then
+ false
+ else if (left = left') && (right = right') then
+ true
+ else if (left = right') && (right = left') then
+ true
+ else
+ try
+ let table = meta_convertibility_aux ([], []) left left' in
+ let _ = meta_convertibility_aux table right right' in
+ true
+ with NotMetaConvertible ->
+ try
+ let table = meta_convertibility_aux ([], []) left right' in
+ let _ = meta_convertibility_aux table right left' in
+ true
+ with NotMetaConvertible ->
+ false
+;;
+
+
+let meta_convertibility t1 t2 =
+ if t1 = t2 then
+ true
+ else
+ try
+ ignore(meta_convertibility_aux ([], []) t1 t2);
+ true
+ with NotMetaConvertible ->
+ false
+;;
+
+
+let rec check_irl start = function
+ | [] -> true
+ | None::tl -> check_irl (start+1) tl
+ | (Some (Cic.Rel x))::tl ->
+ if x = start then check_irl (start+1) tl else false
+ | _ -> false
+;;
+
+
+let rec is_simple_term = function
+ | Cic.Appl ((Cic.Meta _)::_) -> false
+ | Cic.Appl l -> List.for_all is_simple_term l
+ | Cic.Meta (i, l) -> check_irl 1 l
+ | Cic.Rel _ -> true
+ | Cic.Const _ -> true
+ | Cic.MutInd (_, _, []) -> true
+ | Cic.MutConstruct (_, _, _, []) -> true
+ | _ -> false
+;;
+
+
+let lookup_subst meta subst =
+ match meta with
+ | Cic.Meta (i, _) -> (
+ try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t
+ with Not_found -> meta
+ )
+ | _ -> assert false
+;;
+
+
+let unification_simple metasenv context t1 t2 ugraph =
+ let module C = Cic in
+ let module M = CicMetaSubst in
+ let module U = CicUnification in
+ let lookup = lookup_subst in
+ let rec occurs_check subst what where =
+ match where with
+ | t when what = t -> true
+ | C.Appl l -> List.exists (occurs_check subst what) l
+ | C.Meta _ ->
+ let t = lookup where subst in
+ if t <> where then occurs_check subst what t else false
+ | _ -> false
+ in
+ let rec unif subst menv s t =
+ let s = match s with C.Meta _ -> lookup s subst | _ -> s
+ and t = match t with C.Meta _ -> lookup t subst | _ -> t
+ in
+ match s, t with
+ | s, t when s = t -> subst, menv
+ | C.Meta (i, _), C.Meta (j, _) when i > j ->
+ unif subst menv t s
+ | C.Meta _, t when occurs_check subst s t ->
+ raise
+ (U.UnificationFailure (lazy "Inference.unification.unif"))
+ | C.Meta (i, l), t -> (
+ try
+ let _, _, ty = CicUtil.lookup_meta i menv in
+ let subst =
+ if not (List.mem_assoc i subst) then (i, (context, t, ty))::subst
+ else subst
+ in
+ let menv = menv in (* List.filter (fun (m, _, _) -> i <> m) menv in *)
+ subst, menv
+ with CicUtil.Meta_not_found m ->
+ let names = names_of_context context in
+ debug_print
+ (lazy
+ (Printf.sprintf "Meta_not_found %d!: %s %s\n%s\n\n%s" m
+ (CicPp.pp t1 names) (CicPp.pp t2 names)
+ (print_metasenv menv) (print_metasenv metasenv)));
+ assert false
+ )
+ | _, C.Meta _ -> unif subst menv t s
+ | C.Appl (hds::_), C.Appl (hdt::_) when hds <> hdt ->
+ raise (U.UnificationFailure (lazy "Inference.unification.unif"))
+ | C.Appl (hds::tls), C.Appl (hdt::tlt) -> (
+ try
+ List.fold_left2
+ (fun (subst', menv) s t -> unif subst' menv s t)
+ (subst, menv) tls tlt
+ with Invalid_argument _ ->
+ raise (U.UnificationFailure (lazy "Inference.unification.unif"))
+ )
+ | _, _ ->
+ raise (U.UnificationFailure (lazy "Inference.unification.unif"))
+ in
+ let subst, menv = unif [] metasenv t1 t2 in
+ let menv =
+ List.filter
+ (fun (m, _, _) ->
+ try let _ = List.find (fun (i, _) -> m = i) subst in false
+ with Not_found -> true)
+ menv
+ in
+ List.rev subst, menv, ugraph
+;;
+
+
+let unification metasenv context t1 t2 ugraph =
+ let subst, menv, ug =
+ if not (is_simple_term t1) || not (is_simple_term t2) then (
+ debug_print
+ (lazy
+ (Printf.sprintf "NOT SIMPLE TERMS: %s %s"
+ (CicPp.ppterm t1) (CicPp.ppterm t2)));
+ CicUnification.fo_unif metasenv context t1 t2 ugraph
+ ) else
+ unification_simple metasenv context t1 t2 ugraph
+ in
+ let rec fix_term = function
+ | (Cic.Meta (i, l) as t) ->
+ let t' = lookup_subst t subst in
+ if t <> t' then fix_term t' else t
+ | Cic.Appl l -> Cic.Appl (List.map fix_term l)
+ | t -> t
+ in
+ let rec fix_subst = function
+ | [] -> []
+ | (i, (c, t, ty))::tl -> (i, (c, fix_term t, fix_term ty))::(fix_subst tl)
+ in
+ fix_subst subst, menv, ug
+;;
+
+
+let unification = CicUnification.fo_unif;;
+
+exception MatchingFailure;;
+
+
+(*
+let matching_simple metasenv context t1 t2 ugraph =
+ let module C = Cic in
+ let module M = CicMetaSubst in
+ let module U = CicUnification in
+ let lookup meta subst =
+ match meta with
+ | C.Meta (i, _) -> (
+ try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t
+ with Not_found -> meta
+ )
+ | _ -> assert false
+ in
+ let rec do_match subst menv s t =
+ match s, t with
+ | s, t when s = t -> subst, menv
+ | s, C.Meta (i, l) ->
+ let filter_menv i menv =
+ List.filter (fun (m, _, _) -> i <> m) menv
+ in
+ let subst, menv =
+ let value = lookup t subst in
+ match value with
+ | value when value = t ->
+ let _, _, ty = CicUtil.lookup_meta i menv in
+ (i, (context, s, ty))::subst, filter_menv i menv
+ | value when value <> s ->
+ raise MatchingFailure
+ | value -> do_match subst menv s value
+ in
+ subst, menv
+ | C.Appl ls, C.Appl lt -> (
+ try
+ List.fold_left2
+ (fun (subst, menv) s t -> do_match subst menv s t)
+ (subst, menv) ls lt
+ with Invalid_argument _ ->
+ raise MatchingFailure
+ )
+ | _, _ ->
+ raise MatchingFailure
+ in
+ let subst, menv = do_match [] metasenv t1 t2 in
+ subst, menv, ugraph
+;;
+*)
+
+
+let matching metasenv context t1 t2 ugraph =
+ try
+ let subst, metasenv, ugraph =
+try
+ unification metasenv context t1 t2 ugraph
+with CicUtil.Meta_not_found _ as exn ->
+ Printf.eprintf "t1 == %s\nt2 = %s\nmetasenv == %s\n%!"
+ (CicPp.ppterm t1) (CicPp.ppterm t2) (CicMetaSubst.ppmetasenv [] metasenv);
+ raise exn
+ in
+ let t' = CicMetaSubst.apply_subst subst t1 in
+ if not (meta_convertibility t1 t') then
+ raise MatchingFailure
+ else
+ let metas = metas_of_term t1 in
+ let fix_subst = function
+ | (i, (c, Cic.Meta (j, lc), ty)) when List.mem i metas ->
+ (j, (c, Cic.Meta (i, lc), ty))
+ | s -> s
+ in
+ let subst = List.map fix_subst subst in
+ subst, metasenv, ugraph
+ with
+ | CicUnification.UnificationFailure _
+ | CicUnification.Uncertain _ ->
+ raise MatchingFailure
+;;
+
+
+let find_equalities context proof =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module T = CicTypeChecker in
+ let eq_uri = LibraryObjects.eq_URI () in
+ let newmeta = ProofEngineHelpers.new_meta_of_proof ~proof in
+ let ok_types ty menv =
+ List.for_all (fun (_, _, mt) -> mt = ty) menv
+ in
+ let rec aux index newmeta = function
+ | [] -> [], newmeta
+ | (Some (_, C.Decl (term)))::tl ->
+ let do_find context term =
+ match term with
+ | C.Prod (name, s, t) ->
+ let (head, newmetas, args, newmeta) =
+ ProofEngineHelpers.saturate_term newmeta []
+ context (S.lift index term) 0
+ in
+ let p =
+ if List.length args = 0 then
+ C.Rel index
+ else
+ C.Appl ((C.Rel index)::args)
+ in (
+ match head with
+ | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
+ when (UriManager.eq uri eq_uri) && (ok_types ty newmetas) ->
+ debug_print
+ (lazy
+ (Printf.sprintf "OK: %s" (CicPp.ppterm term)));
+ let o = !Utils.compare_terms t1 t2 in
+ let w = compute_equality_weight ty t1 t2 in
+ let proof = BasicProof p in
+ let e = (w, proof, (ty, t1, t2, o), newmetas, args) in
+ Some e, (newmeta+1)
+ | _ -> None, newmeta
+ )
+ | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
+ when UriManager.eq uri eq_uri ->
+ let t1 = S.lift index t1
+ and t2 = S.lift index t2 in
+ let o = !Utils.compare_terms t1 t2 in
+ let w = compute_equality_weight ty t1 t2 in
+ let e = (w, BasicProof (C.Rel index), (ty, t1, t2, o), [], []) in
+ Some e, (newmeta+1)
+ | _ -> None, newmeta
+ in (
+ match do_find context term with
+ | Some p, newmeta ->
+ let tl, newmeta' = (aux (index+1) newmeta tl) in
+ if newmeta' < newmeta then
+ prerr_endline "big trouble";
+ (index, p)::tl, newmeta' (* max???? *)
+ | None, _ ->
+ aux (index+1) newmeta tl
+ )
+ | _::tl ->
+ aux (index+1) newmeta tl
+ in
+ let il, maxm = aux 1 newmeta context in
+ let indexes, equalities = List.split il in
+ indexes, equalities, maxm
+;;
+
+
+(*
+let equations_blacklist =
+ List.fold_left
+ (fun s u -> UriManager.UriSet.add (UriManager.uri_of_string u) s)
+ UriManager.UriSet.empty [
+ "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)";
+ "cic:/Coq/Init/Logic/trans_eq.con";
+ "cic:/Coq/Init/Logic/f_equal.con";
+ "cic:/Coq/Init/Logic/f_equal2.con";
+ "cic:/Coq/Init/Logic/f_equal3.con";
+ "cic:/Coq/Init/Logic/f_equal4.con";
+ "cic:/Coq/Init/Logic/f_equal5.con";
+ "cic:/Coq/Init/Logic/sym_eq.con";
+ "cic:/Coq/Init/Logic/eq_ind.con";
+ "cic:/Coq/Init/Logic/eq_ind_r.con";
+ "cic:/Coq/Init/Logic/eq_rec.con";
+ "cic:/Coq/Init/Logic/eq_rec_r.con";
+ "cic:/Coq/Init/Logic/eq_rect.con";
+ "cic:/Coq/Init/Logic/eq_rect_r.con";
+ "cic:/Coq/Logic/Eqdep/UIP.con";
+ "cic:/Coq/Logic/Eqdep/UIP_refl.con";
+ "cic:/Coq/Logic/Eqdep_dec/eq2eqT.con";
+ "cic:/Coq/ZArith/Zcompare/rename.con";
+ (* ALB !!!! questo e` imbrogliare, ma x ora lo lasciamo cosi`...
+ perche' questo cacchio di teorema rompe le scatole :'( *)
+ "cic:/Rocq/SUBST/comparith/mult_n_2.con";
+
+ "cic:/matita/logic/equality/eq_f.con";
+ "cic:/matita/logic/equality/eq_f2.con";
+ "cic:/matita/logic/equality/eq_rec.con";
+ "cic:/matita/logic/equality/eq_rect.con";
+ ]
+;;
+*)
+let equations_blacklist = UriManager.UriSet.empty;;
+
+
+let find_library_equalities dbd context status maxmeta =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module T = CicTypeChecker in
+ let blacklist =
+ List.fold_left
+ (fun s u -> UriManager.UriSet.add u s)
+ equations_blacklist
+ [eq_XURI (); sym_eq_URI (); trans_eq_URI (); eq_ind_URI ();
+ eq_ind_r_URI ()]
+ in
+ let candidates =
+ List.fold_left
+ (fun l uri ->
+ if UriManager.UriSet.mem uri blacklist then
+ l
+ else
+ let t = CicUtil.term_of_uri uri in
+ let ty, _ =
+ CicTypeChecker.type_of_aux' [] context t CicUniv.empty_ugraph
+ in
+ (uri, t, ty)::l)
+ []
+ (let t1 = Unix.gettimeofday () in
+ let eqs = (MetadataQuery.equations_for_goal ~dbd status) in
+ let t2 = Unix.gettimeofday () in
+ (debug_print
+ (lazy
+ (Printf.sprintf "Tempo di MetadataQuery.equations_for_goal: %.9f\n"
+ (t2 -. t1))));
+ eqs)
+ in
+ let eq_uri1 = eq_XURI ()
+ and eq_uri2 = LibraryObjects.eq_URI () in
+ let iseq uri =
+ (UriManager.eq uri eq_uri1) || (UriManager.eq uri eq_uri2)
+ in
+ let ok_types ty menv =
+ List.for_all (fun (_, _, mt) -> mt = ty) menv
+ in
+ let rec has_vars = function
+ | C.Meta _ | C.Rel _ | C.Const _ -> false
+ | C.Var _ -> true
+ | C.Appl l -> List.exists has_vars l
+ | C.Prod (_, s, t) | C.Lambda (_, s, t)
+ | C.LetIn (_, s, t) | C.Cast (s, t) ->
+ (has_vars s) || (has_vars t)
+ | _ -> false
+ in
+ let rec aux newmeta = function
+ | [] -> [], newmeta
+ | (uri, term, termty)::tl ->
+ debug_print
+ (lazy
+ (Printf.sprintf "Examining: %s (%s)"
+ (CicPp.ppterm term) (CicPp.ppterm termty)));
+ let res, newmeta =
+ match termty with
+ | C.Prod (name, s, t) when not (has_vars termty) ->
+ let head, newmetas, args, newmeta =
+ ProofEngineHelpers.saturate_term newmeta [] context termty 0
+ in
+ let p =
+ if List.length args = 0 then
+ term
+ else
+ C.Appl (term::args)
+ in (
+ match head with
+ | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
+ when (iseq uri) && (ok_types ty newmetas) ->
+ debug_print
+ (lazy
+ (Printf.sprintf "OK: %s" (CicPp.ppterm term)));
+ let o = !Utils.compare_terms t1 t2 in
+ let w = compute_equality_weight ty t1 t2 in
+ let proof = BasicProof p in
+ let e = (w, proof, (ty, t1, t2, o), newmetas, args) in
+ Some e, (newmeta+1)
+ | _ -> None, newmeta
+ )
+ | C.Appl [C.MutInd (uri, _, _); ty; t1; t2]
+ when iseq uri && not (has_vars termty) ->
+ let o = !Utils.compare_terms t1 t2 in
+ let w = compute_equality_weight ty t1 t2 in
+ let e = (w, BasicProof term, (ty, t1, t2, o), [], []) in
+ Some e, (newmeta+1)
+ | _ -> None, newmeta
+ in
+ match res with
+ | Some e ->
+ let tl, newmeta' = aux newmeta tl in
+ if newmeta' < newmeta then
+ prerr_endline "big trouble";
+ (uri, e)::tl, newmeta' (* max???? *)
+ | None ->
+ aux newmeta tl
+ in
+ let found, maxm = aux maxmeta candidates in
+ let uriset, eqlist =
+ (List.fold_left
+ (fun (s, l) (u, e) ->
+ if List.exists (meta_convertibility_eq e) (List.map snd l) then (
+ debug_print
+ (lazy
+ (Printf.sprintf "NO!! %s already there!"
+ (string_of_equality e)));
+ (UriManager.UriSet.add u s, l)
+ ) else (UriManager.UriSet.add u s, (u, e)::l))
+ (UriManager.UriSet.empty, []) found)
+ in
+ uriset, eqlist, maxm
+;;
+
+
+let find_library_theorems dbd env status equalities_uris =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module T = CicTypeChecker in
+ let blacklist =
+ let refl_equal =
+ UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)" in
+ let s =
+ UriManager.UriSet.remove refl_equal
+ (UriManager.UriSet.union equalities_uris equations_blacklist)
+ in
+ List.fold_left
+ (fun s u -> UriManager.UriSet.add u s)
+ s [eq_XURI () ;sym_eq_URI (); trans_eq_URI (); eq_ind_URI ();
+ eq_ind_r_URI ()]
+ in
+ let metasenv, context, ugraph = env in
+ let candidates =
+ List.fold_left
+ (fun l uri ->
+ if UriManager.UriSet.mem uri blacklist then l
+ else
+ let t = CicUtil.term_of_uri uri in
+ let ty, _ = CicTypeChecker.type_of_aux' metasenv context t ugraph in
+ (t, ty, [])::l)
+ [] (MetadataQuery.signature_of_goal ~dbd status)
+ in
+ let refl_equal =
+ let u = eq_XURI () in
+ let t = CicUtil.term_of_uri u in
+ let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in
+ (t, ty, [])
+ in
+ refl_equal::candidates
+;;
+
+
+let find_context_hypotheses env equalities_indexes =
+ let metasenv, context, ugraph = env in
+ let _, res =
+ List.fold_left
+ (fun (n, l) entry ->
+ match entry with
+ | None -> (n+1, l)
+ | Some _ ->
+ if List.mem n equalities_indexes then
+ (n+1, l)
+ else
+ let t = Cic.Rel n in
+ let ty, _ =
+ CicTypeChecker.type_of_aux' metasenv context t ugraph in
+ (n+1, (t, ty, [])::l))
+ (1, []) context
+ in
+ res
+;;
+
+
+let fix_metas_old newmeta (w, p, (ty, left, right, o), menv, args) =
+ let table = Hashtbl.create (List.length args) in
+
+ let newargs, newmeta =
+ List.fold_right
+ (fun t (newargs, index) ->
+ match t with
+ | Cic.Meta (i, l) ->
+ if Hashtbl.mem table i then
+ let idx = Hashtbl.find table i in
+ ((Cic.Meta (idx, l))::newargs, index+1)
+ else
+ let _ = Hashtbl.add table i index in
+ ((Cic.Meta (index, l))::newargs, index+1)
+ | _ -> assert false)
+ args ([], newmeta+1)
+ in
+
+ let repl where =
+ ProofEngineReduction.replace ~equality:(=) ~what:args ~with_what:newargs
+ ~where
+ in
+ let menv' =
+ List.fold_right
+ (fun (i, context, term) menv ->
+ try
+ let index = Hashtbl.find table i in
+ (index, context, term)::menv
+ with Not_found ->
+ (i, context, term)::menv)
+ menv []
+ in
+ let ty = repl ty
+ and left = repl left
+ and right = repl right in
+ let metas = (metas_of_term left) @ (metas_of_term right) @ (metas_of_term ty) in
+ let menv' = List.filter (fun (i, _, _) -> List.mem i metas) menv' in
+ let newargs =
+ List.filter
+ (function Cic.Meta (i, _) -> List.mem i metas | _ -> assert false) newargs
+ in
+ let _ =
+ if List.length metas > 0 then
+ let first = List.hd metas in
+ (* this new equality might have less variables than its parents: here
+ we fill the gap with a dummy arg. Example:
+ with (f X Y) = X we can simplify
+ (g X) = (f X Y) in
+ (g X) = X.
+ So the new equation has only one variable, but it still has type like
+ \lambda X,Y:..., so we need to pass a dummy arg for Y
+ (I hope this makes some sense...)
+ *)
+ Hashtbl.iter
+ (fun k v ->
+ if not (List.exists
+ (function Cic.Meta (i, _) -> i = v | _ -> assert false)
+ newargs) then
+ Hashtbl.replace table k first)
+ (Hashtbl.copy table)
+ in
+ let rec fix_proof = function
+ | NoProof -> NoProof
+ | BasicProof term -> BasicProof (repl term)
+ | ProofBlock (subst, eq_URI, namety, bo, (pos, eq), p) ->
+ let subst' =
+ List.fold_left
+ (fun s arg ->
+ match arg with
+ | Cic.Meta (i, l) -> (
+ try
+ let j = Hashtbl.find table i in
+ if List.mem_assoc i subst then
+ s
+ else
+ let _, context, ty = CicUtil.lookup_meta i menv in
+ (i, (context, Cic.Meta (j, l), ty))::s
+ with Not_found | CicUtil.Meta_not_found _ ->
+ s
+ )
+ | _ -> assert false)
+ [] args
+ in
+ ProofBlock (subst' @ subst, eq_URI, namety, bo(* t' *), (pos, eq), p)
+ | p -> assert false
+ in
+ let neweq = (w, fix_proof p, (ty, left, right, o), menv', newargs) in
+ (newmeta +1, neweq)
+;;
+
+
+let relocate newmeta menv =
+ let subst, metasenv, newmeta =
+ List.fold_right
+ (fun (i, context, ty) (subst, menv, maxmeta) ->
+ let irl=CicMkImplicit.identity_relocation_list_for_metavariable context in
+ let newsubst = (i, (context, (Cic.Meta (maxmeta, irl)), ty)) in
+ let newmeta = maxmeta, context, ty in
+ newsubst::subst, newmeta::menv, maxmeta+1)
+ menv ([], [], newmeta+1)
+ in
+ let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
+ let subst =
+ List.map
+ (fun (i, (context, term, ty)) ->
+ let context = CicMetaSubst.apply_subst_context subst context in
+ let term = CicMetaSubst.apply_subst subst term in
+ let ty = CicMetaSubst.apply_subst subst ty in
+ (i, (context, term, ty))) subst in
+ subst, metasenv, newmeta
+
+
+let fix_metas newmeta (w, p, (ty, left, right, o), menv, args) =
+ (* debug
+ let _ , eq =
+ fix_metas_old newmeta (w, p, (ty, left, right, o), menv, args) in
+ prerr_endline (string_of_equality eq); *)
+ let subst, metasenv, newmeta = relocate newmeta menv in
+ let ty = CicMetaSubst.apply_subst subst ty in
+ let left = CicMetaSubst.apply_subst subst left in
+ let right = CicMetaSubst.apply_subst subst right in
+ let args = List.map (CicMetaSubst.apply_subst subst) args in
+ let rec fix_proof = function
+ | NoProof -> NoProof
+ | BasicProof term -> BasicProof (CicMetaSubst.apply_subst subst term)
+ | ProofBlock (subst', eq_URI, namety, bo, (pos, eq), p) ->
+ ProofBlock (subst' @ subst, eq_URI, namety, bo, (pos, eq), p)
+ | p -> assert false
+ in
+ let metas = (metas_of_term left)@(metas_of_term right)@(metas_of_term ty) in
+ let metasenv = List.filter (fun (i, _, _) -> List.mem i metas) metasenv in
+ let eq = (w, fix_proof p, (ty, left, right, o), metasenv, args) in
+ (* debug prerr_endline (string_of_equality eq); *)
+ newmeta, eq
+
+let term_is_equality term =
+ let iseq uri = UriManager.eq uri (LibraryObjects.eq_URI ()) in
+ match term with
+ | Cic.Appl [Cic.MutInd (uri, _, _); _; _; _] when iseq uri -> true
+ | _ -> false
+;;
+
+
+exception TermIsNotAnEquality;;
+
+let equality_of_term proof term =
+ let eq_uri = LibraryObjects.eq_URI () in
+ let iseq uri = UriManager.eq uri eq_uri in
+ match term with
+ | Cic.Appl [Cic.MutInd (uri, _, _); ty; t1; t2] when iseq uri ->
+ let o = !Utils.compare_terms t1 t2 in
+ let w = compute_equality_weight ty t1 t2 in
+ let e = (w, BasicProof proof, (ty, t1, t2, o), [], []) in
+ e
+ | _ ->
+ raise TermIsNotAnEquality
+;;
+
+
+type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph;;
+
+let is_weak_identity (metasenv, context, ugraph) = function
+ | (_, _, (ty, left, right, _), menv, _) ->
+ (left = right ||
+ (meta_convertibility left right))
+ (* the test below is not a good idea since it stops
+ demodulation too early *)
+ (* (fst (CicReduction.are_convertible
+ ~metasenv:(metasenv @ menv) context left right ugraph)))*)
+;;
+
+let is_identity (metasenv, context, ugraph) = function
+ | (_, _, (ty, left, right, _), menv, _) ->
+ (left = right ||
+ (* (meta_convertibility left right)) *)
+ (fst (CicReduction.are_convertible
+ ~metasenv:(metasenv @ menv) context left right ugraph)))
+;;
+
+
+let term_of_equality equality =
+ let _, _, (ty, left, right, _), menv, args = equality in
+ let eq i = function Cic.Meta (j, _) -> i = j | _ -> false in
+ let argsno = List.length args in
+ let t =
+ CicSubstitution.lift argsno
+ (Cic.Appl [Cic.MutInd (LibraryObjects.eq_URI (), 0, []); ty; left; right])
+ in
+ snd (
+ List.fold_right
+ (fun a (n, t) ->
+ match a with
+ | Cic.Meta (i, _) ->
+ let name = Cic.Name ("X" ^ (string_of_int n)) in
+ let _, _, ty = CicUtil.lookup_meta i menv in
+ let t =
+ ProofEngineReduction.replace
+ ~equality:eq ~what:[i]
+ ~with_what:[Cic.Rel (argsno - (n - 1))] ~where:t
+ in
+ (n-1, Cic.Prod (name, ty, t))
+ | _ -> assert false)
+ args (argsno, t))
+;;
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+type equality =
+ int * (* weight *)
+ proof * (* proof *)
+ (Cic.term * (* type *)
+ Cic.term * (* left side *)
+ Cic.term * (* right side *)
+ Utils.comparison) * (* ordering *)
+ Cic.metasenv * (* environment for metas *)
+ Cic.term list (* arguments *)
+
+and proof =
+ | NoProof (* no proof *)
+ | BasicProof of Cic.term (* already a proof of a goal *)
+ | ProofBlock of (* proof of a rewrite step *)
+ Cic.substitution * UriManager.uri * (* eq_ind or eq_ind_r *)
+ (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof
+ | ProofGoalBlock of proof * proof
+ (* proof of the new meta, proof of the goal from which this comes *)
+ | ProofSymBlock of Cic.term list * proof (* expl.named subst, proof *)
+ | SubProof of Cic.term * int * proof
+ (* parent proof, subgoal, proof of the subgoal *)
+
+type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph
+
+(** builds the Cic.term encoded by proof *)
+val build_proof_term: ?noproof:Cic.term -> proof -> Cic.term
+
+val string_of_proof: proof -> string
+
+exception MatchingFailure
+
+(** matching between two terms. Can raise MatchingFailure *)
+val matching:
+ Cic.metasenv -> Cic.context -> Cic.term -> Cic.term ->
+ CicUniv.universe_graph ->
+ Cic.substitution * Cic.metasenv * CicUniv.universe_graph
+
+(**
+ special unification that checks if the two terms are "simple", and in
+ such case should be significantly faster than CicUnification.fo_unif
+*)
+val unification:
+ Cic.metasenv -> Cic.context -> Cic.term -> Cic.term ->
+ CicUniv.universe_graph ->
+ Cic.substitution * Cic.metasenv * CicUniv.universe_graph
+
+
+(**
+ scans the context to find all Declarations "left = right"; returns a
+ list of tuples (proof, (type, left, right), newmetas). Uses
+ PrimitiveTactics.new_metasenv_for_apply to replace bound variables with
+ fresh metas...
+*)
+val find_equalities:
+ Cic.context -> ProofEngineTypes.proof -> int list * equality list * int
+
+(**
+ searches the library for equalities that can be applied to the current goal
+*)
+val find_library_equalities:
+ HMysql.dbd -> Cic.context -> ProofEngineTypes.status -> int ->
+ UriManager.UriSet.t * (UriManager.uri * equality) list * int
+
+(**
+ searches the library for theorems that are not equalities (returned by the
+ function above)
+*)
+val find_library_theorems:
+ HMysql.dbd -> environment -> ProofEngineTypes.status -> UriManager.UriSet.t ->
+ (Cic.term * Cic.term * Cic.metasenv) list
+
+(**
+ searches the context for hypotheses that are not equalities
+*)
+val find_context_hypotheses:
+ environment -> int list -> (Cic.term * Cic.term * Cic.metasenv) list
+
+
+exception TermIsNotAnEquality;;
+
+(**
+ raises TermIsNotAnEquality if term is not an equation.
+ The first Cic.term is a proof of the equation
+*)
+val equality_of_term: Cic.term -> Cic.term -> equality
+
+(**
+ Re-builds the term corresponding to this equality
+*)
+val term_of_equality: equality -> Cic.term
+
+val term_is_equality: Cic.term -> bool
+
+(** tests a sort of alpha-convertibility between the two terms, but on the
+ metavariables *)
+val meta_convertibility: Cic.term -> Cic.term -> bool
+
+(** meta convertibility between two equations *)
+val meta_convertibility_eq: equality -> equality -> bool
+
+val is_weak_identity: environment -> equality -> bool
+val is_identity: environment -> equality -> bool
+
+val string_of_equality: ?env:environment -> equality -> string
+
+val metas_of_term: Cic.term -> int list
+
+(** ensures that metavariables in equality are unique *)
+val fix_metas: int -> equality -> int * equality
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+module Trivial_disambiguate:
+sig
+ exception Ambiguous_term of string Lazy.t
+ (** disambiguate an _unanmbiguous_ term using dummy callbacks which fail if a
+ * choice from the user is needed to disambiguate the term
+ * @raise Ambiguous_term for ambiguous term *)
+ val disambiguate_string:
+ dbd:HMysql.dbd ->
+ ?context:Cic.context ->
+ ?metasenv:Cic.metasenv ->
+ ?initial_ugraph:CicUniv.universe_graph ->
+ ?aliases:DisambiguateTypes.environment ->(* previous interpretation status*)
+ string ->
+ ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list *
+ Cic.metasenv * (* new metasenv *)
+ Cic.term *
+ CicUniv.universe_graph) list (* disambiguated term *)
+end
+=
+struct
+ exception Ambiguous_term of string Lazy.t
+ exception Exit
+ module Callbacks =
+ struct
+ let non p x = not (p x)
+ let interactive_user_uri_choice ~selection_mode ?ok
+ ?(enable_button_for_non_vars = true) ~title ~msg ~id uris =
+ List.filter (non UriManager.uri_is_var) uris
+ let interactive_interpretation_choice interp = raise Exit
+ let input_or_locate_uri ~(title:string) ?id = raise Exit
+ end
+ module Disambiguator = Disambiguate.Make (Callbacks)
+ let disambiguate_string ~dbd ?(context = []) ?(metasenv = []) ?initial_ugraph
+ ?(aliases = DisambiguateTypes.Environment.empty) term
+ =
+ let ast =
+ CicNotationParser.parse_level2_ast (Ulexing.from_utf8_string term)
+ in
+ try
+ fst (Disambiguator.disambiguate_term ~dbd ~context ~metasenv ast
+ ?initial_ugraph ~aliases ~universe:None)
+ with Exit -> raise (Ambiguous_term (lazy term))
+end
+
+let configuration_file = ref "../../../matita/matita.conf.xml";;
+
+let core_notation_script = "../../../matita/core_notation.moo";;
+
+let get_from_user ~(dbd:HMysql.dbd) =
+ let rec get () =
+ match read_line () with
+ | "" -> []
+ | t -> t::(get ())
+ in
+ let term_string = String.concat "\n" (get ()) in
+ let env, metasenv, term, ugraph =
+ List.nth (Trivial_disambiguate.disambiguate_string dbd term_string) 0
+ in
+ term, metasenv, ugraph
+;;
+
+let full = ref false;;
+
+let retrieve_only = ref false;;
+
+let demod_equalities = ref false;;
+
+let main () =
+ let module S = Saturation in
+ let set_ratio v = S.weight_age_ratio := v; S.weight_age_counter := v
+ and set_sel v = S.symbols_ratio := v; S.symbols_counter := v;
+ and set_conf f = configuration_file := f
+ and set_ordering o =
+ match o with
+ | "lpo" -> Utils.compare_terms := Utils.lpo
+ | "kbo" -> Utils.compare_terms := Utils.kbo
+ | "nr-kbo" -> Utils.compare_terms := Utils.nonrec_kbo
+ | "ao" -> Utils.compare_terms := Utils.ao
+ | o -> raise (Arg.Bad ("Unknown term ordering: " ^ o))
+ and set_fullred b = S.use_fullred := b
+ and set_time_limit v = S.time_limit := float_of_int v
+ and set_width w = S.maxwidth := w
+ and set_depth d = S.maxdepth := d
+ and set_full () = full := true
+ and set_retrieve () = retrieve_only := true
+ and set_demod_equalities () = demod_equalities := true
+ in
+ Arg.parse [
+ "-full", Arg.Unit set_full, "Enable full mode";
+ "-f", Arg.Bool set_fullred,
+ "Enable/disable full-reduction strategy (default: enabled)";
+
+ "-r", Arg.Int set_ratio, "Weight-Age equality selection ratio (default: 4)";
+
+ "-s", Arg.Int set_sel,
+ "symbols-based selection ratio (relative to the weight ratio, default: 0)";
+
+ "-c", Arg.String set_conf, "Configuration file (for the db connection)";
+
+ "-o", Arg.String set_ordering,
+ "Term ordering. Possible values are:\n" ^
+ "\tkbo: Knuth-Bendix ordering\n" ^
+ "\tnr-kbo: Non-recursive variant of kbo (default)\n" ^
+ "\tlpo: Lexicographic path ordering";
+
+ "-l", Arg.Int set_time_limit, "Time limit in seconds (default: no limit)";
+
+ "-w", Arg.Int set_width,
+ Printf.sprintf "Maximal width (default: %d)" !Saturation.maxwidth;
+
+ "-d", Arg.Int set_depth,
+ Printf.sprintf "Maximal depth (default: %d)" !Saturation.maxdepth;
+
+ "-retrieve", Arg.Unit set_retrieve, "retrieve only";
+ "-demod-equalities", Arg.Unit set_demod_equalities, "demod equalities";
+ ] (fun a -> ()) "Usage:";
+ Helm_registry.load_from !configuration_file;
+ ignore (CicNotation2.load_notation [] core_notation_script);
+ ignore (CicNotation2.load_notation [] "../../../matita/library/legacy/coq.ma");
+ let dbd = HMysql.quick_connect
+ ~host:(Helm_registry.get "db.host")
+ ~user:(Helm_registry.get "db.user")
+ ~database:(Helm_registry.get "db.database")
+ ()
+ in
+ let term, metasenv, ugraph = get_from_user ~dbd in
+ if !retrieve_only then
+ Saturation.retrieve_and_print dbd term metasenv ugraph
+ else if !demod_equalities then
+ Saturation.main_demod_equalities dbd term metasenv ugraph
+ else
+ Saturation.main dbd !full term metasenv ugraph
+;;
+
+let _ =
+ (*try*)
+ main ()
+ (*with exn -> prerr_endline (Printexc.to_string exn)*)
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+open Inference;;
+open Utils;;
+
+(*
+for debugging
+let check_equation env equation msg =
+ let w, proof, (eq_ty, left, right, order), metas, args = equation in
+ let metasenv, context, ugraph = env in
+ let metasenv' = metasenv @ metas in
+ try
+ CicTypeChecker.type_of_aux' metasenv' context left ugraph;
+ CicTypeChecker.type_of_aux' metasenv' context right ugraph;
+ ()
+ with
+ CicUtil.Meta_not_found _ as exn ->
+ begin
+ prerr_endline msg;
+ prerr_endline (CicPp.ppterm left);
+ prerr_endline (CicPp.ppterm right);
+ raise exn
+ end
+*)
+
+(* set to false to disable paramodulation inside auto_tac *)
+let connect_to_auto = true;;
+
+
+(* profiling statistics... *)
+let infer_time = ref 0.;;
+let forward_simpl_time = ref 0.;;
+let forward_simpl_new_time = ref 0.;;
+let backward_simpl_time = ref 0.;;
+let passive_maintainance_time = ref 0.;;
+
+(* limited-resource-strategy related globals *)
+let processed_clauses = ref 0;; (* number of equalities selected so far... *)
+let time_limit = ref 0.;; (* in seconds, settable by the user... *)
+let start_time = ref 0.;; (* time at which the execution started *)
+let elapsed_time = ref 0.;;
+(* let maximal_weight = ref None;; *)
+let maximal_retained_equality = ref None;;
+
+(* equality-selection related globals *)
+let use_fullred = ref true;;
+let weight_age_ratio = ref (* 5 *) 4;; (* settable by the user *)
+let weight_age_counter = ref !weight_age_ratio;;
+let symbols_ratio = ref (* 0 *) 3;;
+let symbols_counter = ref 0;;
+
+(* non-recursive Knuth-Bendix term ordering by default *)
+(* Utils.compare_terms := Utils.rpo;; *)
+(* Utils.compare_terms := Utils.nonrec_kbo;; *)
+(* Utils.compare_terms := Utils.ao;; *)
+
+(* statistics... *)
+let derived_clauses = ref 0;;
+let kept_clauses = ref 0;;
+
+(* index of the greatest Cic.Meta created - TODO: find a better way! *)
+let maxmeta = ref 0;;
+
+(* varbiables controlling the search-space *)
+let maxdepth = ref 3;;
+let maxwidth = ref 3;;
+
+
+type result =
+ | ParamodulationFailure
+ | ParamodulationSuccess of Inference.proof option * environment
+;;
+
+type goal = proof * Cic.metasenv * Cic.term;;
+
+type theorem = Cic.term * Cic.term * Cic.metasenv;;
+
+let symbols_of_equality (_, _, (_, left, right, _), _, _) =
+ let m1 = symbols_of_term left in
+ let m =
+ TermMap.fold
+ (fun k v res ->
+ try
+ let c = TermMap.find k res in
+ TermMap.add k (c+v) res
+ with Not_found ->
+ TermMap.add k v res)
+ (symbols_of_term right) m1
+ in
+ m
+;;
+
+module OrderedEquality = struct
+ type t = Inference.equality
+
+ let compare eq1 eq2 =
+ match meta_convertibility_eq eq1 eq2 with
+ | true -> 0
+ | false ->
+ let w1, _, (ty, left, right, _), _, a = eq1
+ and w2, _, (ty', left', right', _), _, a' = eq2 in
+ match Pervasives.compare w1 w2 with
+ | 0 ->
+ let res = (List.length a) - (List.length a') in
+ if res <> 0 then res else (
+ try
+ let res = Pervasives.compare (List.hd a) (List.hd a') in
+ if res <> 0 then res else Pervasives.compare eq1 eq2
+ with Failure "hd" -> Pervasives.compare eq1 eq2
+ )
+ | res -> res
+end
+
+module EqualitySet = Set.Make(OrderedEquality);;
+
+
+(**
+ selects one equality from passive. The selection strategy is a combination
+ of weight, age and goal-similarity
+*)
+let select env goals passive (active, _) =
+ processed_clauses := !processed_clauses + 1;
+ let goal =
+ match (List.rev goals) with (_, goal::_)::_ -> goal | _ -> assert false
+ in
+ let (neg_list, neg_set), (pos_list, pos_set), passive_table = passive in
+ let remove eq l =
+ List.filter (fun e -> e <> eq) l
+ in
+ if !weight_age_ratio > 0 then
+ weight_age_counter := !weight_age_counter - 1;
+ match !weight_age_counter with
+ | 0 -> (
+ weight_age_counter := !weight_age_ratio;
+ match neg_list, pos_list with
+ | hd::tl, pos ->
+ (* Negatives aren't indexed, no need to remove them... *)
+ (Negative, hd),
+ ((tl, EqualitySet.remove hd neg_set), (pos, pos_set), passive_table)
+ | [], (hd:EqualitySet.elt)::tl ->
+ let passive_table =
+ Indexing.remove_index passive_table hd
+ in
+ (Positive, hd),
+ (([], neg_set), (tl, EqualitySet.remove hd pos_set), passive_table)
+ | _, _ -> assert false
+ )
+ | _ when (!symbols_counter > 0) && (EqualitySet.is_empty neg_set) -> (
+ symbols_counter := !symbols_counter - 1;
+ let cardinality map =
+ TermMap.fold (fun k v res -> res + v) map 0
+ in
+ let symbols =
+ let _, _, term = goal in
+ symbols_of_term term
+ in
+ let card = cardinality symbols in
+ let foldfun k v (r1, r2) =
+ if TermMap.mem k symbols then
+ let c = TermMap.find k symbols in
+ let c1 = abs (c - v) in
+ let c2 = v - c1 in
+ r1 + c2, r2 + c1
+ else
+ r1, r2 + v
+ in
+ let f equality (i, e) =
+ let common, others =
+ TermMap.fold foldfun (symbols_of_equality equality) (0, 0)
+ in
+ let c = others + (abs (common - card)) in
+ if c < i then (c, equality)
+ else (i, e)
+ in
+ let e1 = EqualitySet.min_elt pos_set in
+ let initial =
+ let common, others =
+ TermMap.fold foldfun (symbols_of_equality e1) (0, 0)
+ in
+ (others + (abs (common - card))), e1
+ in
+ let _, current = EqualitySet.fold f pos_set initial in
+ let passive_table =
+ Indexing.remove_index passive_table current
+ in
+ (Positive, current),
+ (([], neg_set),
+ (remove current pos_list, EqualitySet.remove current pos_set),
+ passive_table)
+ )
+ | _ ->
+ symbols_counter := !symbols_ratio;
+ let set_selection set = EqualitySet.min_elt set in
+ if EqualitySet.is_empty neg_set then
+ let current = set_selection pos_set in
+ let passive =
+ (neg_list, neg_set),
+ (remove current pos_list, EqualitySet.remove current pos_set),
+ Indexing.remove_index passive_table current
+ in
+ (Positive, current), passive
+ else
+ let current = set_selection neg_set in
+ let passive =
+ (remove current neg_list, EqualitySet.remove current neg_set),
+ (pos_list, pos_set),
+ passive_table
+ in
+ (Negative, current), passive
+;;
+
+
+(* initializes the passive set of equalities *)
+let make_passive neg pos =
+ let set_of equalities =
+ List.fold_left (fun s e -> EqualitySet.add e s) EqualitySet.empty equalities
+ in
+ let table =
+ List.fold_left (fun tbl e -> Indexing.index tbl e) Indexing.empty pos
+ in
+ (neg, set_of neg),
+ (pos, set_of pos),
+ table
+;;
+
+
+let make_active () =
+ [], Indexing.empty
+;;
+
+
+(* adds to passive a list of equalities: new_neg is a list of negative
+ equalities, new_pos a list of positive equalities *)
+let add_to_passive passive (new_neg, new_pos) =
+ let (neg_list, neg_set), (pos_list, pos_set), table = passive in
+ let ok set equality = not (EqualitySet.mem equality set) in
+ let neg = List.filter (ok neg_set) new_neg
+ and pos = List.filter (ok pos_set) new_pos in
+ let table =
+ List.fold_left (fun tbl e -> Indexing.index tbl e) table pos
+ in
+ let add set equalities =
+ List.fold_left (fun s e -> EqualitySet.add e s) set equalities
+ in
+ (neg @ neg_list, add neg_set neg),
+ (pos_list @ pos, add pos_set pos),
+ table
+;;
+
+
+let passive_is_empty = function
+ | ([], _), ([], _), _ -> true
+ | _ -> false
+;;
+
+
+let size_of_passive ((_, ns), (_, ps), _) =
+ (EqualitySet.cardinal ns) + (EqualitySet.cardinal ps)
+;;
+
+
+let size_of_active (active_list, _) =
+ List.length active_list
+;;
+
+
+(* removes from passive equalities that are estimated impossible to activate
+ within the current time limit *)
+let prune_passive howmany (active, _) passive =
+ let (nl, ns), (pl, ps), tbl = passive in
+ let howmany = float_of_int howmany
+ and ratio = float_of_int !weight_age_ratio in
+ let round v =
+ let t = ceil v in
+ int_of_float (if t -. v < 0.5 then t else v)
+ in
+ let in_weight = round (howmany *. ratio /. (ratio +. 1.))
+ and in_age = round (howmany /. (ratio +. 1.)) in
+ debug_print
+ (lazy (Printf.sprintf "in_weight: %d, in_age: %d\n" in_weight in_age));
+ let symbols, card =
+ match active with
+ | (Negative, e)::_ ->
+ let symbols = symbols_of_equality e in
+ let card = TermMap.fold (fun k v res -> res + v) symbols 0 in
+ Some symbols, card
+ | _ -> None, 0
+ in
+ let counter = ref !symbols_ratio in
+ let rec pickw w ns ps =
+ if w > 0 then
+ if not (EqualitySet.is_empty ns) then
+ let e = EqualitySet.min_elt ns in
+ let ns', ps = pickw (w-1) (EqualitySet.remove e ns) ps in
+ EqualitySet.add e ns', ps
+ else if !counter > 0 then
+ let _ =
+ counter := !counter - 1;
+ if !counter = 0 then counter := !symbols_ratio
+ in
+ match symbols with
+ | None ->
+ let e = EqualitySet.min_elt ps in
+ let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in
+ ns, EqualitySet.add e ps'
+ | Some symbols ->
+ let foldfun k v (r1, r2) =
+ if TermMap.mem k symbols then
+ let c = TermMap.find k symbols in
+ let c1 = abs (c - v) in
+ let c2 = v - c1 in
+ r1 + c2, r2 + c1
+ else
+ r1, r2 + v
+ in
+ let f equality (i, e) =
+ let common, others =
+ TermMap.fold foldfun (symbols_of_equality equality) (0, 0)
+ in
+ let c = others + (abs (common - card)) in
+ if c < i then (c, equality)
+ else (i, e)
+ in
+ let e1 = EqualitySet.min_elt ps in
+ let initial =
+ let common, others =
+ TermMap.fold foldfun (symbols_of_equality e1) (0, 0)
+ in
+ (others + (abs (common - card))), e1
+ in
+ let _, e = EqualitySet.fold f ps initial in
+ let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in
+ ns, EqualitySet.add e ps'
+ else
+ let e = EqualitySet.min_elt ps in
+ let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in
+ ns, EqualitySet.add e ps'
+ else
+ EqualitySet.empty, EqualitySet.empty
+ in
+ let ns, ps = pickw in_weight ns ps in
+ let rec picka w s l =
+ if w > 0 then
+ match l with
+ | [] -> w, s, []
+ | hd::tl when not (EqualitySet.mem hd s) ->
+ let w, s, l = picka (w-1) s tl in
+ w, EqualitySet.add hd s, hd::l
+ | hd::tl ->
+ let w, s, l = picka w s tl in
+ w, s, hd::l
+ else
+ 0, s, l
+ in
+ let in_age, ns, nl = picka in_age ns nl in
+ let _, ps, pl = picka in_age ps pl in
+ if not (EqualitySet.is_empty ps) then
+ maximal_retained_equality := Some (EqualitySet.max_elt ps);
+ let tbl =
+ EqualitySet.fold
+ (fun e tbl -> Indexing.index tbl e) ps Indexing.empty
+ in
+ (nl, ns), (pl, ps), tbl
+;;
+
+
+(** inference of new equalities between current and some in active *)
+let infer env sign current (active_list, active_table) =
+ let new_neg, new_pos =
+ match sign with
+ | Negative ->
+ let maxm, res =
+ Indexing.superposition_left !maxmeta env active_table current in
+ maxmeta := maxm;
+ res, []
+ | Positive ->
+ let maxm, res =
+ Indexing.superposition_right !maxmeta env active_table current in
+ maxmeta := maxm;
+ let rec infer_positive table = function
+ | [] -> [], []
+ | (Negative, equality)::tl ->
+ let maxm, res =
+ Indexing.superposition_left !maxmeta env table equality in
+ maxmeta := maxm;
+ let neg, pos = infer_positive table tl in
+ res @ neg, pos
+ | (Positive, equality)::tl ->
+ let maxm, res =
+ Indexing.superposition_right !maxmeta env table equality in
+ maxmeta := maxm;
+ let neg, pos = infer_positive table tl in
+ neg, res @ pos
+ in
+ let curr_table = Indexing.index Indexing.empty current in
+ let neg, pos = infer_positive curr_table active_list in
+ neg, res @ pos
+ in
+ derived_clauses := !derived_clauses + (List.length new_neg) +
+ (List.length new_pos);
+ match !maximal_retained_equality with
+ | None -> new_neg, new_pos
+ | Some eq ->
+ (* if we have a maximal_retained_equality, we can discard all equalities
+ "greater" than it, as they will never be reached... An equality is
+ greater than maximal_retained_equality if it is bigger
+ wrt. OrderedEquality.compare and it is less similar than
+ maximal_retained_equality to the current goal *)
+ let symbols, card =
+ match active_list with
+ | (Negative, e)::_ ->
+ let symbols = symbols_of_equality e in
+ let card = TermMap.fold (fun k v res -> res + v) symbols 0 in
+ Some symbols, card
+ | _ -> None, 0
+ in
+ let new_pos =
+ match symbols with
+ | None ->
+ List.filter (fun e -> OrderedEquality.compare e eq <= 0) new_pos
+ | Some symbols ->
+ let filterfun e =
+ if OrderedEquality.compare e eq <= 0 then
+ true
+ else
+ let foldfun k v (r1, r2) =
+ if TermMap.mem k symbols then
+ let c = TermMap.find k symbols in
+ let c1 = abs (c - v) in
+ let c2 = v - c1 in
+ r1 + c2, r2 + c1
+ else
+ r1, r2 + v
+ in
+ let initial =
+ let common, others =
+ TermMap.fold foldfun (symbols_of_equality eq) (0, 0) in
+ others + (abs (common - card))
+ in
+ let common, others =
+ TermMap.fold foldfun (symbols_of_equality e) (0, 0) in
+ let c = others + (abs (common - card)) in
+ if c < initial then true else false
+ in
+ List.filter filterfun new_pos
+ in
+ new_neg, new_pos
+;;
+
+
+let contains_empty env (negative, positive) =
+ let metasenv, context, ugraph = env in
+ try
+ let found =
+ List.find
+ (fun (w, proof, (ty, left, right, ordering), m, a) ->
+ fst (CicReduction.are_convertible context left right ugraph))
+ negative
+ in
+ true, Some found
+ with Not_found ->
+ false, None
+;;
+
+
+(** simplifies current using active and passive *)
+let forward_simplify env (sign, current) ?passive (active_list, active_table) =
+ let pl, passive_table =
+ match passive with
+ | None -> [], None
+ | Some ((pn, _), (pp, _), pt) ->
+ let pn = List.map (fun e -> (Negative, e)) pn
+ and pp = List.map (fun e -> (Positive, e)) pp in
+ pn @ pp, Some pt
+ in
+ let all = if pl = [] then active_list else active_list @ pl in
+
+ let demodulate table current =
+ let newmeta, newcurrent =
+ Indexing.demodulation_equality !maxmeta env table sign current in
+ maxmeta := newmeta;
+ if is_identity env newcurrent then
+ if sign = Negative then Some (sign, newcurrent)
+ else (
+(* debug_print *)
+(* (lazy *)
+(* (Printf.sprintf "\ncurrent was: %s\nnewcurrent is: %s\n" *)
+(* (string_of_equality current) *)
+(* (string_of_equality newcurrent))); *)
+(* debug_print *)
+(* (lazy *)
+(* (Printf.sprintf "active is: %s" *)
+(* (String.concat "\n" *)
+(* (List.map (fun (_, e) -> (string_of_equality e)) active_list)))); *)
+ None
+ )
+ else
+ Some (sign, newcurrent)
+ in
+ let res =
+ let res = demodulate active_table current in
+ match res with
+ | None -> None
+ | Some (sign, newcurrent) ->
+ match passive_table with
+ | None -> res
+ | Some passive_table -> demodulate passive_table newcurrent
+ in
+ match res with
+ | None -> None
+ | Some (Negative, c) ->
+ let ok = not (
+ List.exists
+ (fun (s, eq) -> s = Negative && meta_convertibility_eq eq c)
+ all)
+ in
+ if ok then res else None
+ | Some (Positive, c) ->
+ if Indexing.in_index active_table c then
+ None
+ else
+ match passive_table with
+ | None ->
+ if fst (Indexing.subsumption env active_table c) then
+ None
+ else
+ res
+ | Some passive_table ->
+ if Indexing.in_index passive_table c then None
+ else
+ let r1, _ = Indexing.subsumption env active_table c in
+ if r1 then None else
+ let r2, _ = Indexing.subsumption env passive_table c in
+ if r2 then None else res
+;;
+
+type fs_time_info_t = {
+ mutable build_all: float;
+ mutable demodulate: float;
+ mutable subsumption: float;
+};;
+
+let fs_time_info = { build_all = 0.; demodulate = 0.; subsumption = 0. };;
+
+
+(** simplifies new using active and passive *)
+let forward_simplify_new env (new_neg, new_pos) ?passive active =
+ let t1 = Unix.gettimeofday () in
+
+ let active_list, active_table = active in
+ let pl, passive_table =
+ match passive with
+ | None -> [], None
+ | Some ((pn, _), (pp, _), pt) ->
+ let pn = List.map (fun e -> (Negative, e)) pn
+ and pp = List.map (fun e -> (Positive, e)) pp in
+ pn @ pp, Some pt
+ in
+
+ let t2 = Unix.gettimeofday () in
+ fs_time_info.build_all <- fs_time_info.build_all +. (t2 -. t1);
+
+ let demodulate sign table target =
+ let newmeta, newtarget =
+ Indexing.demodulation_equality !maxmeta env table sign target in
+ maxmeta := newmeta;
+ newtarget
+ in
+ let t1 = Unix.gettimeofday () in
+
+ let new_neg, new_pos =
+ let new_neg = List.map (demodulate Negative active_table) new_neg
+ and new_pos = List.map (demodulate Positive active_table) new_pos in
+ new_neg,new_pos
+
+(* PROVA
+ match passive_table with
+ | None -> new_neg, new_pos
+ | Some passive_table ->
+ List.map (demodulate Negative passive_table) new_neg,
+ List.map (demodulate Positive passive_table) new_pos *)
+ in
+
+ let t2 = Unix.gettimeofday () in
+ fs_time_info.demodulate <- fs_time_info.demodulate +. (t2 -. t1);
+
+ let new_pos_set =
+ List.fold_left
+ (fun s e ->
+ if not (Inference.is_identity env e) then
+ if EqualitySet.mem e s then s
+ else EqualitySet.add e s
+ else s)
+ EqualitySet.empty new_pos
+ in
+ let new_pos = EqualitySet.elements new_pos_set in
+
+ let subs =
+ match passive_table with
+ | None ->
+ (fun e -> not (fst (Indexing.subsumption env active_table e)))
+ | Some passive_table ->
+ (fun e -> not ((fst (Indexing.subsumption env active_table e)) ||
+ (fst (Indexing.subsumption env passive_table e))))
+ in
+(* let t1 = Unix.gettimeofday () in *)
+(* let t2 = Unix.gettimeofday () in *)
+(* fs_time_info.subsumption <- fs_time_info.subsumption +. (t2 -. t1); *)
+ let is_duplicate =
+ match passive_table with
+ | None ->
+ (fun e -> not (Indexing.in_index active_table e))
+ | Some passive_table ->
+ (fun e ->
+ not ((Indexing.in_index active_table e) ||
+ (Indexing.in_index passive_table e)))
+ in
+ new_neg, List.filter subs (List.filter is_duplicate new_pos)
+;;
+
+
+(** simplifies active usign new *)
+let backward_simplify_active env new_pos new_table min_weight active =
+ let active_list, active_table = active in
+ let active_list, newa =
+ List.fold_right
+ (fun (s, equality) (res, newn) ->
+ let ew, _, _, _, _ = equality in
+ if ew < min_weight then
+ (s, equality)::res, newn
+ else
+ match forward_simplify env (s, equality) (new_pos, new_table) with
+ | None -> res, newn
+ | Some (s, e) ->
+ if equality = e then
+ (s, e)::res, newn
+ else
+ res, (s, e)::newn)
+ active_list ([], [])
+ in
+ let find eq1 where =
+ List.exists (fun (s, e) -> meta_convertibility_eq eq1 e) where
+ in
+ let active, newa =
+ List.fold_right
+ (fun (s, eq) (res, tbl) ->
+ if List.mem (s, eq) res then
+ res, tbl
+ else if (is_identity env eq) || (find eq res) then (
+ res, tbl
+ )
+ else
+ (s, eq)::res, if s = Negative then tbl else Indexing.index tbl eq)
+ active_list ([], Indexing.empty),
+ List.fold_right
+ (fun (s, eq) (n, p) ->
+ if (s <> Negative) && (is_identity env eq) then (
+ (n, p)
+ ) else
+ if s = Negative then eq::n, p
+ else n, eq::p)
+ newa ([], [])
+ in
+ match newa with
+ | [], [] -> active, None
+ | _ -> active, Some newa
+;;
+
+
+(** simplifies passive using new *)
+let backward_simplify_passive env new_pos new_table min_weight passive =
+ let (nl, ns), (pl, ps), passive_table = passive in
+ let f sign equality (resl, ress, newn) =
+ let ew, _, _, _, _ = equality in
+ if ew < min_weight then
+ equality::resl, ress, newn
+ else
+ match forward_simplify env (sign, equality) (new_pos, new_table) with
+ | None -> resl, EqualitySet.remove equality ress, newn
+ | Some (s, e) ->
+ if equality = e then
+ equality::resl, ress, newn
+ else
+ let ress = EqualitySet.remove equality ress in
+ resl, ress, e::newn
+ in
+ let nl, ns, newn = List.fold_right (f Negative) nl ([], ns, [])
+ and pl, ps, newp = List.fold_right (f Positive) pl ([], ps, []) in
+ let passive_table =
+ List.fold_left
+ (fun tbl e -> Indexing.index tbl e) Indexing.empty pl
+ in
+ match newn, newp with
+ | [], [] -> ((nl, ns), (pl, ps), passive_table), None
+ | _, _ -> ((nl, ns), (pl, ps), passive_table), Some (newn, newp)
+;;
+
+
+let backward_simplify env new' ?passive active =
+ let new_pos, new_table, min_weight =
+ List.fold_left
+ (fun (l, t, w) e ->
+ let ew, _, _, _, _ = e in
+ (Positive, e)::l, Indexing.index t e, min ew w)
+ ([], Indexing.empty, 1000000) (snd new')
+ in
+ let active, newa =
+ backward_simplify_active env new_pos new_table min_weight active in
+ match passive with
+ | None ->
+ active, (make_passive [] []), newa, None
+ | Some passive ->
+ let passive, newp =
+ backward_simplify_passive env new_pos new_table min_weight passive in
+ active, passive, newa, newp
+;;
+
+
+(* returns an estimation of how many equalities in passive can be activated
+ within the current time limit *)
+let get_selection_estimate () =
+ elapsed_time := (Unix.gettimeofday ()) -. !start_time;
+ (* !processed_clauses * (int_of_float (!time_limit /. !elapsed_time)) *)
+ int_of_float (
+ ceil ((float_of_int !processed_clauses) *.
+ ((!time_limit (* *. 2. *)) /. !elapsed_time -. 1.)))
+;;
+
+
+(** initializes the set of goals *)
+let make_goals goal =
+ let active = []
+ and passive = [0, [goal]] in
+ active, passive
+;;
+
+
+(** initializes the set of theorems *)
+let make_theorems theorems =
+ theorems, []
+;;
+
+
+let activate_goal (active, passive) =
+ match passive with
+ | goal_conj::tl -> true, (goal_conj::active, tl)
+ | [] -> false, (active, passive)
+;;
+
+
+let activate_theorem (active, passive) =
+ match passive with
+ | theorem::tl -> true, (theorem::active, tl)
+ | [] -> false, (active, passive)
+;;
+
+
+(** simplifies a goal with equalities in active and passive *)
+let simplify_goal env goal ?passive (active_list, active_table) =
+ let pl, passive_table =
+ match passive with
+ | None -> [], None
+ | Some ((pn, _), (pp, _), pt) ->
+ let pn = List.map (fun e -> (Negative, e)) pn
+ and pp = List.map (fun e -> (Positive, e)) pp in
+ pn @ pp, Some pt
+ in
+
+ let demodulate table goal =
+ let newmeta, newgoal =
+ Indexing.demodulation_goal !maxmeta env table goal in
+ maxmeta := newmeta;
+ goal != newgoal, newgoal
+ in
+ let changed, goal =
+ match passive_table with
+ | None -> demodulate active_table goal
+ | Some passive_table ->
+ let changed, goal = demodulate active_table goal in
+ let changed', goal = demodulate passive_table goal in
+ (changed || changed'), goal
+ in
+ changed, goal
+;;
+
+
+let simplify_goals env goals ?passive active =
+ let a_goals, p_goals = goals in
+ let p_goals =
+ List.map
+ (fun (d, gl) ->
+ let gl =
+ List.map (fun g -> snd (simplify_goal env g ?passive active)) gl in
+ d, gl)
+ p_goals
+ in
+ let goals =
+ List.fold_left
+ (fun (a, p) (d, gl) ->
+ let changed = ref false in
+ let gl =
+ List.map
+ (fun g ->
+ let c, g = simplify_goal env g ?passive active in
+ changed := !changed || c; g) gl in
+ if !changed then (a, (d, gl)::p) else ((d, gl)::a, p))
+ ([], p_goals) a_goals
+ in
+ goals
+;;
+
+
+let simplify_theorems env theorems ?passive (active_list, active_table) =
+ let pl, passive_table =
+ match passive with
+ | None -> [], None
+ | Some ((pn, _), (pp, _), pt) ->
+ let pn = List.map (fun e -> (Negative, e)) pn
+ and pp = List.map (fun e -> (Positive, e)) pp in
+ pn @ pp, Some pt
+ in
+ let a_theorems, p_theorems = theorems in
+ let demodulate table theorem =
+ let newmeta, newthm =
+ Indexing.demodulation_theorem !maxmeta env table theorem in
+ maxmeta := newmeta;
+ theorem != newthm, newthm
+ in
+ let foldfun table (a, p) theorem =
+ let changed, theorem = demodulate table theorem in
+ if changed then (a, theorem::p) else (theorem::a, p)
+ in
+ let mapfun table theorem = snd (demodulate table theorem) in
+ match passive_table with
+ | None ->
+ let p_theorems = List.map (mapfun active_table) p_theorems in
+ List.fold_left (foldfun active_table) ([], p_theorems) a_theorems
+ | Some passive_table ->
+ let p_theorems = List.map (mapfun active_table) p_theorems in
+ let p_theorems, a_theorems =
+ List.fold_left (foldfun active_table) ([], p_theorems) a_theorems in
+ let p_theorems = List.map (mapfun passive_table) p_theorems in
+ List.fold_left (foldfun passive_table) ([], p_theorems) a_theorems
+;;
+
+
+let rec simpl env e others others_simpl =
+ let active = others @ others_simpl in
+ let tbl =
+ List.fold_left
+ (fun t (_, e) -> Indexing.index t e)
+ Indexing.empty active
+ in
+ let res = forward_simplify env e (active, tbl) in
+ match others with
+ | hd::tl -> (
+ match res with
+ | None -> simpl env hd tl others_simpl
+ | Some e -> simpl env hd tl (e::others_simpl)
+ )
+ | [] -> (
+ match res with
+ | None -> others_simpl
+ | Some e -> e::others_simpl
+ )
+;;
+
+let simplify_equalities env equalities =
+ debug_print
+ (lazy
+ (Printf.sprintf "equalities:\n%s\n"
+ (String.concat "\n"
+ (List.map string_of_equality equalities))));
+ debug_print (lazy "SIMPLYFYING EQUALITIES...");
+ match equalities with
+ | [] -> []
+ | hd::tl ->
+ let others = List.map (fun e -> (Positive, e)) tl in
+ let res =
+ List.rev (List.map snd (simpl env (Positive, hd) others []))
+ in
+ debug_print
+ (lazy
+ (Printf.sprintf "equalities AFTER:\n%s\n"
+ (String.concat "\n"
+ (List.map string_of_equality res))));
+ res
+;;
+
+(* applies equality to goal to see if the goal can be closed *)
+let apply_equality_to_goal env equality goal =
+ let module C = Cic in
+ let module HL = HelmLibraryObjects in
+ let module I = Inference in
+ let metasenv, context, ugraph = env in
+ let _, proof, (ty, left, right, _), metas, args = equality in
+ let eqterm =
+ C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); ty; left; right] in
+ let gproof, gmetas, gterm = goal in
+(* debug_print *)
+(* (lazy *)
+(* (Printf.sprintf "APPLY EQUALITY TO GOAL: %s, %s" *)
+(* (string_of_equality equality) (CicPp.ppterm gterm))); *)
+ try
+ let subst, metasenv', _ =
+ let menv = metasenv @ metas @ gmetas in
+ Inference.unification menv context eqterm gterm ugraph
+ in
+ let newproof =
+ match proof with
+ | I.BasicProof t -> I.BasicProof (CicMetaSubst.apply_subst subst t)
+ | I.ProofBlock (s, uri, nt, t, pe, p) ->
+ I.ProofBlock (subst @ s, uri, nt, t, pe, p)
+ | _ -> assert false
+ in
+ let newgproof =
+ let rec repl = function
+ | I.ProofGoalBlock (_, gp) -> I.ProofGoalBlock (newproof, gp)
+ | I.NoProof -> newproof
+ | I.BasicProof p -> newproof
+ | I.SubProof (t, i, p) -> I.SubProof (t, i, repl p)
+ | _ -> assert false
+ in
+ repl gproof
+ in
+ true, subst, newgproof
+ with CicUnification.UnificationFailure _ ->
+ false, [], I.NoProof
+;;
+
+
+
+let new_meta metasenv =
+ let m = CicMkImplicit.new_meta metasenv [] in
+ incr maxmeta;
+ while !maxmeta <= m do incr maxmeta done;
+ !maxmeta
+;;
+
+
+(* applies a theorem or an equality to goal, returning a list of subgoals or
+ an indication of failure *)
+let apply_to_goal env theorems ?passive active goal =
+ let metasenv, context, ugraph = env in
+ let proof, metas, term = goal in
+ (* debug_print *)
+ (* (lazy *)
+ (* (Printf.sprintf "apply_to_goal with goal: %s" *)
+ (* (\* (string_of_proof proof) *\)(CicPp.ppterm term))); *)
+ let status =
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context in
+ let proof', newmeta =
+ let rec get_meta = function
+ | SubProof (t, i, p) ->
+ let t', i' = get_meta p in
+ if i' = -1 then t, i else t', i'
+ | ProofGoalBlock (_, p) -> get_meta p
+ | _ -> Cic.Implicit None, -1
+ in
+ let p, m = get_meta proof in
+ if m = -1 then
+ let n = new_meta (metasenv @ metas) in
+ Cic.Meta (n, irl), n
+ else
+ p, m
+ in
+ let metasenv = (newmeta, context, term)::metasenv @ metas in
+ let bit = new_meta metasenv, context, term in
+ let metasenv' = bit::metasenv in
+ ((None, metasenv', Cic.Meta (newmeta, irl), term), newmeta)
+ in
+ let rec aux = function
+ | [] -> `No
+ | (theorem, thmty, _)::tl ->
+ try
+ let subst, (newproof, newgoals) =
+ PrimitiveTactics.apply_tac_verbose_with_subst ~term:theorem status
+ in
+ if newgoals = [] then
+ let _, _, p, _ = newproof in
+ let newp =
+ let rec repl = function
+ | Inference.ProofGoalBlock (_, gp) ->
+ Inference.ProofGoalBlock (Inference.BasicProof p, gp)
+ | Inference.NoProof -> Inference.BasicProof p
+ | Inference.BasicProof _ -> Inference.BasicProof p
+ | Inference.SubProof (t, i, p2) ->
+ Inference.SubProof (t, i, repl p2)
+ | _ -> assert false
+ in
+ repl proof
+ in
+ let _, m = status in
+ let subst = List.filter (fun (i, _) -> i = m) subst in
+ `Ok (subst, [newp, metas, term])
+ else
+ let _, menv, p, _ = newproof in
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context
+ in
+ let goals =
+ List.map
+ (fun i ->
+ let _, _, ty = CicUtil.lookup_meta i menv in
+ let p' =
+ let rec gp = function
+ | SubProof (t, i, p) ->
+ SubProof (t, i, gp p)
+ | ProofGoalBlock (sp1, sp2) ->
+ ProofGoalBlock (sp1, gp sp2)
+ | BasicProof _
+ | NoProof ->
+ SubProof (p, i, BasicProof (Cic.Meta (i, irl)))
+ | ProofSymBlock (s, sp) ->
+ ProofSymBlock (s, gp sp)
+ | ProofBlock (s, u, nt, t, pe, sp) ->
+ ProofBlock (s, u, nt, t, pe, gp sp)
+ in gp proof
+ in
+ (p', menv, ty))
+ newgoals
+ in
+ let goals =
+ let weight t =
+ let w, m = weight_of_term t in
+ w + 2 * (List.length m)
+ in
+ List.sort
+ (fun (_, _, t1) (_, _, t2) ->
+ Pervasives.compare (weight t1) (weight t2))
+ goals
+ in
+ let best = aux tl in
+ match best with
+ | `Ok (_, _) -> best
+ | `No -> `GoOn ([subst, goals])
+ | `GoOn sl -> `GoOn ((subst, goals)::sl)
+ with ProofEngineTypes.Fail msg ->
+ aux tl
+ in
+ let r, s, l =
+ if Inference.term_is_equality term then
+ let rec appleq_a = function
+ | [] -> false, [], []
+ | (Positive, equality)::tl ->
+ let ok, s, newproof = apply_equality_to_goal env equality goal in
+ if ok then true, s, [newproof, metas, term] else appleq_a tl
+ | _::tl -> appleq_a tl
+ in
+ let rec appleq_p = function
+ | [] -> false, [], []
+ | equality::tl ->
+ let ok, s, newproof = apply_equality_to_goal env equality goal in
+ if ok then true, s, [newproof, metas, term] else appleq_p tl
+ in
+ let al, _ = active in
+ match passive with
+ | None -> appleq_a al
+ | Some (_, (pl, _), _) ->
+ let r, s, l = appleq_a al in if r then r, s, l else appleq_p pl
+ else
+ false, [], []
+ in
+ if r = true then `Ok (s, l) else aux theorems
+;;
+
+
+(* sorts a conjunction of goals in order to detect earlier if it is
+ unsatisfiable. Non-predicate goals are placed at the end of the list *)
+let sort_goal_conj (metasenv, context, ugraph) (depth, gl) =
+ let gl =
+ List.stable_sort
+ (fun (_, e1, g1) (_, e2, g2) ->
+ let ty1, _ =
+ CicTypeChecker.type_of_aux' (e1 @ metasenv) context g1 ugraph
+ and ty2, _ =
+ CicTypeChecker.type_of_aux' (e2 @ metasenv) context g2 ugraph
+ in
+ let prop1 =
+ let b, _ =
+ CicReduction.are_convertible context (Cic.Sort Cic.Prop) ty1 ugraph
+ in
+ if b then 0 else 1
+ and prop2 =
+ let b, _ =
+ CicReduction.are_convertible context (Cic.Sort Cic.Prop) ty2 ugraph
+ in
+ if b then 0 else 1
+ in
+ if prop1 = 0 && prop2 = 0 then
+ let e1 = if Inference.term_is_equality g1 then 0 else 1
+ and e2 = if Inference.term_is_equality g2 then 0 else 1 in
+ e1 - e2
+ else
+ prop1 - prop2)
+ gl
+ in
+ (depth, gl)
+;;
+
+
+let is_meta_closed goals =
+ List.for_all (fun (_, _, g) -> CicUtil.is_meta_closed g) goals
+;;
+
+
+(* applies a series of theorems/equalities to a conjunction of goals *)
+let rec apply_to_goal_conj env theorems ?passive active (depth, goals) =
+ let aux (goal, r) tl =
+ let propagate_subst subst (proof, metas, term) =
+ let rec repl = function
+ | NoProof -> NoProof
+ | BasicProof t ->
+ BasicProof (CicMetaSubst.apply_subst subst t)
+ | ProofGoalBlock (p, pb) ->
+ let pb' = repl pb in
+ ProofGoalBlock (p, pb')
+ | SubProof (t, i, p) ->
+ let t' = CicMetaSubst.apply_subst subst t in
+ let p = repl p in
+ SubProof (t', i, p)
+ | ProofSymBlock (ens, p) -> ProofSymBlock (ens, repl p)
+ | ProofBlock (s, u, nty, t, pe, p) ->
+ ProofBlock (subst @ s, u, nty, t, pe, p)
+ in (repl proof, metas, term)
+ in
+ (* let r = apply_to_goal env theorems ?passive active goal in *) (
+ match r with
+ | `No -> `No (depth, goals)
+ | `GoOn sl ->
+ let l =
+ List.map
+ (fun (s, gl) ->
+ let tl = List.map (propagate_subst s) tl in
+ sort_goal_conj env (depth+1, gl @ tl)) sl
+ in
+ `GoOn l
+ | `Ok (subst, gl) ->
+ if tl = [] then
+ `Ok (depth, gl)
+ else
+ let p, _, _ = List.hd gl in
+ let subproof =
+ let rec repl = function
+ | SubProof (_, _, p) -> repl p
+ | ProofGoalBlock (p1, p2) ->
+ ProofGoalBlock (repl p1, repl p2)
+ | p -> p
+ in
+ build_proof_term (repl p)
+ in
+ let i =
+ let rec get_meta = function
+ | SubProof (_, i, p) ->
+ let i' = get_meta p in
+ if i' = -1 then i else i'
+(* max i (get_meta p) *)
+ | ProofGoalBlock (_, p) -> get_meta p
+ | _ -> -1
+ in
+ get_meta p
+ in
+ let subst =
+ let _, (context, _, _) = List.hd subst in
+ [i, (context, subproof, Cic.Implicit None)]
+ in
+ let tl = List.map (propagate_subst subst) tl in
+ let conj = sort_goal_conj env (depth(* +1 *), tl) in
+ `GoOn ([conj])
+ )
+ in
+ if depth > !maxdepth || (List.length goals) > !maxwidth then
+ `No (depth, goals)
+ else
+ let rec search_best res = function
+ | [] -> res
+ | goal::tl ->
+ let r = apply_to_goal env theorems ?passive active goal in
+ match r with
+ | `Ok _ -> (goal, r)
+ | `No -> search_best res tl
+ | `GoOn l ->
+ let newres =
+ match res with
+ | _, `Ok _ -> assert false
+ | _, `No -> goal, r
+ | _, `GoOn l2 ->
+ if (List.length l) < (List.length l2) then goal, r else res
+ in
+ search_best newres tl
+ in
+ let hd = List.hd goals in
+ let res = hd, (apply_to_goal env theorems ?passive active hd) in
+ let best =
+ match res with
+ | _, `Ok _ -> res
+ | _, _ -> search_best res (List.tl goals)
+ in
+ let res = aux best (List.filter (fun g -> g != (fst best)) goals) in
+ match res with
+ | `GoOn ([conj]) when is_meta_closed (snd conj) &&
+ (List.length (snd conj)) < (List.length goals)->
+ apply_to_goal_conj env theorems ?passive active conj
+ | _ -> res
+;;
+
+
+(*
+module OrderedGoals = struct
+ type t = int * (Inference.proof * Cic.metasenv * Cic.term) list
+
+ let compare g1 g2 =
+ let d1, l1 = g1
+ and d2, l2 = g2 in
+ let r = d2 - d1 in
+ if r <> 0 then r
+ else let r = (List.length l1) - (List.length l2) in
+ if r <> 0 then r
+ else
+ let res = ref 0 in
+ let _ =
+ List.exists2
+ (fun (_, _, t1) (_, _, t2) ->
+ let r = Pervasives.compare t1 t2 in
+ if r <> 0 then (
+ res := r;
+ true
+ ) else
+ false) l1 l2
+ in !res
+end
+
+module GoalsSet = Set.Make(OrderedGoals);;
+
+
+exception SearchSpaceOver;;
+*)
+
+
+(*
+let apply_to_goals env is_passive_empty theorems active goals =
+ debug_print (lazy "\n\n\tapply_to_goals\n\n");
+ let add_to set goals =
+ List.fold_left (fun s g -> GoalsSet.add g s) set goals
+ in
+ let rec aux set = function
+ | [] ->
+ debug_print (lazy "HERE!!!");
+ if is_passive_empty then raise SearchSpaceOver else false, set
+ | goals::tl ->
+ let res = apply_to_goal_conj env theorems active goals in
+ match res with
+ | `Ok newgoals ->
+ let _ =
+ let d, p, t =
+ match newgoals with
+ | (d, (p, _, t)::_) -> d, p, t
+ | _ -> assert false
+ in
+ debug_print
+ (lazy
+ (Printf.sprintf "\nOK!!!!\ndepth: %d\nProof: %s\ngoal: %s\n"
+ d (string_of_proof p) (CicPp.ppterm t)))
+ in
+ true, GoalsSet.singleton newgoals
+ | `GoOn newgoals ->
+ let set' = add_to set (goals::tl) in
+ let set' = add_to set' newgoals in
+ false, set'
+ | `No newgoals ->
+ aux set tl
+ in
+ let n = List.length goals in
+ let res, goals = aux (add_to GoalsSet.empty goals) goals in
+ let goals = GoalsSet.elements goals in
+ debug_print (lazy "\n\tapply_to_goals end\n");
+ let m = List.length goals in
+ if m = n && is_passive_empty then
+ raise SearchSpaceOver
+ else
+ res, goals
+;;
+*)
+
+
+(* sorts the list of passive goals to minimize the search for a proof (doesn't
+ work that well yet...) *)
+let sort_passive_goals goals =
+ List.stable_sort
+ (fun (d1, l1) (d2, l2) ->
+ let r1 = d2 - d1
+ and r2 = (List.length l1) - (List.length l2) in
+ let foldfun ht (_, _, t) =
+ let _ = List.map (fun i -> Hashtbl.replace ht i 1) (metas_of_term t)
+ in ht
+ in
+ let m1 = Hashtbl.length (List.fold_left foldfun (Hashtbl.create 3) l1)
+ and m2 = Hashtbl.length (List.fold_left foldfun (Hashtbl.create 3) l2)
+ in let r3 = m1 - m2 in
+ if r3 <> 0 then r3
+ else if r2 <> 0 then r2
+ else r1)
+ (* let _, _, g1 = List.hd l1 *)
+(* and _, _, g2 = List.hd l2 in *)
+(* let e1 = if Inference.term_is_equality g1 then 0 else 1 *)
+(* and e2 = if Inference.term_is_equality g2 then 0 else 1 *)
+(* in let r4 = e1 - e2 in *)
+(* if r4 <> 0 then r3 else r1) *)
+ goals
+;;
+
+
+let print_goals goals =
+ (String.concat "\n"
+ (List.map
+ (fun (d, gl) ->
+ let gl' =
+ List.map
+ (fun (p, _, t) ->
+ (* (string_of_proof p) ^ ", " ^ *) (CicPp.ppterm t)) gl
+ in
+ Printf.sprintf "%d: %s" d (String.concat "; " gl')) goals))
+;;
+
+
+(* tries to prove the first conjunction in goals with applications of
+ theorems/equalities, returning new sub-goals or an indication of success *)
+let apply_goal_to_theorems dbd env theorems ?passive active goals =
+ let theorems, _ = theorems in
+ let a_goals, p_goals = goals in
+ let goal = List.hd a_goals in
+ let not_in_active gl =
+ not
+ (List.exists
+ (fun (_, gl') ->
+ if (List.length gl) = (List.length gl') then
+ List.for_all2 (fun (_, _, g1) (_, _, g2) -> g1 = g2) gl gl'
+ else
+ false)
+ a_goals)
+ in
+ let aux theorems =
+ let res = apply_to_goal_conj env theorems ?passive active goal in
+ match res with
+ | `Ok newgoals ->
+ true, ([newgoals], [])
+ | `No _ ->
+ false, (a_goals, p_goals)
+ | `GoOn newgoals ->
+ let newgoals =
+ List.filter
+ (fun (d, gl) ->
+ (d <= !maxdepth) && (List.length gl) <= !maxwidth &&
+ not_in_active gl)
+ newgoals in
+ let p_goals = newgoals @ p_goals in
+ let p_goals = sort_passive_goals p_goals in
+ false, (a_goals, p_goals)
+ in
+ aux theorems
+;;
+
+
+let apply_theorem_to_goals env theorems active goals =
+ let a_goals, p_goals = goals in
+ let theorem = List.hd (fst theorems) in
+ let theorems = [theorem] in
+ let rec aux p = function
+ | [] -> false, ([], p)
+ | goal::tl ->
+ let res = apply_to_goal_conj env theorems active goal in
+ match res with
+ | `Ok newgoals -> true, ([newgoals], [])
+ | `No _ -> aux p tl
+ | `GoOn newgoals -> aux (newgoals @ p) tl
+ in
+ let ok, (a, p) = aux p_goals a_goals in
+ if ok then
+ ok, (a, p)
+ else
+ let p_goals =
+ List.stable_sort
+ (fun (d1, l1) (d2, l2) ->
+ let r = d2 - d1 in
+ if r <> 0 then r
+ else let r = (List.length l1) - (List.length l2) in
+ if r <> 0 then r
+ else
+ let res = ref 0 in
+ let _ =
+ List.exists2
+ (fun (_, _, t1) (_, _, t2) ->
+ let r = Pervasives.compare t1 t2 in
+ if r <> 0 then (res := r; true) else false) l1 l2
+ in !res)
+ p
+ in
+ ok, (a_goals, p_goals)
+;;
+
+
+(* given-clause algorithm with lazy reduction strategy *)
+let rec given_clause dbd env goals theorems passive active =
+ let goals = simplify_goals env goals active in
+ let ok, goals = activate_goal goals in
+ (* let theorems = simplify_theorems env theorems active in *)
+ if ok then
+ let ok, goals = apply_goal_to_theorems dbd env theorems active goals in
+ if ok then
+ let proof =
+ match (fst goals) with
+ | (_, [proof, _, _])::_ -> Some proof
+ | _ -> assert false
+ in
+ ParamodulationSuccess (proof, env)
+ else
+ given_clause_aux dbd env goals theorems passive active
+ else
+(* let ok', theorems = activate_theorem theorems in *)
+ let ok', theorems = false, theorems in
+ if ok' then
+ let ok, goals = apply_theorem_to_goals env theorems active goals in
+ if ok then
+ let proof =
+ match (fst goals) with
+ | (_, [proof, _, _])::_ -> Some proof
+ | _ -> assert false
+ in
+ ParamodulationSuccess (proof, env)
+ else
+ given_clause_aux dbd env goals theorems passive active
+ else
+ if (passive_is_empty passive) then ParamodulationFailure
+ else given_clause_aux dbd env goals theorems passive active
+
+and given_clause_aux dbd env goals theorems passive active =
+ let time1 = Unix.gettimeofday () in
+
+ let selection_estimate = get_selection_estimate () in
+ let kept = size_of_passive passive in
+ let passive =
+ if !time_limit = 0. || !processed_clauses = 0 then
+ passive
+ else if !elapsed_time > !time_limit then (
+ debug_print (lazy (Printf.sprintf "Time limit (%.2f) reached: %.2f\n"
+ !time_limit !elapsed_time));
+ make_passive [] []
+ ) else if kept > selection_estimate then (
+ debug_print
+ (lazy (Printf.sprintf ("Too many passive equalities: pruning..." ^^
+ "(kept: %d, selection_estimate: %d)\n")
+ kept selection_estimate));
+ prune_passive selection_estimate active passive
+ ) else
+ passive
+ in
+
+ let time2 = Unix.gettimeofday () in
+ passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1);
+
+ kept_clauses := (size_of_passive passive) + (size_of_active active);
+ match passive_is_empty passive with
+ | true -> (* ParamodulationFailure *)
+ given_clause dbd env goals theorems passive active
+ | false ->
+ let (sign, current), passive = select env (fst goals) passive active in
+ let time1 = Unix.gettimeofday () in
+ let res = forward_simplify env (sign, current) ~passive active in
+ let time2 = Unix.gettimeofday () in
+ forward_simpl_time := !forward_simpl_time +. (time2 -. time1);
+ match res with
+ | None ->
+ given_clause dbd env goals theorems passive active
+ | Some (sign, current) ->
+ if (sign = Negative) && (is_identity env current) then (
+ debug_print
+ (lazy (Printf.sprintf "OK!!! %s %s" (string_of_sign sign)
+ (string_of_equality ~env current)));
+ let _, proof, _, _, _ = current in
+ ParamodulationSuccess (Some proof, env)
+ ) else (
+ debug_print
+ (lazy "\n================================================");
+ debug_print (lazy (Printf.sprintf "selected: %s %s"
+ (string_of_sign sign)
+ (string_of_equality ~env current)));
+
+ let t1 = Unix.gettimeofday () in
+ let new' = infer env sign current active in
+ let t2 = Unix.gettimeofday () in
+ infer_time := !infer_time +. (t2 -. t1);
+
+ let res, goal' = contains_empty env new' in
+ if res then
+ let proof =
+ match goal' with
+ | Some goal -> let _, proof, _, _, _ = goal in Some proof
+ | None -> None
+ in
+ ParamodulationSuccess (proof, env)
+ else
+ let t1 = Unix.gettimeofday () in
+ let new' = forward_simplify_new env new' active in
+ let t2 = Unix.gettimeofday () in
+ let _ =
+ forward_simpl_new_time :=
+ !forward_simpl_new_time +. (t2 -. t1)
+ in
+ let active =
+ match sign with
+ | Negative -> active
+ | Positive ->
+ let t1 = Unix.gettimeofday () in
+ let active, _, newa, _ =
+ backward_simplify env ([], [current]) active
+ in
+ let t2 = Unix.gettimeofday () in
+ backward_simpl_time :=
+ !backward_simpl_time +. (t2 -. t1);
+ match newa with
+ | None -> active
+ | Some (n, p) ->
+ let al, tbl = active in
+ let nn = List.map (fun e -> Negative, e) n in
+ let pp, tbl =
+ List.fold_right
+ (fun e (l, t) ->
+ (Positive, e)::l,
+ Indexing.index tbl e)
+ p ([], tbl)
+ in
+ nn @ al @ pp, tbl
+ in
+ match contains_empty env new' with
+ | false, _ ->
+ let active =
+ let al, tbl = active in
+ match sign with
+ | Negative -> (sign, current)::al, tbl
+ | Positive ->
+ al @ [(sign, current)], Indexing.index tbl current
+ in
+ let passive = add_to_passive passive new' in
+ given_clause dbd env goals theorems passive active
+ | true, goal ->
+ let proof =
+ match goal with
+ | Some goal ->
+ let _, proof, _, _, _ = goal in Some proof
+ | None -> None
+ in
+ ParamodulationSuccess (proof, env)
+ )
+;;
+
+
+(** given-clause algorithm with full reduction strategy *)
+let rec given_clause_fullred dbd env goals theorems passive active =
+ let goals = simplify_goals env goals ~passive active in
+ let ok, goals = activate_goal goals in
+(* let theorems = simplify_theorems env theorems ~passive active in *)
+ if ok then
+(* let _ = *)
+(* debug_print *)
+(* (lazy *)
+(* (Printf.sprintf "\ngoals = \nactive\n%s\npassive\n%s\n" *)
+(* (print_goals (fst goals)) (print_goals (snd goals)))); *)
+(* let current = List.hd (fst goals) in *)
+(* let p, _, t = List.hd (snd current) in *)
+(* debug_print *)
+(* (lazy *)
+(* (Printf.sprintf "goal activated:\n%s\n%s\n" *)
+(* (CicPp.ppterm t) (string_of_proof p))); *)
+(* in *)
+ let ok, goals =
+ apply_goal_to_theorems dbd env theorems ~passive active goals
+ in
+ if ok then
+ let proof =
+ match (fst goals) with
+ | (_, [proof, _, _])::_ -> Some proof
+ | _ -> assert false
+ in
+ ParamodulationSuccess (proof, env)
+ else
+ given_clause_fullred_aux dbd env goals theorems passive active
+ else
+(* let ok', theorems = activate_theorem theorems in *)
+(* if ok' then *)
+(* let ok, goals = apply_theorem_to_goals env theorems active goals in *)
+(* if ok then *)
+(* let proof = *)
+(* match (fst goals) with *)
+(* | (_, [proof, _, _])::_ -> Some proof *)
+(* | _ -> assert false *)
+(* in *)
+(* ParamodulationSuccess (proof, env) *)
+(* else *)
+(* given_clause_fullred_aux env goals theorems passive active *)
+(* else *)
+ if (passive_is_empty passive) then ParamodulationFailure
+ else given_clause_fullred_aux dbd env goals theorems passive active
+
+and given_clause_fullred_aux dbd env goals theorems passive active =
+ let time1 = Unix.gettimeofday () in
+
+ let selection_estimate = get_selection_estimate () in
+ let kept = size_of_passive passive in
+ let passive =
+ if !time_limit = 0. || !processed_clauses = 0 then
+ passive
+ else if !elapsed_time > !time_limit then (
+ debug_print (lazy (Printf.sprintf "Time limit (%.2f) reached: %.2f\n"
+ !time_limit !elapsed_time));
+ make_passive [] []
+ ) else if kept > selection_estimate then (
+ debug_print
+ (lazy (Printf.sprintf ("Too many passive equalities: pruning..." ^^
+ "(kept: %d, selection_estimate: %d)\n")
+ kept selection_estimate));
+ prune_passive selection_estimate active passive
+ ) else
+ passive
+ in
+
+ let time2 = Unix.gettimeofday () in
+ passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1);
+
+ kept_clauses := (size_of_passive passive) + (size_of_active active);
+ match passive_is_empty passive with
+ | true -> (* ParamodulationFailure *)
+ given_clause_fullred dbd env goals theorems passive active
+ | false ->
+ let (sign, current), passive = select env (fst goals) passive active in
+ let time1 = Unix.gettimeofday () in
+ let res = forward_simplify env (sign, current) ~passive active in
+ let time2 = Unix.gettimeofday () in
+ forward_simpl_time := !forward_simpl_time +. (time2 -. time1);
+ match res with
+ | None ->
+ given_clause_fullred dbd env goals theorems passive active
+ | Some (sign, current) ->
+ if (sign = Negative) && (is_identity env current) then (
+ debug_print
+ (lazy (Printf.sprintf "OK!!! %s %s" (string_of_sign sign)
+ (string_of_equality ~env current)));
+ let _, proof, _, _, _ = current in
+ ParamodulationSuccess (Some proof, env)
+ ) else (
+ debug_print
+ (lazy "\n================================================");
+ debug_print (lazy (Printf.sprintf "selected: %s %s"
+ (string_of_sign sign)
+ (string_of_equality ~env current)));
+
+ let t1 = Unix.gettimeofday () in
+ let new' = infer env sign current active in
+ let t2 = Unix.gettimeofday () in
+ infer_time := !infer_time +. (t2 -. t1);
+
+ let active =
+ if is_identity env current then active
+ else
+ let al, tbl = active in
+ match sign with
+ | Negative -> (sign, current)::al, tbl
+ | Positive ->
+ al @ [(sign, current)], Indexing.index tbl current
+ in
+ let rec simplify new' active passive =
+ let t1 = Unix.gettimeofday () in
+ let new' = forward_simplify_new env new' ~passive active in
+ let t2 = Unix.gettimeofday () in
+ forward_simpl_new_time :=
+ !forward_simpl_new_time +. (t2 -. t1);
+ let t1 = Unix.gettimeofday () in
+ let active, passive, newa, retained =
+ backward_simplify env new' ~passive active in
+ let t2 = Unix.gettimeofday () in
+ backward_simpl_time := !backward_simpl_time +. (t2 -. t1);
+ match newa, retained with
+ | None, None -> active, passive, new'
+ | Some (n, p), None
+ | None, Some (n, p) ->
+ let nn, np = new' in
+ simplify (nn @ n, np @ p) active passive
+ | Some (n, p), Some (rn, rp) ->
+ let nn, np = new' in
+ simplify (nn @ n @ rn, np @ p @ rp) active passive
+ in
+ let active, passive, new' = simplify new' active passive in
+
+ let k = size_of_passive passive in
+ if k < (kept - 1) then
+ processed_clauses := !processed_clauses + (kept - 1 - k);
+
+ let _ =
+ debug_print
+ (lazy
+ (Printf.sprintf "active:\n%s\n"
+ (String.concat "\n"
+ ((List.map
+ (fun (s, e) -> (string_of_sign s) ^ " " ^
+ (string_of_equality ~env e))
+ (fst active))))))
+ in
+ let _ =
+ match new' with
+ | neg, pos ->
+ debug_print
+ (lazy
+ (Printf.sprintf "new':\n%s\n"
+ (String.concat "\n"
+ ((List.map
+ (fun e -> "Negative " ^
+ (string_of_equality ~env e)) neg) @
+ (List.map
+ (fun e -> "Positive " ^
+ (string_of_equality ~env e)) pos)))))
+ in
+ match contains_empty env new' with
+ | false, _ ->
+ let passive = add_to_passive passive new' in
+ given_clause_fullred dbd env goals theorems passive active
+ | true, goal ->
+ let proof =
+ match goal with
+ | Some goal -> let _, proof, _, _, _ = goal in Some proof
+ | None -> None
+ in
+ ParamodulationSuccess (proof, env)
+ )
+;;
+
+
+let rec saturate_equations env goal accept_fun passive active =
+ elapsed_time := Unix.gettimeofday () -. !start_time;
+ if !elapsed_time > !time_limit then
+ (active, passive)
+ else
+ let (sign, current), passive = select env [1, [goal]] passive active in
+ let res = forward_simplify env (sign, current) ~passive active in
+ match res with
+ | None ->
+ saturate_equations env goal accept_fun passive active
+ | Some (sign, current) ->
+ assert (sign = Positive);
+ debug_print
+ (lazy "\n================================================");
+ debug_print (lazy (Printf.sprintf "selected: %s %s"
+ (string_of_sign sign)
+ (string_of_equality ~env current)));
+ let new' = infer env sign current active in
+ let active =
+ if is_identity env current then active
+ else
+ let al, tbl = active in
+ al @ [(sign, current)], Indexing.index tbl current
+ in
+ let rec simplify new' active passive =
+ let new' = forward_simplify_new env new' ~passive active in
+ let active, passive, newa, retained =
+ backward_simplify env new' ~passive active in
+ match newa, retained with
+ | None, None -> active, passive, new'
+ | Some (n, p), None
+ | None, Some (n, p) ->
+ let nn, np = new' in
+ simplify (nn @ n, np @ p) active passive
+ | Some (n, p), Some (rn, rp) ->
+ let nn, np = new' in
+ simplify (nn @ n @ rn, np @ p @ rp) active passive
+ in
+ let active, passive, new' = simplify new' active passive in
+ let _ =
+ debug_print
+ (lazy
+ (Printf.sprintf "active:\n%s\n"
+ (String.concat "\n"
+ ((List.map
+ (fun (s, e) -> (string_of_sign s) ^ " " ^
+ (string_of_equality ~env e))
+ (fst active))))))
+ in
+ let _ =
+ match new' with
+ | neg, pos ->
+ debug_print
+ (lazy
+ (Printf.sprintf "new':\n%s\n"
+ (String.concat "\n"
+ ((List.map
+ (fun e -> "Negative " ^
+ (string_of_equality ~env e)) neg) @
+ (List.map
+ (fun e -> "Positive " ^
+ (string_of_equality ~env e)) pos)))))
+ in
+ let new' = match new' with _, pos -> [], List.filter accept_fun pos in
+ let passive = add_to_passive passive new' in
+ saturate_equations env goal accept_fun passive active
+;;
+
+
+
+
+let main dbd full term metasenv ugraph =
+ let module C = Cic in
+ let module T = CicTypeChecker in
+ let module PET = ProofEngineTypes in
+ let module PP = CicPp in
+ let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in
+ let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in
+ let proof, goals = status in
+ let goal' = List.nth goals 0 in
+ let _, metasenv, meta_proof, _ = proof in
+ let _, context, goal = CicUtil.lookup_meta goal' metasenv in
+ let eq_indexes, equalities, maxm = find_equalities context proof in
+ let lib_eq_uris, library_equalities, maxm =
+
+ find_library_equalities dbd context (proof, goal') (maxm+2)
+ in
+ let library_equalities = List.map snd library_equalities in
+ maxmeta := maxm+2; (* TODO ugly!! *)
+ let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in
+ let new_meta_goal, metasenv, type_of_goal =
+ let _, context, ty = CicUtil.lookup_meta goal' metasenv in
+ debug_print
+ (lazy
+ (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n\n" (CicPp.ppterm ty)));
+ Cic.Meta (maxm+1, irl),
+ (maxm+1, context, ty)::metasenv,
+ ty
+ in
+ let env = (metasenv, context, ugraph) in
+ let t1 = Unix.gettimeofday () in
+ let theorems =
+ if full then
+ let theorems = find_library_theorems dbd env (proof, goal') lib_eq_uris in
+ let context_hyp = find_context_hypotheses env eq_indexes in
+ context_hyp @ theorems, []
+ else
+ let refl_equal =
+ let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in
+ UriManager.uri_of_string (us ^ "#xpointer(1/1/1)")
+ in
+ let t = CicUtil.term_of_uri refl_equal in
+ let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in
+ [(t, ty, [])], []
+ in
+ let t2 = Unix.gettimeofday () in
+ debug_print
+ (lazy
+ (Printf.sprintf "Time to retrieve theorems: %.9f\n" (t2 -. t1)));
+ let _ =
+ debug_print
+ (lazy
+ (Printf.sprintf
+ "Theorems:\n-------------------------------------\n%s\n"
+ (String.concat "\n"
+ (List.map
+ (fun (t, ty, _) ->
+ Printf.sprintf
+ "Term: %s, type: %s" (CicPp.ppterm t) (CicPp.ppterm ty))
+ (fst theorems)))))
+ in
+ (*try*)
+ let goal = Inference.BasicProof new_meta_goal, [], goal in
+ let equalities = simplify_equalities env (equalities@library_equalities) in
+ let active = make_active () in
+ let passive = make_passive [] equalities in
+ Printf.printf "\ncurrent goal: %s\n"
+ (let _, _, g = goal in CicPp.ppterm g);
+ Printf.printf "\ncontext:\n%s\n" (PP.ppcontext context);
+ Printf.printf "\nmetasenv:\n%s\n" (print_metasenv metasenv);
+ Printf.printf "\nequalities:\n%s\n"
+ (String.concat "\n"
+ (List.map
+ (string_of_equality ~env) equalities));
+(* (equalities @ library_equalities))); *)
+ print_endline "--------------------------------------------------";
+ let start = Unix.gettimeofday () in
+ print_endline "GO!";
+ start_time := Unix.gettimeofday ();
+ let res =
+ let goals = make_goals goal in
+ (if !use_fullred then given_clause_fullred else given_clause)
+ dbd env goals theorems passive active
+ in
+ let finish = Unix.gettimeofday () in
+ let _ =
+ match res with
+ | ParamodulationFailure ->
+ Printf.printf "NO proof found! :-(\n\n"
+ | ParamodulationSuccess (Some proof, env) ->
+ let proof = Inference.build_proof_term proof in
+ Printf.printf "OK, found a proof!\n";
+ (* REMEMBER: we have to instantiate meta_proof, we should use
+ apply the "apply" tactic to proof and status
+ *)
+ let names = names_of_context context in
+ print_endline (PP.pp proof names);
+ let newmetasenv =
+ List.fold_left
+ (fun m (_, _, _, menv, _) -> m @ menv) metasenv equalities
+ in
+ let _ =
+ (*try*)
+ let ty, ug =
+ CicTypeChecker.type_of_aux' newmetasenv context proof ugraph
+ in
+ print_endline (string_of_float (finish -. start));
+ Printf.printf
+ "\nGOAL was: %s\nPROOF has type: %s\nconvertible?: %s\n\n"
+ (CicPp.pp type_of_goal names) (CicPp.pp ty names)
+ (string_of_bool
+ (fst (CicReduction.are_convertible
+ context type_of_goal ty ug)));
+ (*with e ->
+ Printf.printf "\nEXCEPTION!!! %s\n" (Printexc.to_string e);
+ Printf.printf "MAXMETA USED: %d\n" !maxmeta;
+ print_endline (string_of_float (finish -. start));*)
+ in
+ ()
+
+ | ParamodulationSuccess (None, env) ->
+ Printf.printf "Success, but no proof?!?\n\n"
+ in
+ Printf.printf ("infer_time: %.9f\nforward_simpl_time: %.9f\n" ^^
+ "forward_simpl_new_time: %.9f\n" ^^
+ "backward_simpl_time: %.9f\n")
+ !infer_time !forward_simpl_time !forward_simpl_new_time
+ !backward_simpl_time;
+ Printf.printf "passive_maintainance_time: %.9f\n"
+ !passive_maintainance_time;
+ Printf.printf " successful unification/matching time: %.9f\n"
+ !Indexing.match_unif_time_ok;
+ Printf.printf " failed unification/matching time: %.9f\n"
+ !Indexing.match_unif_time_no;
+ Printf.printf " indexing retrieval time: %.9f\n"
+ !Indexing.indexing_retrieval_time;
+ Printf.printf " demodulate_term.build_newtarget_time: %.9f\n"
+ !Indexing.build_newtarget_time;
+ Printf.printf "derived %d clauses, kept %d clauses.\n"
+ !derived_clauses !kept_clauses;
+(*
+ with exc ->
+ print_endline ("EXCEPTION: " ^ (Printexc.to_string exc));
+ raise exc
+*)
+;;
+
+
+let default_depth = !maxdepth
+and default_width = !maxwidth;;
+
+let reset_refs () =
+ maxmeta := 0;
+ symbols_counter := 0;
+ weight_age_counter := !weight_age_ratio;
+ processed_clauses := 0;
+ start_time := 0.;
+ elapsed_time := 0.;
+ maximal_retained_equality := None;
+ infer_time := 0.;
+ forward_simpl_time := 0.;
+ forward_simpl_new_time := 0.;
+ backward_simpl_time := 0.;
+ passive_maintainance_time := 0.;
+ derived_clauses := 0;
+ kept_clauses := 0;
+;;
+
+let saturate
+ dbd ?(full=false) ?(depth=default_depth) ?(width=default_width) status =
+ let module C = Cic in
+ reset_refs ();
+ Indexing.init_index ();
+ maxdepth := depth;
+ maxwidth := width;
+ let proof, goal = status in
+ let goal' = goal in
+ let uri, metasenv, meta_proof, term_to_prove = proof in
+ let _, context, goal = CicUtil.lookup_meta goal' metasenv in
+ let eq_indexes, equalities, maxm = find_equalities context proof in
+ let new_meta_goal, metasenv, type_of_goal =
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context in
+ let _, context, ty = CicUtil.lookup_meta goal' metasenv in
+ debug_print
+ (lazy (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty)));
+ Cic.Meta (maxm+1, irl),
+ (maxm+1, context, ty)::metasenv,
+ ty
+ in
+ let ugraph = CicUniv.empty_ugraph in
+ let env = (metasenv, context, ugraph) in
+ let goal = Inference.BasicProof new_meta_goal, [], goal in
+ let res, time =
+ let t1 = Unix.gettimeofday () in
+ let lib_eq_uris, library_equalities, maxm =
+ find_library_equalities dbd context (proof, goal') (maxm+2)
+ in
+ let library_equalities = List.map snd library_equalities in
+ let t2 = Unix.gettimeofday () in
+ maxmeta := maxm+2;
+ let equalities = simplify_equalities env (equalities@library_equalities) in
+ debug_print
+ (lazy
+ (Printf.sprintf "Time to retrieve equalities: %.9f\n" (t2 -. t1)));
+ let t1 = Unix.gettimeofday () in
+ let theorems =
+ if full then
+ let thms = find_library_theorems dbd env (proof, goal') lib_eq_uris in
+ let context_hyp = find_context_hypotheses env eq_indexes in
+ context_hyp @ thms, []
+ else
+ let refl_equal =
+ let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in
+ UriManager.uri_of_string (us ^ "#xpointer(1/1/1)")
+ in
+ let t = CicUtil.term_of_uri refl_equal in
+ let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in
+ [(t, ty, [])], []
+ in
+ let t2 = Unix.gettimeofday () in
+ let _ =
+ debug_print
+ (lazy
+ (Printf.sprintf
+ "Theorems:\n-------------------------------------\n%s\n"
+ (String.concat "\n"
+ (List.map
+ (fun (t, ty, _) ->
+ Printf.sprintf
+ "Term: %s, type: %s"
+ (CicPp.ppterm t) (CicPp.ppterm ty))
+ (fst theorems)))));
+ debug_print
+ (lazy
+ (Printf.sprintf "Time to retrieve theorems: %.9f\n" (t2 -. t1)));
+ in
+ let active = make_active () in
+ let passive = make_passive [] equalities in
+ let start = Unix.gettimeofday () in
+ let res =
+ let goals = make_goals goal in
+ given_clause_fullred dbd env goals theorems passive active
+ in
+ let finish = Unix.gettimeofday () in
+ (res, finish -. start)
+ in
+ match res with
+ | ParamodulationSuccess (Some proof, env) ->
+ debug_print (lazy "OK, found a proof!");
+ let proof = Inference.build_proof_term proof in
+ let names = names_of_context context in
+ let newmetasenv =
+ let i1 =
+ match new_meta_goal with
+ | C.Meta (i, _) -> i | _ -> assert false
+ in
+ List.filter (fun (i, _, _) -> i <> i1 && i <> goal') metasenv
+ in
+ let newstatus =
+ try
+ let ty, ug =
+ CicTypeChecker.type_of_aux' newmetasenv context proof ugraph
+ in
+ debug_print (lazy (CicPp.pp proof [](* names *)));
+ debug_print
+ (lazy
+ (Printf.sprintf
+ "\nGOAL was: %s\nPROOF has type: %s\nconvertible?: %s\n"
+ (CicPp.pp type_of_goal names) (CicPp.pp ty names)
+ (string_of_bool
+ (fst (CicReduction.are_convertible
+ context type_of_goal ty ug)))));
+ let equality_for_replace i t1 =
+ match t1 with
+ | C.Meta (n, _) -> n = i
+ | _ -> false
+ in
+ let real_proof =
+ ProofEngineReduction.replace
+ ~equality:equality_for_replace
+ ~what:[goal'] ~with_what:[proof]
+ ~where:meta_proof
+ in
+ debug_print
+ (lazy
+ (Printf.sprintf "status:\n%s\n%s\n%s\n%s\n"
+ (match uri with Some uri -> UriManager.string_of_uri uri
+ | None -> "")
+ (print_metasenv newmetasenv)
+ (CicPp.pp real_proof [](* names *))
+ (CicPp.pp term_to_prove names)));
+ ((uri, newmetasenv, real_proof, term_to_prove), [])
+ with CicTypeChecker.TypeCheckerFailure _ ->
+ debug_print (lazy "THE PROOF DOESN'T TYPECHECK!!!");
+ debug_print (lazy (CicPp.pp proof names));
+ raise (ProofEngineTypes.Fail
+ (lazy "Found a proof, but it doesn't typecheck"))
+ in
+ let tall = fs_time_info.build_all in
+ let tdemodulate = fs_time_info.demodulate in
+ let tsubsumption = fs_time_info.subsumption in
+ debug_print (lazy (Printf.sprintf "\nTIME NEEDED: %.9f" time));
+ debug_print (lazy (Printf.sprintf "\ntall: %.9f" tall));
+ debug_print (lazy (Printf.sprintf "\ntdemod: %.9f" tdemodulate));
+ debug_print (lazy (Printf.sprintf "\ntsubsumption: %.9f" tsubsumption));
+ debug_print (lazy (Printf.sprintf "\ninfer_time: %.9f" !infer_time));
+ debug_print (lazy (Printf.sprintf "\nforward_simpl_times: %.9f" !forward_simpl_time));
+ debug_print (lazy (Printf.sprintf "\nforward_simpl_new_times: %.9f" !forward_simpl_new_time));
+ debug_print (lazy (Printf.sprintf "\nbackward_simpl_times: %.9f" !backward_simpl_time));
+ debug_print (lazy (Printf.sprintf "\npassive_maintainance_time: %.9f" !passive_maintainance_time));
+ newstatus
+ | _ ->
+ raise (ProofEngineTypes.Fail (lazy "NO proof found"))
+;;
+
+(* dummy function called within matita to trigger linkage *)
+let init () = ();;
+
+
+let retrieve_and_print dbd term metasenv ugraph =
+ let module C = Cic in
+ let module T = CicTypeChecker in
+ let module PET = ProofEngineTypes in
+ let module PP = CicPp in
+ let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in
+ let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in
+ let proof, goals = status in
+ let goal' = List.nth goals 0 in
+ let uri, metasenv, meta_proof, term_to_prove = proof in
+ let _, context, goal = CicUtil.lookup_meta goal' metasenv in
+ let eq_indexes, equalities, maxm = find_equalities context proof in
+ let new_meta_goal, metasenv, type_of_goal =
+ let irl =
+ CicMkImplicit.identity_relocation_list_for_metavariable context in
+ let _, context, ty = CicUtil.lookup_meta goal' metasenv in
+ debug_print
+ (lazy (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty)));
+ Cic.Meta (maxm+1, irl),
+ (maxm+1, context, ty)::metasenv,
+ ty
+ in
+ let ugraph = CicUniv.empty_ugraph in
+ let env = (metasenv, context, ugraph) in
+ let t1 = Unix.gettimeofday () in
+ let lib_eq_uris, library_equalities, maxm =
+ find_library_equalities dbd context (proof, goal') (maxm+2) in
+ let t2 = Unix.gettimeofday () in
+ maxmeta := maxm+2;
+ let equalities = (* equalities @ *) library_equalities in
+ debug_print
+ (lazy
+ (Printf.sprintf "\n\nequalities:\n%s\n"
+ (String.concat "\n"
+ (List.map
+ (fun (u, e) ->
+(* Printf.sprintf "%s: %s" *)
+ (UriManager.string_of_uri u)
+(* (string_of_equality e) *)
+ )
+ equalities))));
+ debug_print (lazy "SIMPLYFYING EQUALITIES...");
+ let rec simpl e others others_simpl =
+ let (u, e) = e in
+ let active = List.map (fun (u, e) -> (Positive, e))
+ (others @ others_simpl) in
+ let tbl =
+ List.fold_left
+ (fun t (_, e) -> Indexing.index t e)
+ Indexing.empty active
+ in
+ let res = forward_simplify env (Positive, e) (active, tbl) in
+ match others with
+ | hd::tl -> (
+ match res with
+ | None -> simpl hd tl others_simpl
+ | Some e -> simpl hd tl ((u, (snd e))::others_simpl)
+ )
+ | [] -> (
+ match res with
+ | None -> others_simpl
+ | Some e -> (u, (snd e))::others_simpl
+ )
+ in
+ let _equalities =
+ match equalities with
+ | [] -> []
+ | hd::tl ->
+ let others = tl in (* List.map (fun e -> (Positive, e)) tl in *)
+ let res =
+ List.rev (simpl (*(Positive,*) hd others [])
+ in
+ debug_print
+ (lazy
+ (Printf.sprintf "\nequalities AFTER:\n%s\n"
+ (String.concat "\n"
+ (List.map
+ (fun (u, e) ->
+ Printf.sprintf "%s: %s"
+ (UriManager.string_of_uri u)
+ (string_of_equality e)
+ )
+ res))));
+ res in
+ debug_print
+ (lazy
+ (Printf.sprintf "Time to retrieve equalities: %.9f\n" (t2 -. t1)))
+;;
+
+
+let main_demod_equalities dbd term metasenv ugraph =
+ let module C = Cic in
+ let module T = CicTypeChecker in
+ let module PET = ProofEngineTypes in
+ let module PP = CicPp in
+ let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in
+ let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in
+ let proof, goals = status in
+ let goal' = List.nth goals 0 in
+ let _, metasenv, meta_proof, _ = proof in
+ let _, context, goal = CicUtil.lookup_meta goal' metasenv in
+ let eq_indexes, equalities, maxm = find_equalities context proof in
+ let lib_eq_uris, library_equalities, maxm =
+ find_library_equalities dbd context (proof, goal') (maxm+2)
+ in
+ let library_equalities = List.map snd library_equalities in
+ maxmeta := maxm+2; (* TODO ugly!! *)
+ let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in
+ let new_meta_goal, metasenv, type_of_goal =
+ let _, context, ty = CicUtil.lookup_meta goal' metasenv in
+ debug_print
+ (lazy
+ (Printf.sprintf "\n\nTRYING TO INFER EQUALITIES MATCHING: %s\n\n"
+ (CicPp.ppterm ty)));
+ Cic.Meta (maxm+1, irl),
+ (maxm+1, context, ty)::metasenv,
+ ty
+ in
+ let env = (metasenv, context, ugraph) in
+ (*try*)
+ let goal = Inference.BasicProof new_meta_goal, [], goal in
+ let equalities = simplify_equalities env (equalities@library_equalities) in
+ let active = make_active () in
+ let passive = make_passive [] equalities in
+ Printf.printf "\ncontext:\n%s\n" (PP.ppcontext context);
+ Printf.printf "\nmetasenv:\n%s\n" (print_metasenv metasenv);
+ Printf.printf "\nequalities:\n%s\n"
+ (String.concat "\n"
+ (List.map
+ (string_of_equality ~env) equalities));
+ print_endline "--------------------------------------------------";
+ print_endline "GO!";
+ start_time := Unix.gettimeofday ();
+ if !time_limit < 1. then time_limit := 60.;
+ let ra, rp =
+ saturate_equations env goal (fun e -> true) passive active
+ in
+
+ let initial =
+ List.fold_left (fun s e -> EqualitySet.add e s)
+ EqualitySet.empty equalities
+ in
+ let addfun s e =
+ if not (EqualitySet.mem e initial) then EqualitySet.add e s else s
+ in
+
+ let passive =
+ match rp with
+ | (n, _), (p, _), _ ->
+ EqualitySet.elements (List.fold_left addfun EqualitySet.empty p)
+ in
+ let active =
+ let l = List.map snd (fst ra) in
+ EqualitySet.elements (List.fold_left addfun EqualitySet.empty l)
+ in
+ Printf.printf "\n\nRESULTS:\nActive:\n%s\n\nPassive:\n%s\n"
+ (String.concat "\n" (List.map (string_of_equality ~env) active))
+ (* (String.concat "\n"
+ (List.map (fun e -> CicPp.ppterm (term_of_equality e)) active)) *)
+(* (String.concat "\n" (List.map (string_of_equality ~env) passive)); *)
+ (String.concat "\n"
+ (List.map (fun e -> CicPp.ppterm (term_of_equality e)) passive));
+ print_newline ();
+(*
+ with e ->
+ debug_print (lazy ("EXCEPTION: " ^ (Printexc.to_string e)))
+*)
+;;
+
+let demodulate_tac ~dbd ~pattern ((proof,goal) as initialstatus) =
+ let module I = Inference in
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = CicUtil.lookup_meta goal metasenv in
+ let eq_indexes, equalities, maxm = I.find_equalities context proof in
+ let lib_eq_uris, library_equalities, maxm =
+ I.find_library_equalities dbd context (proof, goal) (maxm+2) in
+ if library_equalities = [] then prerr_endline "VUOTA!!!";
+ let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in
+ let library_equalities = List.map snd library_equalities in
+ let goalterm = Cic.Meta (metano,irl) in
+ let initgoal = Inference.BasicProof goalterm, [], ty in
+ let env = (metasenv, context, CicUniv.empty_ugraph) in
+ let equalities = simplify_equalities env (equalities@library_equalities) in
+ let table =
+ List.fold_left
+ (fun tbl eq -> Indexing.index tbl eq)
+ Indexing.empty equalities
+ in
+ let newmeta,(newproof,newmetasenv, newty) = Indexing.demodulation_goal
+ maxm (metasenv,context,CicUniv.empty_ugraph) table initgoal
+ in
+ if newmeta != maxm then
+ begin
+ let opengoal = Cic.Meta(maxm,irl) in
+ let proofterm =
+ Inference.build_proof_term ~noproof:opengoal newproof in
+ let extended_metasenv = (maxm,context,newty)::metasenv in
+ let extended_status =
+ (curi,extended_metasenv,pbo,pty),goal in
+ let (status,newgoals) =
+ ProofEngineTypes.apply_tactic
+ (PrimitiveTactics.apply_tac ~term:proofterm)
+ extended_status in
+ (status,maxm::newgoals)
+ end
+ else if newty = ty then
+ raise (ProofEngineTypes.Fail (lazy "no progress"))
+ else ProofEngineTypes.apply_tactic
+ (ReductionTactics.simpl_tac ~pattern)
+ initialstatus
+;;
+
+let demodulate_tac ~dbd ~pattern =
+ ProofEngineTypes.mk_tactic (demodulate_tac ~dbd ~pattern)
+;;
--- /dev/null
+(* Copyright (C) 2006, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+val saturate :
+ HMysql.dbd ->
+ ?full:bool ->
+ ?depth:int ->
+ ?width:int ->
+ ProofEngineTypes.proof * ProofEngineTypes.goal ->
+ (UriManager.uri option * Cic.conjecture list * Cic.term * Cic.term) *
+ 'a list
+
+val weight_age_ratio : int ref
+val weight_age_counter: int ref
+val symbols_ratio: int ref
+val symbols_counter: int ref
+val use_fullred: bool ref
+val time_limit: float ref
+val maxwidth: int ref
+val maxdepth: int ref
+val retrieve_and_print: HMysql.dbd -> Cic.term -> Cic.conjecture list -> 'a -> unit
+val main_demod_equalities: HMysql.dbd ->
+ Cic.term -> Cic.conjecture list -> CicUniv.universe_graph -> unit
+val main: HMysql.dbd ->
+ bool -> Cic.term -> Cic.conjecture list -> CicUniv.universe_graph -> unit
+val demodulate_tac:
+ dbd:HMysql.dbd ->
+ pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
--- /dev/null
+(* $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 ();;
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+let debug = true;;
+
+let debug_print s = if debug then prerr_endline (Lazy.force s);;
+
+let print_metasenv metasenv =
+ String.concat "\n--------------------------\n"
+ (List.map (fun (i, context, term) ->
+ (string_of_int i) ^ " [\n" ^ (CicPp.ppcontext context) ^
+ "\n] " ^ (CicPp.ppterm term))
+ metasenv)
+;;
+
+
+
+
+let print_subst ?(prefix="\n") subst =
+ String.concat prefix
+ (List.map
+ (fun (i, (c, t, ty)) ->
+ Printf.sprintf "?%d -> %s : %s" i
+ (CicPp.ppterm t) (CicPp.ppterm ty))
+ subst)
+;;
+
+type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;;
+
+let string_of_comparison = function
+ | Lt -> "<"
+ | Le -> "<="
+ | Gt -> ">"
+ | Ge -> ">="
+ | Eq -> "="
+ | Incomparable -> "I"
+
+module OrderedTerm =
+struct
+ type t = Cic.term
+
+ let compare = Pervasives.compare
+end
+
+module TermSet = Set.Make(OrderedTerm);;
+module TermMap = Map.Make(OrderedTerm);;
+
+let symbols_of_term term =
+ let module C = Cic in
+ let rec aux map = function
+ | C.Meta _ -> map
+ | C.Appl l ->
+ List.fold_left (fun res t -> (aux res t)) map l
+ | t ->
+ let map =
+ try
+ let c = TermMap.find t map in
+ TermMap.add t (c+1) map
+ with Not_found ->
+ TermMap.add t 1 map
+ in
+ map
+ in
+ aux TermMap.empty term
+;;
+
+
+let metas_of_term term =
+ let module C = Cic in
+ let rec aux = function
+ | C.Meta _ as t -> TermSet.singleton t
+ | C.Appl l ->
+ List.fold_left (fun res t -> TermSet.union res (aux t)) TermSet.empty l
+ | t -> TermSet.empty (* TODO: maybe add other cases? *)
+ in
+ aux term
+;;
+
+
+(************************* rpo ********************************)
+let number = [
+ UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)",3;
+ UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)",6;
+ UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)",9;
+ HelmLibraryObjects.Peano.pred_URI, 12;
+ HelmLibraryObjects.Peano.plus_URI, 15;
+ HelmLibraryObjects.Peano.minus_URI, 18;
+ HelmLibraryObjects.Peano.mult_URI, 21;
+ UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1)",103;
+ UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1/1)",106;
+ UriManager.uri_of_string "cic:/matita/nat/nat/nat.ind#xpointer(1/1/2)",109;
+ UriManager.uri_of_string "cic:/matita/nat/nat/pred.con",112;
+ UriManager.uri_of_string "cic:/matita/nat/plus/plus.con",115;
+ UriManager.uri_of_string "cic:/matita/nat/minus/minus.con",118;
+ UriManager.uri_of_string "cic:/matita/nat/times/times.con",121;
+ ]
+;;
+
+let atomic t =
+ match t with
+ Cic.Const _
+ | Cic.MutInd _
+ | Cic.MutConstruct _
+ | Cic.Rel _ -> true
+ | _ -> false
+
+let sig_order_const t1 t2 =
+ try
+ let u1 = CicUtil.uri_of_term t1 in
+ let u2 = CicUtil.uri_of_term t2 in
+ let n1 = List.assoc u1 number in
+ let n2 = List.assoc u2 number in
+ if n1 < n2 then Lt
+ else if n1 > n2 then Gt
+ else
+ begin
+ prerr_endline ("t1 = "^(CicPp.ppterm t1));
+ prerr_endline ("t2 = "^(CicPp.ppterm t2));
+ assert false
+ end
+ with
+ Invalid_argument _
+ | Not_found -> Incomparable
+
+let sig_order t1 t2 =
+ match t1, t2 with
+ Cic.Rel n, Cic.Rel m when n < m -> Gt (* inverted order *)
+ | Cic.Rel n, Cic.Rel m when n = m -> Incomparable
+ | Cic.Rel n, Cic.Rel m when n > m -> Lt
+ | Cic.Rel _, _ -> Gt
+ | _, Cic.Rel _ -> Lt
+ | _,_ -> sig_order_const t1 t2
+
+let rec rpo_lt t1 t2 =
+ let module C = Cic in
+ let first_trie =
+ match t1,t2 with
+ C.Meta (_, _), C.Meta (_,_) -> false
+ | C.Meta (_,_) , t2 -> TermSet.mem t1 (metas_of_term t2)
+ | t1, C.Meta (_,_) -> false
+ | C.Appl [h1;a1],C.Appl [h2;a2] when h1=h2 ->
+ rpo_lt a1 a2
+ | C.Appl (h1::arg1),C.Appl (h2::arg2) when h1=h2 ->
+ if lex_lt arg1 arg2 then
+ check_lt arg1 t2
+ else false
+ | C.Appl (h1::arg1),C.Appl (h2::arg2) ->
+ (match sig_order h1 h2 with
+ | Lt -> check_lt arg1 t2
+ | _ -> false)
+ | C.Appl (h1::arg1), t2 when atomic t2 ->
+ (match sig_order h1 t2 with
+ | Lt -> check_lt arg1 t2
+ | _ -> false)
+ | t1 , C.Appl (h2::arg2) when atomic t1 ->
+ (match sig_order t1 h2 with
+ | Lt -> true
+ | _ -> false )
+ | C.Appl [] , _ -> assert false
+ | _ , C.Appl [] -> assert false
+ | t1, t2 when (atomic t1 && atomic t2 && t1<>t2) ->
+ (match sig_order t1 t2 with
+ | Lt -> true
+ | _ -> false)
+ | _,_ -> false
+ in
+ if first_trie then true else
+ match t2 with
+ C.Appl (_::args) ->
+ List.exists (fun a -> t1 = a || rpo_lt t1 a) args
+ | _ -> false
+
+and lex_lt l1 l2 =
+ match l1,l2 with
+ [],[] -> false
+ | [],_ -> assert false
+ | _, [] -> assert false
+ | a1::l1, a2::l2 when a1 = a2 -> lex_lt l1 l2
+ | a1::_, a2::_ -> rpo_lt a1 a2
+
+and check_lt l t =
+ List.fold_left
+ (fun b a -> b && (rpo_lt a t))
+ true l
+;;
+
+let rpo t1 t2 =
+ if rpo_lt t2 t1 then Gt
+ else if rpo_lt t1 t2 then Lt
+ else Incomparable
+
+
+(*********************** fine rpo *****************************)
+
+(* (weight of constants, [(meta, weight_of_meta)]) *)
+type weight = int * (int * int) list;;
+
+let string_of_weight (cw, mw) =
+ let s =
+ String.concat ", "
+ (List.map (function (m, w) -> Printf.sprintf "(%d,%d)" m w) mw)
+ in
+ Printf.sprintf "[%d; %s]" cw s
+
+
+let weight_of_term ?(consider_metas=true) term =
+ let module C = Cic in
+ let vars_dict = Hashtbl.create 5 in
+ let rec aux = function
+ | C.Meta (metano, _) when consider_metas ->
+ (try
+ let oldw = Hashtbl.find vars_dict metano in
+ Hashtbl.replace vars_dict metano (oldw+1)
+ with Not_found ->
+ Hashtbl.add vars_dict metano 1);
+ 0
+ | C.Meta _ -> 0 (* "variables" are lighter than constants and functions...*)
+
+ | C.Var (_, ens)
+ | C.Const (_, ens)
+ | C.MutInd (_, _, ens)
+ | C.MutConstruct (_, _, _, ens) ->
+ List.fold_left (fun w (u, t) -> (aux t) + w) 1 ens
+
+ | C.Cast (t1, t2)
+ | C.Lambda (_, t1, t2)
+ | C.Prod (_, t1, t2)
+ | C.LetIn (_, t1, t2) ->
+ let w1 = aux t1 in
+ let w2 = aux t2 in
+ w1 + w2 + 1
+
+ | C.Appl l -> List.fold_left (+) 0 (List.map aux l)
+
+ | C.MutCase (_, _, outt, t, pl) ->
+ let w1 = aux outt in
+ let w2 = aux t in
+ let w3 = List.fold_left (+) 0 (List.map aux pl) in
+ w1 + w2 + w3 + 1
+
+ | C.Fix (_, fl) ->
+ List.fold_left (fun w (n, i, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl
+
+ | C.CoFix (_, fl) ->
+ List.fold_left (fun w (n, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl
+
+ | _ -> 1
+ in
+ let w = aux term in
+ let l =
+ Hashtbl.fold (fun meta metaw resw -> (meta, metaw)::resw) vars_dict [] in
+ let compare w1 w2 =
+ match w1, w2 with
+ | (m1, _), (m2, _) -> m2 - m1
+ in
+ (w, List.sort compare l) (* from the biggest meta to the smallest (0) *)
+;;
+
+
+module OrderedInt = struct
+ type t = int
+
+ let compare = Pervasives.compare
+end
+
+module IntSet = Set.Make(OrderedInt)
+
+let compute_equality_weight ty left right =
+ let metasw = ref 0 in
+ let weight_of t =
+ let w, m = (weight_of_term ~consider_metas:true t) in
+ metasw := !metasw + (2 * (List.length m));
+ w
+ in
+ (* Warning: the following let cannot be expanded since it forces the
+ right evaluation order!!!! *)
+ let w = (weight_of ty) + (weight_of left) + (weight_of right) in
+ w + !metasw
+;;
+
+
+(* returns a "normalized" version of the polynomial weight wl (with type
+ * weight list), i.e. a list sorted ascending by meta number,
+ * from 0 to maxmeta. wl must be sorted descending by meta number. Example:
+ * normalize_weight 5 (3, [(3, 2); (1, 1)]) ->
+ * (3, [(1, 1); (2, 0); (3, 2); (4, 0); (5, 0)]) *)
+let normalize_weight maxmeta (cw, wl) =
+ let rec aux = function
+ | 0 -> []
+ | m -> (m, 0)::(aux (m-1))
+ in
+ let tmpl = aux maxmeta in
+ let wl =
+ List.sort
+ (fun (m, _) (n, _) -> Pervasives.compare m n)
+ (List.fold_left
+ (fun res (m, w) -> (m, w)::(List.remove_assoc m res)) tmpl wl)
+ in
+ (cw, wl)
+;;
+
+
+let normalize_weights (cw1, wl1) (cw2, wl2) =
+ let rec aux wl1 wl2 =
+ match wl1, wl2 with
+ | [], [] -> [], []
+ | (m, w)::tl1, (n, w')::tl2 when m = n ->
+ let res1, res2 = aux tl1 tl2 in
+ (m, w)::res1, (n, w')::res2
+ | (m, w)::tl1, ((n, w')::_ as wl2) when m < n ->
+ let res1, res2 = aux tl1 wl2 in
+ (m, w)::res1, (m, 0)::res2
+ | ((m, w)::_ as wl1), (n, w')::tl2 when m > n ->
+ let res1, res2 = aux wl1 tl2 in
+ (n, 0)::res1, (n, w')::res2
+ | [], (n, w)::tl2 ->
+ let res1, res2 = aux [] tl2 in
+ (n, 0)::res1, (n, w)::res2
+ | (m, w)::tl1, [] ->
+ let res1, res2 = aux tl1 [] in
+ (m, w)::res1, (m, 0)::res2
+ | _, _ -> assert false
+ in
+ let cmp (m, _) (n, _) = compare m n in
+ let wl1, wl2 = aux (List.sort cmp wl1) (List.sort cmp wl2) in
+ (cw1, wl1), (cw2, wl2)
+;;
+
+
+let compare_weights ?(normalize=false)
+ ((h1, w1) as weight1) ((h2, w2) as weight2)=
+ let (h1, w1), (h2, w2) =
+ if normalize then
+ normalize_weights weight1 weight2
+ else
+ (h1, w1), (h2, w2)
+ in
+ let res, diffs =
+ try
+ List.fold_left2
+ (fun ((lt, eq, gt), diffs) w1 w2 ->
+ match w1, w2 with
+ | (meta1, w1), (meta2, w2) when meta1 = meta2 ->
+ let diffs = (w1 - w2) + diffs in
+ let r = compare w1 w2 in
+ if r < 0 then (lt+1, eq, gt), diffs
+ else if r = 0 then (lt, eq+1, gt), diffs
+ else (lt, eq, gt+1), diffs
+ | (meta1, w1), (meta2, w2) ->
+ debug_print
+ (lazy
+ (Printf.sprintf "HMMM!!!! %s, %s\n"
+ (string_of_weight weight1) (string_of_weight weight2)));
+ assert false)
+ ((0, 0, 0), 0) w1 w2
+ with Invalid_argument _ ->
+ debug_print
+ (lazy
+ (Printf.sprintf "Invalid_argument: %s{%s}, %s{%s}, normalize = %s\n"
+ (string_of_weight (h1, w1)) (string_of_weight weight1)
+ (string_of_weight (h2, w2)) (string_of_weight weight2)
+ (string_of_bool normalize)));
+ assert false
+ in
+ let hdiff = h1 - h2 in
+ match res with
+ | (0, _, 0) ->
+ if hdiff < 0 then Lt
+ else if hdiff > 0 then Gt
+ else Eq (* Incomparable *)
+ | (m, _, 0) ->
+ if hdiff <= 0 then Lt
+ else if (- diffs) >= hdiff then Le else Incomparable
+ | (0, _, m) ->
+ if hdiff >= 0 then Gt
+ else if diffs >= (- hdiff) then Ge else Incomparable
+ | (m, _, n) when m > 0 && n > 0 ->
+ Incomparable
+ | _ -> assert false
+
+;;
+
+
+let rec aux_ordering ?(recursion=true) t1 t2 =
+ let module C = Cic in
+ let compare_uris u1 u2 =
+ let res =
+ compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2) in
+ if res < 0 then Lt
+ else if res = 0 then Eq
+ else Gt
+ in
+ match t1, t2 with
+ | C.Meta _, _
+ | _, C.Meta _ -> Incomparable
+
+ | t1, t2 when t1 = t2 -> Eq
+
+ | C.Rel n, C.Rel m -> if n > m then Lt else Gt
+ | C.Rel _, _ -> Lt
+ | _, C.Rel _ -> Gt
+
+ | C.Const (u1, _), C.Const (u2, _) -> compare_uris u1 u2
+ | C.Const _, _ -> Lt
+ | _, C.Const _ -> Gt
+
+ | C.MutInd (u1, _, _), C.MutInd (u2, _, _) -> compare_uris u1 u2
+ | C.MutInd _, _ -> Lt
+ | _, C.MutInd _ -> Gt
+
+ | C.MutConstruct (u1, _, _, _), C.MutConstruct (u2, _, _, _) ->
+ compare_uris u1 u2
+ | C.MutConstruct _, _ -> Lt
+ | _, C.MutConstruct _ -> Gt
+
+ | C.Appl l1, C.Appl l2 when recursion ->
+ let rec cmp t1 t2 =
+ match t1, t2 with
+ | [], [] -> Eq
+ | _, [] -> Gt
+ | [], _ -> Lt
+ | hd1::tl1, hd2::tl2 ->
+ let o = aux_ordering hd1 hd2 in
+ if o = Eq then cmp tl1 tl2
+ else o
+ in
+ cmp l1 l2
+ | C.Appl (h1::t1), C.Appl (h2::t2) when not recursion ->
+ aux_ordering h1 h2
+
+ | t1, t2 ->
+ debug_print
+ (lazy
+ (Printf.sprintf "These two terms are not comparable:\n%s\n%s\n\n"
+ (CicPp.ppterm t1) (CicPp.ppterm t2)));
+ Incomparable
+;;
+
+
+(* w1, w2 are the weights, they should already be normalized... *)
+let nonrec_kbo_w (t1, w1) (t2, w2) =
+ match compare_weights w1 w2 with
+ | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable
+ | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable
+ | Eq -> aux_ordering t1 t2
+ | res -> res
+;;
+
+
+let nonrec_kbo t1 t2 =
+ let w1 = weight_of_term t1 in
+ let w2 = weight_of_term t2 in
+ (*
+ prerr_endline ("weight1 :"^(string_of_weight w1));
+ prerr_endline ("weight2 :"^(string_of_weight w2));
+ *)
+ match compare_weights ~normalize:true w1 w2 with
+ | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable
+ | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable
+ | Eq -> aux_ordering t1 t2
+ | res -> res
+;;
+
+
+let rec kbo t1 t2 =
+ let aux = aux_ordering ~recursion:false in
+ let w1 = weight_of_term t1
+ and w2 = weight_of_term t2 in
+ let rec cmp t1 t2 =
+ match t1, t2 with
+ | [], [] -> Eq
+ | _, [] -> Gt
+ | [], _ -> Lt
+ | hd1::tl1, hd2::tl2 ->
+ let o =
+ kbo hd1 hd2
+ in
+ if o = Eq then cmp tl1 tl2
+ else o
+ in
+ let comparison = compare_weights ~normalize:true w1 w2 in
+ match comparison with
+ | Le ->
+ let r = aux t1 t2 in
+ if r = Lt then Lt
+ else if r = Eq then (
+ match t1, t2 with
+ | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
+ if cmp tl1 tl2 = Lt then Lt else Incomparable
+ | _, _ -> Incomparable
+ ) else Incomparable
+ | Ge ->
+ let r = aux t1 t2 in
+ if r = Gt then Gt
+ else if r = Eq then (
+ match t1, t2 with
+ | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
+ if cmp tl1 tl2 = Gt then Gt else Incomparable
+ | _, _ -> Incomparable
+ ) else Incomparable
+ | Eq ->
+ let r = aux t1 t2 in
+ if r = Eq then (
+ match t1, t2 with
+ | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
+ cmp tl1 tl2
+ | _, _ -> Incomparable
+ ) else r
+ | res -> res
+;;
+
+let rec ao t1 t2 =
+ let get_hd t =
+ match t with
+ Cic.MutConstruct(uri,tyno,cno,_) -> Some(uri,tyno,cno)
+ | Cic.Appl(Cic.MutConstruct(uri,tyno,cno,_)::_) ->
+ Some(uri,tyno,cno)
+ | _ -> None in
+ let aux = aux_ordering ~recursion:false in
+ let w1 = weight_of_term t1
+ and w2 = weight_of_term t2 in
+ let rec cmp t1 t2 =
+ match t1, t2 with
+ | [], [] -> Eq
+ | _, [] -> Gt
+ | [], _ -> Lt
+ | hd1::tl1, hd2::tl2 ->
+ let o =
+ ao hd1 hd2
+ in
+ if o = Eq then cmp tl1 tl2
+ else o
+ in
+ match get_hd t1, get_hd t2 with
+ Some(_),None -> Lt
+ | None,Some(_) -> Gt
+ | _ ->
+ let comparison = compare_weights ~normalize:true w1 w2 in
+ match comparison with
+ | Le ->
+ let r = aux t1 t2 in
+ if r = Lt then Lt
+ else if r = Eq then (
+ match t1, t2 with
+ | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
+ if cmp tl1 tl2 = Lt then Lt else Incomparable
+ | _, _ -> Incomparable
+ ) else Incomparable
+ | Ge ->
+ let r = aux t1 t2 in
+ if r = Gt then Gt
+ else if r = Eq then (
+ match t1, t2 with
+ | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
+ if cmp tl1 tl2 = Gt then Gt else Incomparable
+ | _, _ -> Incomparable
+ ) else Incomparable
+ | Eq ->
+ let r = aux t1 t2 in
+ if r = Eq then (
+ match t1, t2 with
+ | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 ->
+ cmp tl1 tl2
+ | _, _ -> Incomparable
+ ) else r
+ | res -> res
+;;
+
+let names_of_context context =
+ List.map
+ (function
+ | None -> None
+ | Some (n, e) -> Some n)
+ context
+;;
+
+
+let rec lpo t1 t2 =
+ let module C = Cic in
+ match t1, t2 with
+ | t1, t2 when t1 = t2 -> Eq
+ | t1, (C.Meta _ as m) ->
+ if TermSet.mem m (metas_of_term t1) then Gt else Incomparable
+ | (C.Meta _ as m), t2 ->
+ if TermSet.mem m (metas_of_term t2) then Lt else Incomparable
+ | C.Appl (hd1::tl1), C.Appl (hd2::tl2) -> (
+ let res =
+ let f o r t =
+ if r then true else
+ match lpo t o with
+ | Gt | Eq -> true
+ | _ -> false
+ in
+ let res1 = List.fold_left (f t2) false tl1 in
+ if res1 then Gt
+ else let res2 = List.fold_left (f t1) false tl2 in
+ if res2 then Lt
+ else Incomparable
+ in
+ if res <> Incomparable then
+ res
+ else
+ let f o r t =
+ if not r then false else
+ match lpo o t with
+ | Gt -> true
+ | _ -> false
+ in
+ match aux_ordering hd1 hd2 with
+ | Gt ->
+ let res = List.fold_left (f t1) false tl2 in
+ if res then Gt
+ else Incomparable
+ | Lt ->
+ let res = List.fold_left (f t2) false tl1 in
+ if res then Lt
+ else Incomparable
+ | Eq -> (
+ let lex_res =
+ try
+ List.fold_left2
+ (fun r t1 t2 -> if r <> Eq then r else lpo t1 t2)
+ Eq tl1 tl2
+ with Invalid_argument _ ->
+ Incomparable
+ in
+ match lex_res with
+ | Gt ->
+ if List.fold_left (f t1) false tl2 then Gt
+ else Incomparable
+ | Lt ->
+ if List.fold_left (f t2) false tl1 then Lt
+ else Incomparable
+ | _ -> Incomparable
+ )
+ | _ -> Incomparable
+ )
+ | t1, t2 -> aux_ordering t1 t2
+;;
+
+
+(* settable by the user... *)
+let compare_terms = ref nonrec_kbo;;
+(* let compare_terms = ref ao;; *)
+(* let compare_terms = ref rpo;; *)
+
+let guarded_simpl ?(debug=false) context t =
+ if !compare_terms == nonrec_kbo then t
+ else
+ let t' = ProofEngineReduction.simpl context t in
+ if t = t' then t else
+ begin
+ let simpl_order = !compare_terms t t' in
+ if debug then
+ prerr_endline ("comparing "^(CicPp.ppterm t)^(CicPp.ppterm t'));
+ if simpl_order = Gt then (if debug then prerr_endline "GT";t')
+ else (if debug then prerr_endline "NO_GT";t)
+ end
+;;
+
+type equality_sign = Negative | Positive;;
+
+let string_of_sign = function
+ | Negative -> "Negative"
+ | Positive -> "Positive"
+;;
+
+
+type pos = Left | Right
+
+let string_of_pos = function
+ | Left -> "Left"
+ | Right -> "Right"
+;;
+
+
+let eq_ind_URI () = LibraryObjects.eq_ind_URI ~eq:(LibraryObjects.eq_URI ())
+let eq_ind_r_URI () = LibraryObjects.eq_ind_r_URI ~eq:(LibraryObjects.eq_URI ())
+let sym_eq_URI () = LibraryObjects.sym_eq_URI ~eq:(LibraryObjects.eq_URI ())
+let eq_XURI () =
+ let s = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in
+ UriManager.uri_of_string (s ^ "#xpointer(1/1/1)")
+let trans_eq_URI () = LibraryObjects.trans_eq_URI ~eq:(LibraryObjects.eq_URI ())
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* (weight of constants, [(meta, weight_of_meta)]) *)
+type weight = int * (int * int) list;;
+
+type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;;
+
+val print_metasenv: Cic.metasenv -> string
+
+val print_subst: ?prefix:string -> Cic.substitution -> string
+
+val string_of_weight: weight -> string
+
+val weight_of_term: ?consider_metas:bool -> Cic.term -> weight
+
+val normalize_weight: int -> weight -> weight
+
+val string_of_comparison: comparison -> string
+
+val compare_weights: ?normalize:bool -> weight -> weight -> comparison
+
+val nonrec_kbo: Cic.term -> Cic.term -> comparison
+
+val rpo: Cic.term -> Cic.term -> comparison
+
+val nonrec_kbo_w: (Cic.term * weight) -> (Cic.term * weight) -> comparison
+
+val names_of_context: Cic.context -> (Cic.name option) list
+
+module TermMap: Map.S with type key = Cic.term
+
+val symbols_of_term: Cic.term -> int TermMap.t
+
+val lpo: Cic.term -> Cic.term -> comparison
+
+val kbo: Cic.term -> Cic.term -> comparison
+
+val ao: Cic.term -> Cic.term -> comparison
+
+(** term-ordering function settable by the user *)
+val compare_terms: (Cic.term -> Cic.term -> comparison) ref
+
+val guarded_simpl: ?debug:bool -> Cic.context -> Cic.term -> Cic.term
+
+type equality_sign = Negative | Positive
+
+val string_of_sign: equality_sign -> string
+
+type pos = Left | Right
+
+val string_of_pos: pos -> string
+
+val compute_equality_weight: Cic.term -> Cic.term -> Cic.term -> int
+
+val debug_print: string Lazy.t -> unit
+
+val eq_ind_URI: unit -> UriManager.uri
+val eq_ind_r_URI: unit -> UriManager.uri
+val sym_eq_URI: unit -> UriManager.uri
+val eq_XURI: unit -> UriManager.uri
+val trans_eq_URI: unit -> UriManager.uri
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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)])
+;;
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* 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
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+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
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 12/04/2002 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+(* $Id$ *)
+
+(* The code of this module is derived from the code of CicReduction *)
+
+exception Impossible of int;;
+exception ReferenceToConstant;;
+exception ReferenceToVariable;;
+exception ReferenceToCurrentProof;;
+exception ReferenceToInductiveDefinition;;
+exception WrongUriToInductiveDefinition;;
+exception WrongUriToConstant;;
+exception RelToHiddenHypothesis;;
+
+let alpha_equivalence =
+ let module C = Cic in
+ let rec aux t t' =
+ if t = t' then true
+ else
+ match t,t' with
+ C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2) ->
+ UriManager.eq uri1 uri2 &&
+ aux_exp_named_subst exp_named_subst1 exp_named_subst2
+ | C.Cast (te,ty), C.Cast (te',ty') ->
+ aux te te' && aux ty ty'
+ | C.Prod (_,s,t), C.Prod (_,s',t') ->
+ aux s s' && aux t t'
+ | C.Lambda (_,s,t), C.Lambda (_,s',t') ->
+ aux s s' && aux t t'
+ | C.LetIn (_,s,t), C.LetIn(_,s',t') ->
+ aux s s' && aux t t'
+ | C.Appl l, C.Appl l' ->
+ (try
+ List.fold_left2
+ (fun b t1 t2 -> b && aux t1 t2) true l l'
+ with
+ Invalid_argument _ -> false)
+ | C.Const (uri,exp_named_subst1), C.Const (uri',exp_named_subst2) ->
+ UriManager.eq uri uri' &&
+ aux_exp_named_subst exp_named_subst1 exp_named_subst2
+ | C.MutInd (uri,i,exp_named_subst1), C.MutInd (uri',i',exp_named_subst2) ->
+ UriManager.eq uri uri' && i = i' &&
+ aux_exp_named_subst exp_named_subst1 exp_named_subst2
+ | C.MutConstruct (uri,i,j,exp_named_subst1),
+ C.MutConstruct (uri',i',j',exp_named_subst2) ->
+ UriManager.eq uri uri' && i = i' && j = j' &&
+ aux_exp_named_subst exp_named_subst1 exp_named_subst2
+ | C.MutCase (sp,i,outt,t,pl), C.MutCase (sp',i',outt',t',pl') ->
+ UriManager.eq sp sp' && i = i' &&
+ aux outt outt' && aux t t' &&
+ (try
+ List.fold_left2
+ (fun b t1 t2 -> b && aux t1 t2) true pl pl'
+ with
+ Invalid_argument _ -> false)
+ | C.Fix (i,fl), C.Fix (i',fl') ->
+ i = i' &&
+ (try
+ List.fold_left2
+ (fun b (_,i,ty,bo) (_,i',ty',bo') ->
+ b && i = i' && aux ty ty' && aux bo bo'
+ ) true fl fl'
+ with
+ Invalid_argument _ -> false)
+ | C.CoFix (i,fl), C.CoFix (i',fl') ->
+ i = i' &&
+ (try
+ List.fold_left2
+ (fun b (_,ty,bo) (_,ty',bo') ->
+ b && aux ty ty' && aux bo bo'
+ ) true fl fl'
+ with
+ Invalid_argument _ -> false)
+ | _,_ -> false (* we already know that t != t' *)
+ and aux_exp_named_subst exp_named_subst1 exp_named_subst2 =
+ try
+ List.fold_left2
+ (fun b (uri1,t1) (uri2,t2) ->
+ b && UriManager.eq uri1 uri2 && aux t1 t2
+ ) true exp_named_subst1 exp_named_subst2
+ with
+ Invalid_argument _ -> false
+ in
+ aux
+;;
+
+exception WhatAndWithWhatDoNotHaveTheSameLength;;
+
+(* "textual" replacement of several subterms with other ones *)
+let replace ~equality ~what ~with_what ~where =
+ let module C = Cic in
+ let find_image t =
+ let rec find_image_aux =
+ function
+ [],[] -> raise Not_found
+ | what::tl1,with_what::tl2 ->
+ if equality what t then with_what else find_image_aux (tl1,tl2)
+ | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
+ in
+ find_image_aux (what,with_what)
+ in
+ let rec aux t =
+ try
+ find_image t
+ with Not_found ->
+ match t with
+ C.Rel _ -> t
+ | C.Var (uri,exp_named_subst) ->
+ C.Var (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
+ | C.Meta _ -> t
+ | C.Sort _ -> t
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) -> C.Cast (aux te, aux ty)
+ | C.Prod (n,s,t) -> C.Prod (n, aux s, aux t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, aux s, aux t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, aux s, aux t)
+ | C.Appl l ->
+ (* Invariant enforced: no application of an application *)
+ (match List.map aux l with
+ (C.Appl l')::tl -> C.Appl (l'@tl)
+ | l' -> C.Appl l')
+ | C.Const (uri,exp_named_subst) ->
+ C.Const (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
+ | C.MutInd (uri,i,exp_named_subst) ->
+ C.MutInd
+ (uri,i,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ C.MutConstruct
+ (uri,i,j,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,aux outt, aux t,List.map aux pl)
+ | C.Fix (i,fl) ->
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) -> (name, i, aux ty, aux bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) -> (name, aux ty, aux bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ in
+ aux where
+;;
+
+(* replaces in a term a term with another one. *)
+(* Lifting are performed as usual. *)
+let replace_lifting ~equality ~what ~with_what ~where =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let find_image what t =
+ let rec find_image_aux =
+ function
+ [],[] -> raise Not_found
+ | what::tl1,with_what::tl2 ->
+ if equality what t then with_what else find_image_aux (tl1,tl2)
+ | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
+ in
+ find_image_aux (what,with_what)
+ in
+ let rec substaux k what t =
+ try
+ S.lift (k-1) (find_image what t)
+ with Not_found ->
+ match t with
+ C.Rel n as t -> t
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
+ | C.Meta (i, l) ->
+ let l' =
+ List.map
+ (function
+ None -> None
+ | Some t -> Some (substaux k what t)
+ ) l
+ in
+ C.Meta(i,l')
+ | C.Sort _ as t -> t
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) -> C.Cast (substaux k what te, substaux k what ty)
+ | C.Prod (n,s,t) ->
+ C.Prod
+ (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
+ | C.Lambda (n,s,t) ->
+ C.Lambda
+ (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
+ | C.LetIn (n,s,t) ->
+ C.LetIn
+ (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
+ | C.Appl (he::tl) ->
+ (* Invariant: no Appl applied to another Appl *)
+ let tl' = List.map (substaux k what) tl in
+ begin
+ match substaux k what he with
+ C.Appl l -> C.Appl (l@tl')
+ | _ as he' -> C.Appl (he'::tl')
+ end
+ | C.Appl _ -> assert false
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
+ in
+ C.MutInd (uri,i,exp_named_subst')
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
+ in
+ C.MutConstruct (uri,i,j,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,substaux k what outt, substaux k what t,
+ List.map (substaux k what) pl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) ->
+ (name, i, substaux k what ty,
+ substaux (k+len) (List.map (S.lift len) what) bo)
+ ) fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) ->
+ (name, substaux k what ty,
+ substaux (k+len) (List.map (S.lift len) what) bo)
+ ) fl
+ in
+ C.CoFix (i, substitutedfl)
+ in
+ substaux 1 what where
+;;
+
+(* replaces in a term a list of terms with other ones. *)
+(* Lifting are performed as usual. *)
+let replace_lifting_csc nnn ~equality ~what ~with_what ~where =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let find_image t =
+ let rec find_image_aux =
+ function
+ [],[] -> raise Not_found
+ | what::tl1,with_what::tl2 ->
+ if equality what t then with_what else find_image_aux (tl1,tl2)
+ | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
+ in
+ find_image_aux (what,with_what)
+ in
+ let rec substaux k t =
+ try
+ S.lift (k-1) (find_image t)
+ with Not_found ->
+ match t with
+ C.Rel n ->
+ if n < k then C.Rel n else C.Rel (n + nnn)
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
+ | C.Meta (i, l) ->
+ let l' =
+ List.map
+ (function
+ None -> None
+ | Some t -> Some (substaux k t)
+ ) l
+ in
+ C.Meta(i,l')
+ | C.Sort _ as t -> t
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
+ | C.Prod (n,s,t) ->
+ C.Prod (n, substaux k s, substaux (k + 1) t)
+ | C.Lambda (n,s,t) ->
+ C.Lambda (n, substaux k s, substaux (k + 1) t)
+ | C.LetIn (n,s,t) ->
+ C.LetIn (n, substaux k s, substaux (k + 1) t)
+ | C.Appl (he::tl) ->
+ (* Invariant: no Appl applied to another Appl *)
+ let tl' = List.map (substaux k) tl in
+ begin
+ match substaux k he with
+ C.Appl l -> C.Appl (l@tl')
+ | _ as he' -> C.Appl (he'::tl')
+ end
+ | C.Appl _ -> assert false
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
+ in
+ C.MutInd (uri,i,exp_named_subst')
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
+ in
+ C.MutConstruct (uri,i,j,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,substaux k outt, substaux k t,
+ List.map (substaux k) pl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) ->
+ (name, i, substaux k ty, substaux (k+len) bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) ->
+ (name, substaux k ty, substaux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ in
+ substaux 1 where
+;;
+
+(* Takes a well-typed term and fully reduces it. *)
+(*CSC: It does not perform reduction in a Case *)
+let reduce context =
+ let rec reduceaux context l =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ function
+ C.Rel n as t ->
+ (match List.nth context (n-1) with
+ Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
+ | Some (_,C.Def (bo,_)) -> reduceaux context l (S.lift n bo)
+ | None -> raise RelToHiddenHypothesis
+ )
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ | C.Variable (_,None,_,_,_) ->
+ let t' = C.Var (uri,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.Variable (_,Some body,_,_,_) ->
+ (reduceaux context l
+ (CicSubstitution.subst_vars exp_named_subst' body))
+ )
+ | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
+ | C.Sort _ as t -> t (* l should be empty *)
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) ->
+ C.Cast (reduceaux context l te, reduceaux context l ty)
+ | C.Prod (name,s,t) ->
+ assert (l = []) ;
+ C.Prod (name,
+ reduceaux context [] s,
+ reduceaux ((Some (name,C.Decl s))::context) [] t)
+ | C.Lambda (name,s,t) ->
+ (match l with
+ [] ->
+ C.Lambda (name,
+ reduceaux context [] s,
+ reduceaux ((Some (name,C.Decl s))::context) [] t)
+ | he::tl -> reduceaux context tl (S.subst he t)
+ (* when name is Anonimous the substitution should be superfluous *)
+ )
+ | C.LetIn (n,s,t) ->
+ reduceaux context l (S.subst (reduceaux context [] s) t)
+ | C.Appl (he::tl) ->
+ let tl' = List.map (reduceaux context []) tl in
+ reduceaux context (tl'@l) he
+ | C.Appl [] -> raise (Impossible 1)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ C.Constant (_,Some body,_,_,_) ->
+ (reduceaux context l
+ (CicSubstitution.subst_vars exp_named_subst' body))
+ | C.Constant (_,None,_,_,_) ->
+ let t' = C.Const (uri,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof (_,_,body,_,_,_) ->
+ (reduceaux context l
+ (CicSubstitution.subst_vars exp_named_subst' body))
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ let t' = C.MutInd (uri,i,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ let t' = C.MutConstruct (uri,i,j,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.MutCase (mutind,i,outtype,term,pl) ->
+ let decofix =
+ function
+ C.CoFix (i,fl) ->
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ reduceaux context [] body'
+ | C.Appl (C.CoFix (i,fl) :: tl) ->
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ let tl' = List.map (reduceaux context []) tl in
+ reduceaux context tl' body'
+ | t -> t
+ in
+ (match decofix (reduceaux context [] term) with
+ C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
+ | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
+ let (arity, r) =
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in
+ match o with
+ C.InductiveDefinition (tl,_,r,_) ->
+ let (_,_,arity,_) = List.nth tl i in
+ (arity,r)
+ | _ -> raise WrongUriToInductiveDefinition
+ in
+ let ts =
+ let rec eat_first =
+ function
+ (0,l) -> l
+ | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
+ | _ -> raise (Impossible 5)
+ in
+ eat_first (r,tl)
+ in
+ reduceaux context (ts@l) (List.nth pl (j-1))
+ | C.Cast _ | C.Implicit _ ->
+ raise (Impossible 2) (* we don't trust our whd ;-) *)
+ | _ ->
+ let outtype' = reduceaux context [] outtype in
+ let term' = reduceaux context [] term in
+ let pl' = List.map (reduceaux context []) pl in
+ let res =
+ C.MutCase (mutind,i,outtype',term',pl')
+ in
+ if l = [] then res else C.Appl (res::l)
+ )
+ | C.Fix (i,fl) ->
+ let tys =
+ List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
+ in
+ let t' () =
+ let fl' =
+ List.map
+ (function (n,recindex,ty,bo) ->
+ (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
+ ) fl
+ in
+ C.Fix (i, fl')
+ in
+ let (_,recindex,_,body) = List.nth fl i in
+ let recparam =
+ try
+ Some (List.nth l recindex)
+ with
+ _ -> None
+ in
+ (match recparam with
+ Some recparam ->
+ (match reduceaux context [] recparam with
+ C.MutConstruct _
+ | C.Appl ((C.MutConstruct _)::_) ->
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
+ fl
+ body
+ in
+ (* Possible optimization: substituting whd recparam in l*)
+ reduceaux context l body'
+ | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
+ )
+ | None -> if l = [] then t' () else C.Appl ((t' ())::l)
+ )
+ | C.CoFix (i,fl) ->
+ let tys =
+ List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
+ in
+ let t' =
+ let fl' =
+ List.map
+ (function (n,ty,bo) ->
+ (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
+ ) fl
+ in
+ C.CoFix (i, fl')
+ in
+ if l = [] then t' else C.Appl (t'::l)
+ and reduceaux_exp_named_subst context l =
+ List.map (function uri,t -> uri,reduceaux context [] t)
+ in
+ reduceaux context []
+;;
+
+exception WrongShape;;
+exception AlreadySimplified;;
+
+(* Takes a well-typed term and *)
+(* 1) Performs beta-iota-zeta reduction until delta reduction is needed *)
+(* 2) Attempts delta-reduction. If the residual is a Fix lambda-abstracted *)
+(* w.r.t. zero or more variables and if the Fix can be reductaed, than it*)
+(* is reduced, the delta-reduction is succesfull and the whole algorithm *)
+(* is applied again to the new redex; Step 3.1) is applied to the result *)
+(* of the recursive simplification. Otherwise, if the Fix can not be *)
+(* reduced, than the delta-reductions fails and the delta-redex is *)
+(* not reduced. Otherwise, if the delta-residual is not the *)
+(* lambda-abstraction of a Fix, then it performs step 3.2). *)
+(* 3.1) Folds the application of the constant to the arguments that did not *)
+(* change in every iteration, i.e. to the actual arguments for the *)
+(* lambda-abstractions that precede the Fix. *)
+(* 3.2) Computes the head beta-zeta normal form of the term. Then it tries *)
+(* reductions. If the reduction cannot be performed, it returns the *)
+(* original term (not the head beta-zeta normal form of the definiendum) *)
+(*CSC: It does not perform simplification in a Case *)
+
+let simpl context =
+ (* reduceaux is equal to the reduceaux locally defined inside *)
+ (* reduce, but for the const case. *)
+ (**** Step 1 ****)
+ let rec reduceaux context l =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ function
+ C.Rel n as t ->
+ (* we never perform delta expansion automatically *)
+ if l = [] then t else C.Appl (t::l)
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ | C.Variable (_,None,_,_,_) ->
+ let t' = C.Var (uri,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.Variable (_,Some body,_,_,_) ->
+ reduceaux context l
+ (CicSubstitution.subst_vars exp_named_subst' body)
+ )
+ | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
+ | C.Sort _ as t -> t (* l should be empty *)
+ | C.Implicit _ as t -> t
+ | C.Cast (te,ty) ->
+ C.Cast (reduceaux context l te, reduceaux context [] ty)
+ | C.Prod (name,s,t) ->
+ assert (l = []) ;
+ C.Prod (name,
+ reduceaux context [] s,
+ reduceaux ((Some (name,C.Decl s))::context) [] t)
+ | C.Lambda (name,s,t) ->
+ (match l with
+ [] ->
+ C.Lambda (name,
+ reduceaux context [] s,
+ reduceaux ((Some (name,C.Decl s))::context) [] t)
+ | he::tl -> reduceaux context tl (S.subst he t)
+ (* when name is Anonimous the substitution should be superfluous *)
+ )
+ | C.LetIn (n,s,t) ->
+ reduceaux context l (S.subst (reduceaux context [] s) t)
+ | C.Appl (he::tl) ->
+ let tl' = List.map (reduceaux context []) tl in
+ reduceaux context (tl'@l) he
+ | C.Appl [] -> raise (Impossible 1)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ match o with
+ C.Constant (_,Some body,_,_,_) ->
+ try_delta_expansion context l
+ (C.Const (uri,exp_named_subst'))
+ (CicSubstitution.subst_vars exp_named_subst' body)
+ | C.Constant (_,None,_,_,_) ->
+ let t' = C.Const (uri,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof (_,_,body,_,_,_) -> reduceaux context l body
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ let t' = C.MutInd (uri,i,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ let t' = C.MutConstruct(uri,i,j,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.MutCase (mutind,i,outtype,term,pl) ->
+ let decofix =
+ function
+ C.CoFix (i,fl) ->
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ reduceaux context [] body'
+ | C.Appl (C.CoFix (i,fl) :: tl) ->
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ let tl' = List.map (reduceaux context []) tl in
+ reduceaux context tl' body'
+ | t -> t
+ in
+ (match decofix (CicReduction.whd context term) with
+ C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
+ | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
+ let (arity, r) =
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph mutind in
+ match o with
+ C.InductiveDefinition (tl,ingredients,r,_) ->
+ let (_,_,arity,_) = List.nth tl i in
+ (arity,r)
+ | _ -> raise WrongUriToInductiveDefinition
+ in
+ let ts =
+ let rec eat_first =
+ function
+ (0,l) -> l
+ | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
+ | _ -> raise (Impossible 5)
+ in
+ eat_first (r,tl)
+ in
+ reduceaux context (ts@l) (List.nth pl (j-1))
+ | C.Cast _ | C.Implicit _ ->
+ raise (Impossible 2) (* we don't trust our whd ;-) *)
+ | _ ->
+ let outtype' = reduceaux context [] outtype in
+ let term' = reduceaux context [] term in
+ let pl' = List.map (reduceaux context []) pl in
+ let res =
+ C.MutCase (mutind,i,outtype',term',pl')
+ in
+ if l = [] then res else C.Appl (res::l)
+ )
+ | C.Fix (i,fl) ->
+ let tys =
+ List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
+ in
+ let t' () =
+ let fl' =
+ List.map
+ (function (n,recindex,ty,bo) ->
+ (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
+ ) fl
+ in
+ C.Fix (i, fl')
+ in
+ let (_,recindex,_,body) = List.nth fl i in
+ let recparam =
+ try
+ Some (List.nth l recindex)
+ with
+ _ -> None
+ in
+ (match recparam with
+ Some recparam ->
+ (match reduceaux context [] recparam with
+ C.MutConstruct _
+ | C.Appl ((C.MutConstruct _)::_) ->
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
+ fl
+ body
+ in
+ (* Possible optimization: substituting whd recparam in l*)
+ reduceaux context l body'
+ | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
+ )
+ | None -> if l = [] then t' () else C.Appl ((t' ())::l)
+ )
+ | C.CoFix (i,fl) ->
+ let tys =
+ List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
+ in
+ let t' =
+ let fl' =
+ List.map
+ (function (n,ty,bo) ->
+ (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
+ ) fl
+ in
+ C.CoFix (i, fl')
+ in
+ if l = [] then t' else C.Appl (t'::l)
+ and reduceaux_exp_named_subst context l =
+ List.map (function uri,t -> uri,reduceaux context [] t)
+ (**** Step 2 ****)
+ and try_delta_expansion context l term body =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ try
+ let res,constant_args =
+ let rec aux rev_constant_args l =
+ function
+ C.Lambda (name,s,t) ->
+ begin
+ match l with
+ [] -> raise WrongShape
+ | he::tl ->
+ (* when name is Anonimous the substitution should *)
+ (* be superfluous *)
+ aux (he::rev_constant_args) tl (S.subst he t)
+ end
+ | C.LetIn (_,s,t) ->
+ aux rev_constant_args l (S.subst s t)
+ | C.Fix (i,fl) ->
+ let (_,recindex,_,body) = List.nth fl i in
+ let recparam =
+ try
+ List.nth l recindex
+ with
+ _ -> raise AlreadySimplified
+ in
+ (match CicReduction.whd context recparam with
+ C.MutConstruct _
+ | C.Appl ((C.MutConstruct _)::_) ->
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (function _ ->
+ decr counter ; S.subst (C.Fix (!counter,fl))
+ ) fl body
+ in
+ (* Possible optimization: substituting whd *)
+ (* recparam in l *)
+ reduceaux context l body',
+ List.rev rev_constant_args
+ | _ -> raise AlreadySimplified
+ )
+ | _ -> raise WrongShape
+ in
+ aux [] l body
+ in
+ (**** Step 3.1 ****)
+ let term_to_fold, delta_expanded_term_to_fold =
+ match constant_args with
+ [] -> term,body
+ | _ -> C.Appl (term::constant_args), C.Appl (body::constant_args)
+ in
+ let simplified_term_to_fold =
+ reduceaux context [] delta_expanded_term_to_fold
+ in
+ replace (=) [simplified_term_to_fold] [term_to_fold] res
+ with
+ WrongShape ->
+ (**** Step 3.2 ****)
+ let rec aux l =
+ function
+ C.Lambda (name,s,t) ->
+ (match l with
+ [] -> raise AlreadySimplified
+ | he::tl ->
+ (* when name is Anonimous the substitution should *)
+ (* be superfluous *)
+ aux tl (S.subst he t))
+ | C.LetIn (_,s,t) -> aux l (S.subst s t)
+ | t ->
+ let simplified = reduceaux context l t in
+ if t = simplified then
+ raise AlreadySimplified
+ else
+ simplified
+ in
+ (try aux l body
+ with
+ AlreadySimplified ->
+ if l = [] then term else C.Appl (term::l))
+ | AlreadySimplified ->
+ (* If we performed delta-reduction, we would find a Fix *)
+ (* not applied to a constructor. So, we refuse to perform *)
+ (* delta-reduction. *)
+ if l = [] then term else C.Appl (term::l)
+ in
+ reduceaux context []
+;;
+
+let unfold ?what context where =
+ let contextlen = List.length context in
+ let first_is_the_expandable_head_of_second context' t1 t2 =
+ match t1,t2 with
+ Cic.Const (uri,_), Cic.Const (uri',_)
+ | Cic.Var (uri,_), Cic.Var (uri',_)
+ | Cic.Const (uri,_), Cic.Appl (Cic.Const (uri',_)::_)
+ | Cic.Var (uri,_), Cic.Appl (Cic.Var (uri',_)::_) -> UriManager.eq uri uri'
+ | Cic.Const _, _
+ | Cic.Var _, _ -> false
+ | Cic.Rel n, Cic.Rel m
+ | Cic.Rel n, Cic.Appl (Cic.Rel m::_) ->
+ n + (List.length context' - contextlen) = m
+ | Cic.Rel _, _ -> false
+ | _,_ ->
+ raise
+ (ProofEngineTypes.Fail
+ (lazy "The term to unfold is not a constant, a variable or a bound variable "))
+ in
+ let appl he tl =
+ if tl = [] then he else Cic.Appl (he::tl) in
+ let cannot_delta_expand t =
+ raise
+ (ProofEngineTypes.Fail
+ (lazy ("The term " ^ CicPp.ppterm t ^ " cannot be delta-expanded"))) in
+ let rec hd_delta_beta context tl =
+ function
+ Cic.Rel n as t ->
+ (try
+ match List.nth context (n-1) with
+ Some (_,Cic.Decl _) -> cannot_delta_expand t
+ | Some (_,Cic.Def (bo,_)) ->
+ CicReduction.head_beta_reduce
+ (appl (CicSubstitution.lift n bo) tl)
+ | None -> raise RelToHiddenHypothesis
+ with
+ Failure _ -> assert false)
+ | Cic.Const (uri,exp_named_subst) as t ->
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ (match o with
+ Cic.Constant (_,Some body,_,_,_) ->
+ CicReduction.head_beta_reduce
+ (appl (CicSubstitution.subst_vars exp_named_subst body) tl)
+ | Cic.Constant (_,None,_,_,_) -> cannot_delta_expand t
+ | Cic.Variable _ -> raise ReferenceToVariable
+ | Cic.CurrentProof _ -> raise ReferenceToCurrentProof
+ | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ | Cic.Var (uri,exp_named_subst) as t ->
+ let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ (match o with
+ Cic.Constant _ -> raise ReferenceToConstant
+ | Cic.CurrentProof _ -> raise ReferenceToCurrentProof
+ | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ | Cic.Variable (_,Some body,_,_,_) ->
+ CicReduction.head_beta_reduce
+ (appl (CicSubstitution.subst_vars exp_named_subst body) tl)
+ | Cic.Variable (_,None,_,_,_) -> cannot_delta_expand t
+ )
+ | Cic.Appl [] -> assert false
+ | Cic.Appl (he::tl) -> hd_delta_beta context tl he
+ | t -> cannot_delta_expand t
+ in
+ let context_and_matched_term_list =
+ match what with
+ None -> [context, where]
+ | Some what ->
+ let res =
+ ProofEngineHelpers.locate_in_term
+ ~equality:first_is_the_expandable_head_of_second
+ what ~where context
+ in
+ if res = [] then
+ raise
+ (ProofEngineTypes.Fail
+ (lazy ("Term "^ CicPp.ppterm what ^ " not found in " ^ CicPp.ppterm where)))
+ else
+ res
+ in
+ let reduced_terms =
+ List.map
+ (function (context,where) -> hd_delta_beta context [] where)
+ context_and_matched_term_list in
+ let whats = List.map snd context_and_matched_term_list in
+ replace ~equality:(==) ~what:whats ~with_what:reduced_terms ~where
+;;
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception Impossible of int
+exception ReferenceToConstant
+exception ReferenceToVariable
+exception ReferenceToCurrentProof
+exception ReferenceToInductiveDefinition
+exception WrongUriToInductiveDefinition
+exception RelToHiddenHypothesis
+exception WrongShape
+exception AlreadySimplified
+exception WhatAndWithWhatDoNotHaveTheSameLength;;
+
+val alpha_equivalence: Cic.term -> Cic.term -> bool
+val replace :
+ equality:('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
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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))))
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val clearbody: hyp: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
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+ (**
+ current proof (proof uri * metas * (in)complete proof * term to be prooved)
+ *)
+type proof = UriManager.uri 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
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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)
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val 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
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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
+
--- /dev/null
+
+ (* ring tactics *)
+val ring_tac: ProofEngineTypes.tactic
+
+(*Galla: spostata in variuosTactics.ml
+ (* auxiliary tactics *)
+val elim_type_tac: term: Cic.term -> ProofEngineTypes.tactic
+*)
+
+(* spostata in variousTactics.ml
+val reflexivity_tac: ProofEngineTypes.tactic
+*)
--- /dev/null
+(* Copyright (C) 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 _ _ -> ()) ()
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*****************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 18/02/2003 *)
+(* *)
+(* *)
+(*****************************************************************************)
+
+(* $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
+;;
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val id_tac : ProofEngineTypes.tactic
+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
+
--- /dev/null
+(* Copyright (C) 2004, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+let absurd = NegationTactics.absurd_tac
+let apply = PrimitiveTactics.apply_tac
+let assumption = VariousTactics.assumption_tac
+let auto = AutoTactic.auto_tac
+let change = ReductionTactics.change_tac
+let clear = ProofEngineStructuralRules.clear
+let clearbody = ProofEngineStructuralRules.clearbody
+let compare = DiscriminationTactics.compare_tac
+let constructor = IntroductionTactics.constructor_tac
+let contradiction = NegationTactics.contradiction_tac
+let cut = PrimitiveTactics.cut_tac
+let decide_equality = DiscriminationTactics.decide_equality_tac
+let decompose = EliminationTactics.decompose_tac
+let demodulate = Saturation.demodulate_tac
+let discriminate = DiscriminationTactics.discriminate_tac
+let elim_intros = PrimitiveTactics.elim_intros_tac
+let elim_intros_simpl = PrimitiveTactics.elim_intros_simpl_tac
+let elim_type = EliminationTactics.elim_type_tac
+let exact = PrimitiveTactics.exact_tac
+let exists = IntroductionTactics.exists_tac
+let fail = Tacticals.fail_tac
+let fold = ReductionTactics.fold_tac
+let fourier = FourierR.fourier_tac
+let fwd_simpl = FwdSimplTactic.fwd_simpl_tac
+let generalize = VariousTactics.generalize_tac
+let id = Tacticals.id_tac
+let injection = DiscriminationTactics.injection_tac
+let intros = PrimitiveTactics.intros_tac
+let inversion = Inversion.inversion_tac
+let lapply = FwdSimplTactic.lapply_tac
+let left = IntroductionTactics.left_tac
+let letin = PrimitiveTactics.letin_tac
+let normalize = ReductionTactics.normalize_tac
+let reduce = ReductionTactics.reduce_tac
+let reflexivity = EqualityTactics.reflexivity_tac
+let replace = EqualityTactics.replace_tac
+let rewrite = EqualityTactics.rewrite_tac
+let rewrite_simpl = EqualityTactics.rewrite_simpl_tac
+let right = IntroductionTactics.right_tac
+let ring = Ring.ring_tac
+let set_goal = ProofEngineStructuralRules.set_goal
+let simpl = ReductionTactics.simpl_tac
+let split = IntroductionTactics.split_tac
+let symmetry = EqualityTactics.symmetry_tac
+let transitivity = EqualityTactics.transitivity_tac
+let unfold = ReductionTactics.unfold_tac
+let whd = ReductionTactics.whd_tac
--- /dev/null
+(* GENERATED FILE, DO NOT EDIT *)
+val absurd : term:Cic.term -> ProofEngineTypes.tactic
+val apply : term:Cic.term -> ProofEngineTypes.tactic
+val assumption : ProofEngineTypes.tactic
+val auto :
+ ?depth:int ->
+ ?width:int ->
+ ?paramodulation:string ->
+ ?full:string -> dbd:HMysql.dbd -> unit -> ProofEngineTypes.tactic
+val change :
+ pattern:ProofEngineTypes.lazy_pattern ->
+ Cic.lazy_term -> ProofEngineTypes.tactic
+val clear : hyp:string -> ProofEngineTypes.tactic
+val clearbody : hyp:string -> ProofEngineTypes.tactic
+val compare : term:Cic.term -> ProofEngineTypes.tactic
+val constructor : n:int -> ProofEngineTypes.tactic
+val contradiction : ProofEngineTypes.tactic
+val cut :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
+ Cic.term -> ProofEngineTypes.tactic
+val decide_equality : ProofEngineTypes.tactic
+val decompose :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
+ ?user_types:(UriManager.uri * int) list ->
+ dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic
+val demodulate :
+ dbd:HMysql.dbd ->
+ pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
+val discriminate : term:Cic.term -> ProofEngineTypes.tactic
+val elim_intros :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
+ ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic
+val elim_intros_simpl :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
+ ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic
+val elim_type :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
+ ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic
+val exact : term:Cic.term -> ProofEngineTypes.tactic
+val exists : ProofEngineTypes.tactic
+val fail : ProofEngineTypes.tactic
+val fold :
+ reduction:ProofEngineTypes.lazy_reduction ->
+ term:Cic.lazy_term ->
+ pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
+val fourier : ProofEngineTypes.tactic
+val fwd_simpl :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
+ dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic
+val generalize :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
+ ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
+val id : ProofEngineTypes.tactic
+val injection : term:Cic.term -> ProofEngineTypes.tactic
+val intros :
+ ?howmany:int ->
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
+ unit -> ProofEngineTypes.tactic
+val inversion : term:Cic.term -> ProofEngineTypes.tactic
+val lapply :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
+ ?how_many:int ->
+ ?to_what:Cic.term list -> Cic.term -> ProofEngineTypes.tactic
+val left : ProofEngineTypes.tactic
+val letin :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
+ Cic.term -> ProofEngineTypes.tactic
+val normalize :
+ pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
+val reduce : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
+val reflexivity : ProofEngineTypes.tactic
+val replace :
+ pattern:ProofEngineTypes.lazy_pattern ->
+ with_what:Cic.lazy_term -> ProofEngineTypes.tactic
+val rewrite :
+ direction:[ `LeftToRight | `RightToLeft ] ->
+ pattern:ProofEngineTypes.lazy_pattern ->
+ Cic.term -> ProofEngineTypes.tactic
+val rewrite_simpl :
+ direction:[ `LeftToRight | `RightToLeft ] ->
+ pattern:ProofEngineTypes.lazy_pattern ->
+ Cic.term -> ProofEngineTypes.tactic
+val right : ProofEngineTypes.tactic
+val ring : ProofEngineTypes.tactic
+val set_goal : int -> ProofEngineTypes.tactic
+val simpl : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
+val split : ProofEngineTypes.tactic
+val symmetry : ProofEngineTypes.tactic
+val transitivity : term:Cic.term -> ProofEngineTypes.tactic
+val unfold :
+ Cic.lazy_term option ->
+ pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
+val whd : pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $Id$ *)
+
+
+(* TODO se ce n'e' piu' di una, prende la prima che trova... sarebbe meglio
+chiedere: find dovrebbe restituire una lista di hyp (?) da passare all'utonto con una
+funzione di callback che restituisce la (sola) hyp da applicare *)
+
+let assumption_tac =
+ let module PET = ProofEngineTypes in
+ let assumption_tac status =
+ let (proof, goal) = status in
+ let module C = Cic in
+ let module R = CicReduction in
+ let module S = CicSubstitution in
+ let module PT = PrimitiveTactics in
+ let _,metasenv,_,_ = proof in
+ let _,context,ty = CicUtil.lookup_meta goal metasenv in
+ let rec find n = function
+ hd::tl ->
+ (match hd with
+ (Some (_, C.Decl t)) when
+ fst (R.are_convertible context (S.lift n t) ty
+ CicUniv.empty_ugraph) -> n
+ | (Some (_, C.Def (_,Some ty'))) when
+ fst (R.are_convertible context (S.lift n ty') ty
+ CicUniv.empty_ugraph) -> n
+ | (Some (_, C.Def (t,None))) ->
+ let ty_t, u = (* TASSI: FIXME *)
+ CicTypeChecker.type_of_aux' metasenv context (S.lift n t)
+ CicUniv.empty_ugraph in
+ let b,_ = R.are_convertible context ty_t ty u in
+ if b then n else find (n+1) tl
+ | _ -> find (n+1) tl
+ )
+ | [] -> raise (PET.Fail (lazy "Assumption: No such assumption"))
+ in PET.apply_tactic (PT.apply_tac ~term:(C.Rel (find 1 context))) status
+ in
+ PET.mk_tactic assumption_tac
+;;
+
+(* ANCORA DA DEBUGGARE *)
+
+exception UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly;;
+exception TheSelectedTermsMustLiveInTheGoalContext
+exception AllSelectedTermsMustBeConvertible;;
+exception GeneralizationInHypothesesNotImplementedYet;;
+
+let generalize_tac
+ ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[])
+ pattern
+ =
+ let module PET = ProofEngineTypes in
+ let generalize_tac mk_fresh_name_callback
+ ~pattern:(term,hyps_pat,concl_pat) status
+ =
+ if hyps_pat <> [] then raise GeneralizationInHypothesesNotImplementedYet;
+ let (proof, goal) = status in
+ let module C = Cic in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ let uri,metasenv,pbo,pty = proof in
+ let (_,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in
+ let subst,metasenv,u,selected_hyps,terms_with_context =
+ ProofEngineHelpers.select ~metasenv ~ugraph:CicUniv.empty_ugraph
+ ~conjecture ~pattern in
+ let context = CicMetaSubst.apply_subst_context subst context in
+ let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in
+ let pbo = CicMetaSubst.apply_subst subst pbo in
+ let pty = CicMetaSubst.apply_subst subst pty in
+ let term =
+ match term with
+ None -> None
+ | Some term ->
+ Some (fun context metasenv ugraph ->
+ let term, metasenv, ugraph = term context metasenv ugraph in
+ CicMetaSubst.apply_subst subst term,
+ CicMetaSubst.apply_subst_metasenv subst metasenv,
+ ugraph)
+ in
+ let u,typ,term, metasenv' =
+ let context_of_t, (t, metasenv, u) =
+ match terms_with_context, term with
+ [], None ->
+ raise
+ UnableToDetectTheTermThatMustBeGeneralizedYouMustGiveItExplicitly
+ | [], Some t -> context, t context metasenv u
+ | (context_of_t, _)::_, Some t ->
+ context_of_t, t context_of_t metasenv u
+ | (context_of_t, t)::_, None -> context_of_t, (t, metasenv, u)
+ in
+ let t,subst,metasenv' =
+ try
+ CicMetaSubst.delift_rels [] metasenv
+ (List.length context_of_t - List.length context) t
+ with
+ CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
+ raise TheSelectedTermsMustLiveInTheGoalContext
+ in
+ (*CSC: I am not sure about the following two assertions;
+ maybe I need to propagate the new subst and metasenv *)
+ assert (subst = []);
+ assert (metasenv' = metasenv);
+ let typ,u = CicTypeChecker.type_of_aux' ~subst metasenv context t u in
+ u,typ,t,metasenv
+ in
+ (* We need to check:
+ 1. whether they live in the context of the goal;
+ if they do they are also well-typed since they are closed subterms
+ of a well-typed term in the well-typed context of the well-typed
+ term
+ 2. whether they are convertible
+ *)
+ ignore (
+ List.fold_left
+ (fun u (context_of_t,t) ->
+ (* 1 *)
+ let t,subst,metasenv'' =
+ try
+ CicMetaSubst.delift_rels [] metasenv'
+ (List.length context_of_t - List.length context) t
+ with
+ CicMetaSubst.DeliftingARelWouldCaptureAFreeVariable ->
+ raise TheSelectedTermsMustLiveInTheGoalContext in
+ (*CSC: I am not sure about the following two assertions;
+ maybe I need to propagate the new subst and metasenv *)
+ assert (subst = []);
+ assert (metasenv'' = metasenv');
+ (* 2 *)
+ let b,u1 = CicReduction.are_convertible ~subst context term t u in
+ if not b then
+ raise AllSelectedTermsMustBeConvertible
+ else
+ u1
+ ) u terms_with_context) ;
+ let status = (uri,metasenv',pbo,pty),goal in
+ let proof,goals =
+ PET.apply_tactic
+ (T.thens
+ ~start:
+ (P.cut_tac
+ (C.Prod(
+ (mk_fresh_name_callback metasenv context C.Anonymous ~typ:typ),
+ typ,
+ (ProofEngineReduction.replace_lifting_csc 1
+ ~equality:(==)
+ ~what:(List.map snd terms_with_context)
+ ~with_what:(List.map (function _ -> C.Rel 1) terms_with_context)
+ ~where:ty)
+ )))
+ ~continuations:
+ [(P.apply_tac ~term:(C.Appl [C.Rel 1; CicSubstitution.lift 1 term])) ;
+ T.id_tac])
+ status
+ in
+ let _,metasenv'',_,_ = proof in
+ (* CSC: the following is just a bad approximation since a meta
+ can be closed and then re-opened! *)
+ (proof,
+ goals @
+ (List.filter
+ (fun j -> List.exists (fun (i,_,_) -> i = j) metasenv'')
+ (ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv
+ ~newmetasenv:metasenv')))
+ in
+ PET.mk_tactic (generalize_tac mk_fresh_name_callback ~pattern)
+;;
--- /dev/null
+
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception AllSelectedTermsMustBeConvertible;;
+
+val assumption_tac: ProofEngineTypes.tactic
+
+val generalize_tac:
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
+ ProofEngineTypes.lazy_pattern ->
+ ProofEngineTypes.tactic
+
--- /dev/null
+threadSafe.cmo: threadSafe.cmi
+threadSafe.cmx: threadSafe.cmi
+extThread.cmo: extThread.cmi
+extThread.cmx: extThread.cmi
--- /dev/null
+
+PACKAGE = thread
+INTERFACE_FILES = threadSafe.mli extThread.mli
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+
+all: thread_fake.cma
+opt: thread_fake.cmxa
+
+include ../../Makefile.defs
+include ../Makefile.common
+
+fake/threadSafe.cmi: fake/threadSafe.mli
+ @echo " OCAMLC $<"
+ @cd fake/ \
+ && ocamlfind ocamlc -c threadSafe.mli
+thread_fake.cma: fake/threadSafe.cmi
+ @echo " OCAMLC -a $@"
+ @cd fake/ \
+ && ocamlfind ocamlc -a -o $@ threadSafe.ml \
+ && cp $@ ../
+thread_fake.cmxa: fake/threadSafe.cmi
+ @echo " OCAMLOPT -a $@"
+ @cd fake/ \
+ && ocamlfind opt -a -o $@ threadSafe.ml \
+ && cp $@ ../
+
+clean: clean_fake
+clean_fake:
+ rm -f fake/*.cm[aiox] fake/*.cmxa fake/*.[ao]
+ rm -f thread_fake.cma thread_fake.cmxa
+
--- /dev/null
+(*
+ * 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 ])
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(** {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
+
--- /dev/null
+(*
+ * 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
+
--- /dev/null
+(*
+ * 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
+
--- /dev/null
+(*
+ * 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
+
--- /dev/null
+(*
+ * 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
+
--- /dev/null
+uriManager.cmo: uriManager.cmi
+uriManager.cmx: uriManager.cmi
--- /dev/null
+PACKAGE = urimanager
+PREDICATES =
+
+INTERFACE_FILES = uriManager.mli
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+EXTRA_OBJECTS_TO_INSTALL =
+EXTRA_OBJECTS_TO_CLEAN =
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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)
+
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception 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
+
--- /dev/null
+utf8Macro.cmo: utf8MacroTable.cmo utf8Macro.cmi
+utf8Macro.cmx: utf8MacroTable.cmx utf8Macro.cmi
--- /dev/null
+PACKAGE = utf8_macros
+PREDICATES =
+MAKE_TABLE_PACKAGES = helm-xml
+
+# modules which have both a .ml and a .mli
+INTERFACE_FILES = utf8Macro.mli
+IMPLEMENTATION_FILES = utf8MacroTable.ml $(INTERFACE_FILES:%.mli=%.ml)
+EXTRA_OBJECTS_TO_INSTALL =
+EXTRA_OBJECTS_TO_CLEAN =
+
+all: utf8_macros.cma pa_unicode_macro.cma
+
+make_table: make_table.ml
+ @echo " OCAMLC $<"
+ @$(OCAMLFIND) ocamlc -package $(MAKE_TABLE_PACKAGES) -linkpkg -o $@ $^
+
+utf8MacroTable.ml:
+ ./make_table $@
+utf8MacroTable.cmo: utf8MacroTable.ml
+ @echo " OCAMLC $<"
+ @$(OCAMLFIND) ocamlc -c $<
+
+pa_unicode_macro.cmo: pa_unicode_macro.ml utf8Macro.cmo
+ @echo " OCAMLC $<"
+ @$(OCAMLFIND) ocamlc -package camlp4 -pp "camlp4o q_MLast.cmo pa_extend.cmo -loc loc" -c $<
+pa_unicode_macro.cma: utf8MacroTable.cmo utf8Macro.cmo pa_unicode_macro.cmo
+ @echo " OCAMLC -a $@"
+ @$(OCAMLFIND) ocamlc -a -o $@ $^
+
+.PHONY: test
+test: test.ml
+ $(OCAMLFIND) ocamlc -package helm-utf8_macros -syntax camlp4o $< -o $@
+
+clean:
+distclean: extra_clean
+extra_clean:
+ rm -f make_table test
+
+STATS_EXCLUDE = utf8MacroTable.ml
+
+include ../../Makefile.defs
+include ../Makefile.common
+
--- /dev/null
+
+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
+
--- /dev/null
+<?xml version="1.0"?>
+
+<!--
+ This file is part of EdiTeX, an editor of mathematical
+ expressions based on TeX syntax.
+
+ Copyright (C) 2002-2003 Luca Padovani <lpadovan@cs.unibo.it>,
+ 2003 Paolo Marinelli <pmarinel@cs.unibo.it>.
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+ For more information, please visit the project's home page
+ http://helm.cs.unibo.it/editex/
+ or send an email to <lpadovan@cs.unibo.it>
+-->
+
+<dictionary name="TeX">
+
+ <include href="dictionary-basic.xml"/>
+
+ <!-- Greek Letters (lower case) -->
+
+ <entry name="alpha" class="i" val="α"/>
+ <entry name="beta" class="i" val="β"/>
+ <entry name="gamma" class="i" val="γ"/>
+ <entry name="delta" class="i" val="δ"/>
+ <entry name="epsilon" class="i" val="ϵ"/>
+ <entry name="varepsilon" class="i" val="ε"/>
+ <entry name="zeta" class="i" val="ζ"/>
+ <entry name="eta" class="i" val="η"/>
+ <entry name="theta" class="i" val="θ"/>
+ <entry name="vartheta" class="i" val="ϑ"/>
+ <entry name="iota" class="i" val="ι"/>
+ <entry name="kappa" class="i" val="κ"/>
+ <entry name="lambda" class="i" val="λ"/>
+ <entry name="mu" class="i" val="μ"/>
+ <entry name="nu" class="i" val="ν"/>
+ <entry name="xi" class="i" val="ξ"/>
+ <entry name="o" class="i" val="ο"/>
+ <entry name="pi" class="i" val="π"/>
+ <entry name="varpi" class="i" val="ϖ"/>
+ <entry name="rho" class="i" val="ρ"/>
+ <entry name="varrho" class="i" val="ϱ"/>
+ <entry name="sigma" class="i" val="σ"/>
+ <entry name="varsigma" class="i" val="ς"/>
+ <entry name="tau" class="i" val="τ"/>
+ <entry name="upsilon" class="i" val="υ"/>
+ <entry name="phi" class="i" val="ϕ"/>
+ <entry name="varphi" class="i" val="φ"/>
+ <entry name="chi" class="i" val="χ"/>
+ <entry name="psi" class="i" val="ψ"/>
+ <entry name="omega" class="i" val="ω"/>
+
+ <!-- Greek Letters (upper case) -->
+
+ <entry name="Gamma" class="i" val="Γ"/>
+ <entry name="Delta" class="i" val="Δ"/>
+ <entry name="Theta" class="i" val="Θ"/>
+ <entry name="Lambda" class="i" val="Λ"/>
+ <entry name="Xi" class="i" val="Ξ"/>
+ <entry name="Pi" class="i" val="Π"/>
+ <entry name="Sigma" class="i" val="Σ"/>
+ <entry name="Upsilon" class="i" val="ϒ"/>
+ <entry name="Phi" class="i" val="Φ"/>
+ <entry name="Psi" class="i" val="Ψ"/>
+ <entry name="Omega" class="i" val="Ω"/>
+
+ <!-- Symbols of Type Ord -->
+
+ <entry name="aleph" class="i" val="ℵ"/>
+ <entry name="hbar" class="i" val="ℏ︀"/>
+ <entry name="imath" class="i" val="ı"/>
+ <entry name="jmath" class="i" val="j︀"/>
+ <entry name="ell" class="i" val="ℓ"/>
+ <entry name="wp" class="i" val="℘"/>
+ <entry name="Re" class="o" val="ℜ"/>
+ <entry name="Im" class="o" val="ℑ"/>
+ <entry name="partial" class="o" val="∂"/>
+ <entry name="infty" class="i" val="∞"/>
+ <entry name="prime" class="o" val="′"/>
+ <entry name="emptyset" class="i" val="∅︀"/>
+ <entry name="nabla" class="o" val="∇"/>
+ <entry name="surd" class="o" val="????"/>
+ <entry name="top" class="i" val="⊤"/>
+ <entry name="bot" class="i" val="⊥"/>
+ <entry name="|" class="o" val="|" delimiter="1"/>
+ <entry name="angle" class="o" val="∠"/>
+ <entry name="triangle" class="o" val="▵"/>
+ <entry name="backslash" class="o" val="\"/>
+ <entry name="forall" class="o" val="∀"/>
+ <entry name="exists" class="o" val="∃"/>
+ <entry name="neg" class="o" val="¬"/>
+ <entry name="lnot" class="o" val="¬"/>
+ <entry name="flat" class="i" val="♭"/>
+ <entry name="natural" class="i" val="♮"/>
+ <entry name="sharp" class="i" val="♯"/>
+ <entry name="clubsuit" class="i" val="♣"/>
+ <entry name="diamondsuit" class="i" val="♢"/>
+ <entry name="heartsuit" class="i" val="♡"/>
+ <entry name="spadesuit" class="i" val="♠"/>
+
+ <!-- Large Operators -->
+
+ <entry name="sum" class="o" val="∑" limits="1"/>
+ <entry name="prod" class="o" val="∏" limits="1"/>
+ <entry name="coprod" class="o" val="∐" limits="1"/>
+ <entry name="int" class="o" val="∫" limits="1"/>
+ <entry name="oint" class="o" val="∮" limits="1"/>
+ <entry name="bigcap" class="o" val="⋂" limits="1"/>
+ <entry name="bigcup" class="o" val="⋃" limits="1"/>
+ <entry name="bigsqcup" class="o" val="⊔" limits="1"/>
+ <entry name="bigvee" class="o" val="⋁" limits="1"/>
+ <entry name="bigwedge" class="o" val="⋀" limits="1"/>
+ <entry name="bigodot" class="o" val="⊙" limits="1"/>
+ <entry name="bigotimes" class="o" val="⊗" limits="1"/>
+ <entry name="bigoplus" class="o" val="⊕" limits="1"/>
+ <entry name="biguplus" class="o" val="⊎" limits="1"/>
+
+ <!-- Binary Operations -->
+
+ <entry name="pm" class="o" val="±"/>
+ <entry name="mp" class="o" val="∓"/>
+ <entry name="setminus" class="o" val="∖"/>
+ <entry name="cdot" class="o" val="ċ"/>
+ <entry name="times" class="o" val="×"/>
+ <entry name="ast" class="o" val="*"/>
+ <entry name="star" class="o" val="⋆"/>
+ <entry name="diamond" class="o" val="⋄"/>
+ <entry name="circ" class="o" val="^"/>
+ <entry name="bullet" class="o" val="•"/>
+ <entry name="div" class="o" val="÷"/>
+ <entry name="cap" class="o" val="∩"/>
+ <entry name="cup" class="o" val="∪"/>
+ <entry name="uplus" class="o" val="⊎"/>
+ <entry name="sqcap" class="o" val="⊓"/>
+ <entry name="sqcup" class="o" val="⊔"/>
+ <entry name="triangleleft" class="o" val="◃"/>
+ <entry name="triangleright" class="o" val="▹"/>
+ <entry name="wr" class="o" val="≀"/>
+ <entry name="bigcirc" class="o" val="◯"/>
+ <entry name="bigtriangleup" class="o" val="△"/>
+ <entry name="bigtriangledown" class="o" val="▽"/>
+ <entry name="vee" class="o" val="∨"/>
+ <entry name="lor" class="o" val="∨"/>
+ <entry name="wedge" class="o" val="∧"/>
+ <entry name="land" class="o" val="∧"/>
+ <entry name="oplus" class="o" val="⊕"/>
+ <entry name="ominus" class="o" val="⊖"/>
+ <entry name="otimes" class="o" val="⊗"/>
+ <entry name="oslash" class="o" val="ø"/>
+ <entry name="odot" class="o" val="⊙"/>
+ <entry name="dagger" class="o" val="†"/>
+ <entry name="ddagger" class="o" val="‡"/>
+ <entry name="amalg" class="o" val="⨿"/>
+
+ <!-- Relations -->
+
+ <entry name="leq" class="o" val="≤"/>
+ <entry name="le" class="o" val="≤"/>
+ <entry name="prec" class="o" val="≺"/>
+ <entry name="preceq" class="o" val="⪯"/>
+ <entry name="ll" class="o" val="≪"/>
+ <entry name="subset" class="o" val="⊂"/>
+ <entry name="subseteq" class="o" val="⊆"/>
+ <entry name="in" class="o" val="∈"/>
+ <entry name="vdash" class="o" val="⊢"/>
+ <entry name="smile" class="o" val="⌣"/>
+ <entry name="frown" class="o" val="⌢"/>
+ <entry name="propto" class="o" val="∝"/>
+ <entry name="geq" class="o" val="≥"/>
+ <entry name="ge" class="o" val="≥"/>
+ <entry name="succ" class="o" val="≻"/>
+ <entry name="succeq" class="o" val="≽"/>
+ <entry name="gg" class="o" val="≫"/>
+ <entry name="supset" class="o" val="⊃"/>
+ <entry name="supseteq" class="o" val="⊇"/>
+ <entry name="sqsupseteq" class="o" val="⊒"/>
+ <entry name="notin" class="o" val="∉"/>
+ <entry name="dashv" class="o" val="⊣"/>
+ <entry name="mid" class="o" val="∣"/>
+ <entry name="parallet" class="o" val="????"/>
+ <entry name="equiv" class="o" val="≡"/>
+ <entry name="sim" class="o" val="∼"/>
+ <entry name="simeq" class="o" val="≃"/>
+ <entry name="asymp" class="o" val="≍"/>
+ <entry name="approx" class="o" val="≈"/>
+ <entry name="cong" class="o" val="≅"/>
+ <entry name="bowtie" class="o" val="⋈"/>
+ <entry name="ni" class="o" val="∋"/>
+ <entry name="owns" class="o" val="∋"/>
+ <entry name="models" class="o" val="⊧"/>
+ <entry name="doteq" class="o" val="≐"/>
+ <entry name="perp" class="o" val="⊥"/>
+
+ <entry name="not" pattern="#1" embellishment="1"/>
+ <entry name="ne" class="o" val="≠"/>
+
+ <!-- Arrows -->
+
+ <entry name="leftarrow" class="o" val="←"/>
+ <entry name="gets" class="o" val="←"/>
+ <entry name="Leftarrow" class="o" val="⇐"/>
+ <entry name="rightarrow" class="o" val="→"/>
+ <entry name="to" class="o" val="→"/>
+ <entry name="Rightarrow" class="o" val="⇒"/>
+ <entry name="leftrightarrow" class="o" val="↔"/>
+ <entry name="Leftrightarrow" class="o" val="⇔"/>
+ <entry name="mapsto" class="o" val="↦"/>
+ <entry name="hookleftarrow" class="o" val="↩"/>
+ <entry name="uparrow" class="o" val="↑"/>
+ <entry name="downarrow" class="o" val="↓"/>
+ <entry name="updownarrow" class="o" val="↕"/>
+ <entry name="nearrow" class="o" val="↗"/>
+ <entry name="nwarrow" class="o" val="↖"/>
+ <entry name="longleftarrow" class="o" val="????;"/>
+ <entry name="Longleftarrow" class="o" val="????"/>
+ <entry name="longrightarrow" class="o" val="????"/>
+ <entry name="Longrightarrow" class="o" val="⇒"/>
+ <entry name="longleftrightarrow" class="o" val="????"/>
+ <entry name="Longleftrightarrow" class="o" val="????"/>
+ <entry name="longmapsto" class="o" val="????"/>
+ <entry name="hookrightarrow" class="o" val="↪"/>
+ <entry name="Uparrow" class="o" val="⇑"/>
+ <entry name="Downarrow" class="o" val="⇓"/>
+ <entry name="searrow" class="o" val="↘"/>
+ <entry name="swarrow" class="o" val="↙"/>
+
+ <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="‖" 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="⌊" delimiter="1"/>
+ <entry name="rfloor" class="o" val="⌋" delimiter="1"/>
+ <entry name="langle" class="o" val="〈" delimiter="1"/>
+ <entry name="rangle" class="o" val="〉" delimiter="1"/>
+ <entry name="lceil" class="o" val="⌈" delimiter="1"/>
+ <entry name="rceil" class="o" val="⌉" 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="…"/>
+ <entry name="ldots" class="i" val="…"/>
+ <entry name="cdots" class="i" val="⋯"/>
+ <entry name="vdots" class="i" val="⋮"/>
+ <entry name="ddots" class="i" val="⋱"/>
+
+ <!-- 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=">"/>
+ <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>
--- /dev/null
+<?xml version="1.0"?>
+
+<entities-table>
+ <entity name="aacute" value="á"/>
+ <entity name="Aacute" value="Á"/>
+ <entity name="abreve" value="ă"/>
+ <entity name="Abreve" value="Ă"/>
+ <entity name="ac" value="⤏"/>
+ <entity name="acd" value="∿"/>
+ <entity name="acE" value="⧛"/>
+ <entity name="acirc" value="â"/>
+ <entity name="Acirc" value="Â"/>
+ <entity name="acute" value="´"/>
+ <entity name="acy" value="а"/>
+ <entity name="Acy" value="А"/>
+ <entity name="aelig" value="æ"/>
+ <entity name="AElig" value="Æ"/>
+ <entity name="af" value="⁡"/>
+ <entity name="afr" value="𝔞"/>
+ <entity name="Afr" value="𝔄"/>
+ <entity name="agrave" value="à"/>
+ <entity name="Agrave" value="À"/>
+ <entity name="aleph" value="ℵ"/>
+ <entity name="alpha" value="α"/>
+ <entity name="amacr" value="ā"/>
+ <entity name="Amacr" value="Ā"/>
+ <entity name="amalg" value="⨿"/>
+ <entity name="amp" value="&"/>
+ <entity name="and" value="∧"/>
+ <entity name="And" value="⩓"/>
+ <entity name="andand" value="⩕"/>
+ <entity name="andd" value="⩜"/>
+ <entity name="andslope" value="⩘"/>
+ <entity name="andv" value="⩚"/>
+ <entity name="ang" value="∠"/>
+ <entity name="ange" value="⦤"/>
+ <entity name="angle" value="∠"/>
+ <entity name="angmsd" value="∡"/>
+ <entity name="angmsdaa" value="⦨"/>
+ <entity name="angmsdab" value="⦩"/>
+ <entity name="angmsdac" value="⦪"/>
+ <entity name="angmsdad" value="⦫"/>
+ <entity name="angmsdae" value="⦬"/>
+ <entity name="angmsdaf" value="⦭"/>
+ <entity name="angmsdag" value="⦮"/>
+ <entity name="angmsdah" value="⦯"/>
+ <entity name="angrt" value="∟"/>
+ <entity name="angrtvb" value="⦝︀"/>
+ <entity name="angrtvbd" value="⦝"/>
+ <entity name="angsph" value="∢"/>
+ <entity name="angst" value="Å"/>
+ <entity name="angzarr" value="⍼"/>
+ <entity name="aogon" value="ą"/>
+ <entity name="Aogon" value="Ą"/>
+ <entity name="aopf" value="𝕒"/>
+ <entity name="Aopf" value="𝔸"/>
+ <entity name="ap" value="≈"/>
+ <entity name="apacir" value="⩯"/>
+ <entity name="ape" value="≊"/>
+ <entity name="apE" value="≊"/>
+ <entity name="apid" value="≋"/>
+ <entity name="apos" value="'"/>
+ <entity name="ApplyFunction" value="⁡"/>
+ <entity name="approx" value="≈"/>
+ <entity name="approxeq" value="≊"/>
+ <entity name="aring" value="å"/>
+ <entity name="Aring" value="Å"/>
+ <entity name="ascr" value="𝒶"/>
+ <entity name="Ascr" value="𝒜"/>
+ <entity name="Assign" value="≔"/>
+ <entity name="ast" value="*"/>
+ <entity name="asymp" value="≍"/>
+ <entity name="atilde" value="ã"/>
+ <entity name="Atilde" value="Ã"/>
+ <entity name="auml" value="ä"/>
+ <entity name="Auml" value="Ä"/>
+ <entity name="awconint" value="∳"/>
+ <entity name="awint" value="⨑"/>
+ <entity name="backcong" value="≌"/>
+ <entity name="backepsilon" value="϶"/>
+ <entity name="backprime" value="‵"/>
+ <entity name="backsim" value="∽"/>
+ <entity name="backsimeq" value="⋍"/>
+ <entity name="Backslash" value="∖"/>
+ <entity name="Barv" value="⫧"/>
+ <entity name="barvee" value="⊽"/>
+ <entity name="barwed" value="⊼"/>
+ <entity name="Barwed" value="⌆"/>
+ <entity name="barwedge" value="⊼"/>
+ <entity name="bbrk" value="⎵"/>
+ <entity name="bcong" value="≌"/>
+ <entity name="bcy" value="б"/>
+ <entity name="Bcy" value="Б"/>
+ <entity name="becaus" value="∵"/>
+ <entity name="because" value="∵"/>
+ <entity name="Because" value="∵"/>
+ <entity name="bemptyv" value="⦰"/>
+ <entity name="bepsi" value="϶"/>
+ <entity name="bernou" value="ℬ"/>
+ <entity name="Bernoullis" value="ℬ"/>
+ <entity name="beta" value="β"/>
+ <entity name="beth" value="ℶ"/>
+ <entity name="between" value="≬"/>
+ <entity name="bfr" value="𝔟"/>
+ <entity name="Bfr" value="𝔅"/>
+ <entity name="bigcap" value="⋂"/>
+ <entity name="bigcirc" value="◯"/>
+ <entity name="bigcup" value="⋃"/>
+ <entity name="bigodot" value="⊙"/>
+ <entity name="bigoplus" value="⊕"/>
+ <entity name="bigotimes" value="⊗"/>
+ <entity name="bigsqcup" value="⊔"/>
+ <entity name="bigstar" value="★"/>
+ <entity name="bigtriangledown" value="▽"/>
+ <entity name="bigtriangleup" value="△"/>
+ <entity name="biguplus" value="⊎"/>
+ <entity name="bigvee" value="⋁"/>
+ <entity name="bigwedge" value="⋀"/>
+ <entity name="bkarow" value="⤍"/>
+ <entity name="blacklozenge" value="⧫"/>
+ <entity name="blacksquare" value="▪"/>
+ <entity name="blacktriangle" value="▴"/>
+ <entity name="blacktriangledown" value="▾"/>
+ <entity name="blacktriangleleft" value="◂"/>
+ <entity name="blacktriangleright" value="▸"/>
+ <entity name="blank" value="␣"/>
+ <entity name="blk12" value="▒"/>
+ <entity name="blk14" value="░"/>
+ <entity name="blk34" value="▓"/>
+ <entity name="block" value="█"/>
+ <entity name="bne" value="=⃥"/>
+ <entity name="bnequiv" value="≡⃥"/>
+ <entity name="bnot" value="⌐"/>
+ <entity name="bNot" value="⫭"/>
+ <entity name="bopf" value="𝕓"/>
+ <entity name="Bopf" value="𝔹"/>
+ <entity name="bot" value="⊥"/>
+ <entity name="bottom" value="⊥"/>
+ <entity name="bowtie" value="⋈"/>
+ <entity name="boxbox" value="⧉"/>
+ <entity name="boxdl" value="┐"/>
+ <entity name="boxdL" value="╕"/>
+ <entity name="boxDl" value="╖"/>
+ <entity name="boxDL" value="╗"/>
+ <entity name="boxdr" value="┌"/>
+ <entity name="boxdR" value="╒"/>
+ <entity name="boxDr" value="╓"/>
+ <entity name="boxDR" value="╔"/>
+ <entity name="boxh" value="─"/>
+ <entity name="boxH" value="═"/>
+ <entity name="boxhd" value="┬"/>
+ <entity name="boxhD" value="╥"/>
+ <entity name="boxHd" value="╤"/>
+ <entity name="boxHD" value="╦"/>
+ <entity name="boxhu" value="┴"/>
+ <entity name="boxhU" value="╨"/>
+ <entity name="boxHu" value="╧"/>
+ <entity name="boxHU" value="╩"/>
+ <entity name="boxminus" value="⊟"/>
+ <entity name="boxplus" value="⊞"/>
+ <entity name="boxtimes" value="⊠"/>
+ <entity name="boxul" value="┘"/>
+ <entity name="boxuL" value="╛"/>
+ <entity name="boxUl" value="╜"/>
+ <entity name="boxUL" value="╝"/>
+ <entity name="boxur" value="└"/>
+ <entity name="boxuR" value="╘"/>
+ <entity name="boxUr" value="╙"/>
+ <entity name="boxUR" value="╚"/>
+ <entity name="boxv" value="│"/>
+ <entity name="boxV" value="║"/>
+ <entity name="boxvh" value="┼"/>
+ <entity name="boxvH" value="╪"/>
+ <entity name="boxVh" value="╫"/>
+ <entity name="boxVH" value="╬"/>
+ <entity name="boxvl" value="┤"/>
+ <entity name="boxvL" value="╡"/>
+ <entity name="boxVl" value="╢"/>
+ <entity name="boxVL" value="╣"/>
+ <entity name="boxvr" value="├"/>
+ <entity name="boxvR" value="╞"/>
+ <entity name="boxVr" value="╟"/>
+ <entity name="boxVR" value="╠"/>
+ <entity name="bprime" value="‵"/>
+ <entity name="breve" value="˘"/>
+ <entity name="Breve" value="˘"/>
+ <entity name="brvbar" value="¦"/>
+ <entity name="bscr" value="𝒷"/>
+ <entity name="Bscr" value="ℬ"/>
+ <entity name="bsemi" value="⁏"/>
+ <entity name="bsim" value="∽"/>
+ <entity name="bsime" value="⋍"/>
+ <entity name="bsol" value="\"/>
+ <entity name="bsolb" value="⧅"/>
+ <entity name="bsolhsub" value="\⊂"/>
+ <entity name="bull" value="•"/>
+ <entity name="bullet" value="•"/>
+ <entity name="bump" value="≎"/>
+ <entity name="bumpe" value="≏"/>
+ <entity name="bumpE" value="⪮"/>
+ <entity name="bumpeq" value="≏"/>
+ <entity name="Bumpeq" value="≎"/>
+ <entity name="cacute" value="ć"/>
+ <entity name="Cacute" value="Ć"/>
+ <entity name="cap" value="∩"/>
+ <entity name="Cap" value="⋒"/>
+ <entity name="capand" value="⩄"/>
+ <entity name="capbrcup" value="⩉"/>
+ <entity name="capcap" value="⩋"/>
+ <entity name="capcup" value="⩇"/>
+ <entity name="capdot" value="⩀"/>
+ <entity name="CapitalDifferentialD" value="ⅅ"/>
+ <entity name="caps" value="∩︀"/>
+ <entity name="caret" value="⁁"/>
+ <entity name="caron" value="ˇ"/>
+ <entity name="Cayleys" value="ℭ"/>
+ <entity name="ccaps" value="⩍"/>
+ <entity name="ccaron" value="č"/>
+ <entity name="Ccaron" value="Č"/>
+ <entity name="ccedil" value="ç"/>
+ <entity name="Ccedil" value="Ç"/>
+ <entity name="ccirc" value="ĉ"/>
+ <entity name="Ccirc" value="Ĉ"/>
+ <entity name="Cconint" value="∰"/>
+ <entity name="ccups" value="⩌"/>
+ <entity name="ccupssm" value="⩐"/>
+ <entity name="cdot" value="ċ"/>
+ <entity name="Cdot" value="Ċ"/>
+ <entity name="cedil" value="¸"/>
+ <entity name="Cedilla" value="¸"/>
+ <entity name="cemptyv" value="⦲"/>
+ <entity name="cent" value="¢"/>
+ <entity name="centerdot" value="·"/>
+ <entity name="CenterDot" value="·"/>
+ <entity name="cfr" value="𝔠"/>
+ <entity name="Cfr" value="ℭ"/>
+ <entity name="chcy" value="ч"/>
+ <entity name="CHcy" value="Ч"/>
+ <entity name="check" value="✓"/>
+ <entity name="checkmark" value="✓"/>
+ <entity name="chi" value="χ"/>
+ <entity name="cir" value="○"/>
+ <entity name="circ" value="^"/>
+ <entity name="circeq" value="≗"/>
+ <entity name="circlearrowleft" value="↺"/>
+ <entity name="circlearrowright" value="↻"/>
+ <entity name="circledast" value="⊛"/>
+ <entity name="circledcirc" value="⊚"/>
+ <entity name="circleddash" value="⊝"/>
+ <entity name="CircleDot" value="⊙"/>
+ <entity name="circledR" value="®"/>
+ <entity name="circledS" value="Ⓢ"/>
+ <entity name="CircleMinus" value="⊖"/>
+ <entity name="CirclePlus" value="⊕"/>
+ <entity name="CircleTimes" value="⊗"/>
+ <entity name="cire" value="≗"/>
+ <entity name="cirE" value="⧃"/>
+ <entity name="cirfnint" value="⨐"/>
+ <entity name="cirmid" value="⫯"/>
+ <entity name="cirscir" value="⧂"/>
+ <entity name="ClockwiseContourIntegral" value="∲"/>
+ <entity name="CloseCurlyDoubleQuote" value="”"/>
+ <entity name="CloseCurlyQuote" value="’"/>
+ <entity name="clubs" value="♣"/>
+ <entity name="clubsuit" value="♣"/>
+ <entity name="colon" value=":"/>
+ <entity name="Colon" value="∷"/>
+ <entity name="colone" value="≔"/>
+ <entity name="Colone" value="⩴"/>
+ <entity name="coloneq" value="≔"/>
+ <entity name="comma" value=","/>
+ <entity name="commat" value="@"/>
+ <entity name="comp" value="∁"/>
+ <entity name="compfn" value="∘"/>
+ <entity name="complement" value="∁"/>
+ <entity name="complexes" value="ℂ"/>
+ <entity name="cong" value="≅"/>
+ <entity name="congdot" value="⩭"/>
+ <entity name="Congruent" value="≡"/>
+ <entity name="conint" value="∮"/>
+ <entity name="Conint" value="∯"/>
+ <entity name="ContourIntegral" value="∮"/>
+ <entity name="copf" value="𝕔"/>
+ <entity name="Copf" value="ℂ"/>
+ <entity name="coprod" value="∐"/>
+ <entity name="Coproduct" value="∐"/>
+ <entity name="copy" value="©"/>
+ <entity name="copysr" value="℗"/>
+ <entity name="CounterClockwiseContourIntegral" value="∳"/>
+ <entity name="cross" value="✗"/>
+ <entity name="Cross" value="⨯"/>
+ <entity name="cscr" value="𝒸"/>
+ <entity name="Cscr" value="𝒞"/>
+ <entity name="csub" value="⫏"/>
+ <entity name="csube" value="⫑"/>
+ <entity name="csup" value="⫐"/>
+ <entity name="csupe" value="⫒"/>
+ <entity name="ctdot" value="⋯"/>
+ <entity name="cudarrl" value="⤸"/>
+ <entity name="cudarrr" value="⤵"/>
+ <entity name="cuepr" value="⋞"/>
+ <entity name="cuesc" value="⋟"/>
+ <entity name="cularr" value="↶"/>
+ <entity name="cularrp" value="⤽"/>
+ <entity name="cup" value="∪"/>
+ <entity name="Cup" value="⋓"/>
+ <entity name="cupbrcap" value="⩈"/>
+ <entity name="cupcap" value="⩆"/>
+ <entity name="CupCap" value="≍"/>
+ <entity name="cupcup" value="⩊"/>
+ <entity name="cupdot" value="⊍"/>
+ <entity name="cupor" value="⩅"/>
+ <entity name="cups" value="∪︀"/>
+ <entity name="curarr" value="↷"/>
+ <entity name="curarrm" value="⤼"/>
+ <entity name="curlyeqprec" value="⋞"/>
+ <entity name="curlyeqsucc" value="⋟"/>
+ <entity name="curlyvee" value="⋎"/>
+ <entity name="curlywedge" value="⋏"/>
+ <entity name="curren" value="¤"/>
+ <entity name="curvearrowleft" value="↶"/>
+ <entity name="curvearrowright" value="↷"/>
+ <entity name="cuvee" value="⋎"/>
+ <entity name="cuwed" value="⋏"/>
+ <entity name="cwconint" value="∲"/>
+ <entity name="cwint" value="∱"/>
+ <entity name="cylcty" value="⌭"/>
+ <entity name="dagger" value="†"/>
+ <entity name="dagger" value="†"/>
+ <entity name="Dagger" value="‡"/>
+ <entity name="Dagger" value="‡"/>
+ <entity name="daleth" value="ℸ"/>
+ <entity name="darr" value="↓"/>
+ <entity name="dArr" value="⇓"/>
+ <entity name="Darr" value="↡"/>
+ <entity name="dash" value="‐"/>
+ <entity name="dashv" value="⊣"/>
+ <entity name="Dashv" value="⫤"/>
+ <entity name="dbkarow" value="⤏"/>
+ <entity name="dblac" value="˝"/>
+ <entity name="dcaron" value="ď"/>
+ <entity name="Dcaron" value="Ď"/>
+ <entity name="dcy" value="д"/>
+ <entity name="Dcy" value="Д"/>
+ <entity name="dd" value="ⅆ"/>
+ <entity name="DD" value="ⅅ"/>
+ <entity name="ddagger" value="‡"/>
+ <entity name="ddarr" value="⇊"/>
+ <entity name="DDotrahd" value="⤑"/>
+ <entity name="ddotseq" value="⩷"/>
+ <entity name="deg" value="°"/>
+ <entity name="Del" value="∇"/>
+ <entity name="delta" value="δ"/>
+ <entity name="Delta" value="Δ"/>
+ <entity name="demptyv" value="⦱"/>
+ <entity name="dfisht" value="⥿"/>
+ <entity name="dfr" value="𝔡"/>
+ <entity name="Dfr" value="𝔇"/>
+ <entity name="dHar" value="⥥"/>
+ <entity name="dharl" value="⇃"/>
+ <entity name="dharr" value="⇂"/>
+ <entity name="DiacriticalAcute" value="´"/>
+ <entity name="DiacriticalDot" value="˙"/>
+ <entity name="DiacriticalDoubleAcute" value="˝"/>
+ <entity name="DiacriticalGrave" value="`"/>
+ <entity name="DiacriticalTilde" value="˜"/>
+ <entity name="diam" value="⋄"/>
+ <entity name="diamond" value="⋄"/>
+ <entity name="Diamond" value="⋄"/>
+ <entity name="diamondsuit" value="♦"/>
+ <entity name="diams" value="♦"/>
+ <entity name="die" value="¨"/>
+ <entity name="DifferentialD" value="ⅆ"/>
+ <entity name="digamma" value="Ϝ"/>
+ <entity name="disin" value="⋲"/>
+ <entity name="div" value="÷"/>
+ <entity name="divide" value="÷"/>
+ <entity name="divideontimes" value="⋇"/>
+ <entity name="divonx" value="⋇"/>
+ <entity name="djcy" value="ђ"/>
+ <entity name="DJcy" value="Ђ"/>
+ <entity name="dlcorn" value="⌞"/>
+ <entity name="dlcrop" value="⌍"/>
+ <entity name="dollar" value="$"/>
+ <entity name="dopf" value="𝕕"/>
+ <entity name="Dopf" value="𝔻"/>
+ <entity name="dot" value="˙"/>
+ <entity name="Dot" value="¨"/>
+ <entity name="DotDot" value="⃜"/>
+ <entity name="doteq" value="≐"/>
+ <entity name="doteqdot" value="≑"/>
+ <entity name="DotEqual" value="≐"/>
+ <entity name="dotminus" value="∸"/>
+ <entity name="dotplus" value="∔"/>
+ <entity name="dotsquare" value="⊡"/>
+ <entity name="doublebarwedge" value="⌆"/>
+ <entity name="DoubleContourIntegral" value="∯"/>
+ <entity name="DoubleDot" value="¨"/>
+ <entity name="DoubleDownArrow" value="⇓"/>
+ <entity name="DoubleLeftArrow" value="⇐"/>
+ <entity name="DoubleLeftRightArrow" value="⇔"/>
+ <entity name="DoubleLeftTee" value="⫤"/>
+ <entity name="DoubleLongLeftArrow" value=""/>
+ <entity name="DoubleLongLeftRightArrow" value=""/>
+ <entity name="DoubleLongRightArrow" value=""/>
+ <entity name="DoubleRightArrow" value="⇒"/>
+ <entity name="DoubleRightTee" value="⊨"/>
+ <entity name="DoubleUpArrow" value="⇑"/>
+ <entity name="DoubleUpDownArrow" value="⇕"/>
+ <entity name="DoubleVerticalBar" value="∥"/>
+ <entity name="downarrow" value="↓"/>
+ <entity name="Downarrow" value="⇓"/>
+ <entity name="DownArrow" value="↓"/>
+ <entity name="DownArrowBar" value="⤓"/>
+ <entity name="DownArrowUpArrow" value="⇵"/>
+ <entity name="DownBreve" value="̑"/>
+ <entity name="downdownarrows" value="⇊"/>
+ <entity name="downharpoonleft" value="⇃"/>
+ <entity name="downharpoonright" value="⇂"/>
+ <entity name="DownLeftRightVector" value="⥐"/>
+ <entity name="DownLeftTeeVector" value="⥞"/>
+ <entity name="DownLeftVector" value="↽"/>
+ <entity name="DownLeftVectorBar" value="⥖"/>
+ <entity name="DownRightTeeVector" value="⥟"/>
+ <entity name="DownRightVector" value="⇁"/>
+ <entity name="DownRightVectorBar" value="⥗"/>
+ <entity name="DownTee" value="⊤"/>
+ <entity name="DownTeeArrow" value="↧"/>
+ <entity name="drbkarow" value="⤐"/>
+ <entity name="drcorn" value="⌟"/>
+ <entity name="drcrop" value="⌌"/>
+ <entity name="dscr" value="𝒹"/>
+ <entity name="Dscr" value="𝒟"/>
+ <entity name="dscy" value="ѕ"/>
+ <entity name="DScy" value="Ѕ"/>
+ <entity name="dsol" value="⧶"/>
+ <entity name="dstrok" value="đ"/>
+ <entity name="Dstrok" value="Đ"/>
+ <entity name="dtdot" value="⋱"/>
+ <entity name="dtri" value="▿"/>
+ <entity name="dtrif" value="▾"/>
+ <entity name="duarr" value="⇵"/>
+ <entity name="duhar" value="⥯"/>
+ <entity name="dwangle" value="⦦"/>
+ <entity name="dzcy" value="џ"/>
+ <entity name="DZcy" value="Џ"/>
+ <entity name="dzigrarr" value=""/>
+ <entity name="eacute" value="é"/>
+ <entity name="Eacute" value="É"/>
+ <entity name="easter" value="≛"/>
+ <entity name="ecaron" value="ě"/>
+ <entity name="Ecaron" value="Ě"/>
+ <entity name="ecir" value="≖"/>
+ <entity name="ecirc" value="ê"/>
+ <entity name="Ecirc" value="Ê"/>
+ <entity name="ecolon" value="≕"/>
+ <entity name="ecy" value="э"/>
+ <entity name="Ecy" value="Э"/>
+ <entity name="eDDot" value="⩷"/>
+ <entity name="edot" value="ė"/>
+ <entity name="eDot" value="≑"/>
+ <entity name="Edot" value="Ė"/>
+ <entity name="ee" value="ⅇ"/>
+ <entity name="efDot" value="≒"/>
+ <entity name="efr" value="𝔢"/>
+ <entity name="Efr" value="𝔈"/>
+ <entity name="eg" value="⪚"/>
+ <entity name="egrave" value="è"/>
+ <entity name="Egrave" value="È"/>
+ <entity name="egs" value="⋝"/>
+ <entity name="egsdot" value="⪘"/>
+ <entity name="el" value="⪙"/>
+ <entity name="Element" value="∈"/>
+ <entity name="ell" value="ℓ"/>
+ <entity name="els" value="⋜"/>
+ <entity name="elsdot" value="⪗"/>
+ <entity name="emacr" value="ē"/>
+ <entity name="Emacr" value="Ē"/>
+ <entity name="empty" value="∅︀"/>
+ <entity name="emptyset" value="∅︀"/>
+ <entity name="EmptySmallSquare" value="◽"/>
+ <entity name="emptyv" value="∅"/>
+ <entity name="EmptyVerySmallSquare" value=""/>
+ <entity name="emsp" value=" "/>
+ <entity name="emsp13" value=" "/>
+ <entity name="emsp14" value=" "/>
+ <entity name="eng" value="ŋ"/>
+ <entity name="ENG" value="Ŋ"/>
+ <entity name="ensp" value=" "/>
+ <entity name="eogon" value="ę"/>
+ <entity name="Eogon" value="Ę"/>
+ <entity name="eopf" value="𝕖"/>
+ <entity name="Eopf" value="𝔼"/>
+ <entity name="epar" value="⋕"/>
+ <entity name="eparsl" value="⧣"/>
+ <entity name="eplus" value="⩱"/>
+ <entity name="epsi" value="ε"/>
+ <entity name="epsiv" value="ɛ"/>
+ <entity name="eqcirc" value="≖"/>
+ <entity name="eqcolon" value="≕"/>
+ <entity name="eqsim" value="≂"/>
+ <entity name="eqslantgtr" value="⋝"/>
+ <entity name="eqslantless" value="⋜"/>
+ <entity name="Equal" value="⩵"/>
+ <entity name="equals" value="="/>
+ <entity name="EqualTilde" value="≂"/>
+ <entity name="equest" value="≟"/>
+ <entity name="Equilibrium" value="⇌"/>
+ <entity name="equiv" value="≡"/>
+ <entity name="equivDD" value="⩸"/>
+ <entity name="eqvparsl" value="⧥"/>
+ <entity name="erarr" value="⥱"/>
+ <entity name="erDot" value="≓"/>
+ <entity name="escr" value="ℯ"/>
+ <entity name="Escr" value="ℰ"/>
+ <entity name="esdot" value="≐"/>
+ <entity name="esim" value="≂"/>
+ <entity name="Esim" value="⩳"/>
+ <entity name="eta" value="η"/>
+ <entity name="eth" value="ð"/>
+ <entity name="ETH" value="Ð"/>
+ <entity name="euml" value="ë"/>
+ <entity name="Euml" value="Ë"/>
+ <entity name="excl" value="!"/>
+ <entity name="exist" value="∃"/>
+ <entity name="Exists" value="∃"/>
+ <entity name="expectation" value="ℰ"/>
+ <entity name="exponentiale" value="ⅇ"/>
+ <entity name="ExponentialE" value="ⅇ"/>
+ <entity name="fallingdotseq" value="≒"/>
+ <entity name="fcy" value="ф"/>
+ <entity name="Fcy" value="Ф"/>
+ <entity name="female" value="♀"/>
+ <entity name="ffilig" value="ffi"/>
+ <entity name="fflig" value="ff"/>
+ <entity name="ffllig" value="ffl"/>
+ <entity name="ffr" value="𝔣"/>
+ <entity name="Ffr" value="𝔉"/>
+ <entity name="filig" value="fi"/>
+ <entity name="FilledSmallSquare" value="◾"/>
+ <entity name="FilledVerySmallSquare" value=""/>
+ <entity name="flat" value="♭"/>
+ <entity name="fllig" value="fl"/>
+ <entity name="fnof" value="ƒ"/>
+ <entity name="fopf" value="𝕗"/>
+ <entity name="Fopf" value="𝔽"/>
+ <entity name="forall" value="∀"/>
+ <entity name="ForAll" value="∀"/>
+ <entity name="fork" value="⋔"/>
+ <entity name="forkv" value="⫙"/>
+ <entity name="Fouriertrf" value="ℱ"/>
+ <entity name="fpartint" value="⨍"/>
+ <entity name="frac12" value="½"/>
+ <entity name="frac13" value="⅓"/>
+ <entity name="frac14" value="¼"/>
+ <entity name="frac15" value="⅕"/>
+ <entity name="frac16" value="⅙"/>
+ <entity name="frac18" value="⅛"/>
+ <entity name="frac23" value="⅔"/>
+ <entity name="frac25" value="⅖"/>
+ <entity name="frac34" value="¾"/>
+ <entity name="frac35" value="⅗"/>
+ <entity name="frac38" value="⅜"/>
+ <entity name="frac45" value="⅘"/>
+ <entity name="frac56" value="⅚"/>
+ <entity name="frac58" value="⅝"/>
+ <entity name="frac78" value="⅞"/>
+ <entity name="frown" value="⌢"/>
+ <entity name="fscr" value="𝒻"/>
+ <entity name="Fscr" value="ℱ"/>
+ <entity name="gacute" value="ǵ"/>
+ <entity name="gamma" value="γ"/>
+ <entity name="Gamma" value="Γ"/>
+ <entity name="gammad" value="Ϝ"/>
+ <entity name="Gammad" value="Ϝ"/>
+ <entity name="gap" value="≳"/>
+ <entity name="gbreve" value="ğ"/>
+ <entity name="Gbreve" value="Ğ"/>
+ <entity name="Gcedil" value="Ģ"/>
+ <entity name="gcirc" value="ĝ"/>
+ <entity name="Gcirc" value="Ĝ"/>
+ <entity name="gcy" value="г"/>
+ <entity name="Gcy" value="Г"/>
+ <entity name="gdot" value="ġ"/>
+ <entity name="Gdot" value="Ġ"/>
+ <entity name="ge" value="≥"/>
+ <entity name="gE" value="≧"/>
+ <entity name="gel" value="⋛"/>
+ <entity name="gEl" value="⋛"/>
+ <entity name="geq" value="≥"/>
+ <entity name="geqq" value="≧"/>
+ <entity name="geqslant" value="⩾"/>
+ <entity name="ges" value="⩾"/>
+ <entity name="gescc" value="⪩"/>
+ <entity name="gesdot" value="⪀"/>
+ <entity name="gesdoto" value="⪂"/>
+ <entity name="gesdotol" value="⪄"/>
+ <entity name="gesl" value="⋛︀"/>
+ <entity name="gesles" value="⪔"/>
+ <entity name="gfr" value="𝔤"/>
+ <entity name="Gfr" value="𝔊"/>
+ <entity name="gg" value="≫"/>
+ <entity name="Gg" value="⋙"/>
+ <entity name="ggg" value="⋙"/>
+ <entity name="gimel" value="ℷ"/>
+ <entity name="gjcy" value="ѓ"/>
+ <entity name="GJcy" value="Ѓ"/>
+ <entity name="gl" value="≷"/>
+ <entity name="gla" value="⪥"/>
+ <entity name="glE" value="⪒"/>
+ <entity name="glj" value="⪤"/>
+ <entity name="gnap" value="⪊"/>
+ <entity name="gnapprox" value="⪊"/>
+ <entity name="gne" value="≩"/>
+ <entity name="gnE" value="≩"/>
+ <entity name="gneq" value="≩"/>
+ <entity name="gneqq" value="≩"/>
+ <entity name="gnsim" value="⋧"/>
+ <entity name="gopf" value="𝕘"/>
+ <entity name="Gopf" value="𝔾"/>
+ <entity name="grave" value="`"/>
+ <entity name="GreaterEqual" value="≥"/>
+ <entity name="GreaterEqualLess" value="⋛"/>
+ <entity name="GreaterFullEqual" value="≧"/>
+ <entity name="GreaterGreater" value="⪢"/>
+ <entity name="GreaterLess" value="≷"/>
+ <entity name="GreaterSlantEqual" value="⩾"/>
+ <entity name="GreaterTilde" value="≳"/>
+ <entity name="gscr" value="ℊ"/>
+ <entity name="Gscr" value="𝒢"/>
+ <entity name="gsim" value="≳"/>
+ <entity name="gsime" value="⪎"/>
+ <entity name="gsiml" value="⪐"/>
+ <entity name="gt" value=">"/>
+ <entity name="Gt" value="≫"/>
+ <entity name="gtcc" value="⪧"/>
+ <entity name="gtcir" value="⩺"/>
+ <entity name="gtdot" value="⋗"/>
+ <entity name="gtlPar" value="⦕"/>
+ <entity name="gtquest" value="⩼"/>
+ <entity name="gtrapprox" value="≳"/>
+ <entity name="gtrarr" value="⥸"/>
+ <entity name="gtrdot" value="⋗"/>
+ <entity name="gtreqless" value="⋛"/>
+ <entity name="gtreqqless" value="⋛"/>
+ <entity name="gtrless" value="≷"/>
+ <entity name="gtrsim" value="≳"/>
+ <entity name="gvertneqq" value="≩︀"/>
+ <entity name="gvnE" value="≩︀"/>
+ <entity name="Hacek" value="ˇ"/>
+ <entity name="hairsp" value=" "/>
+ <entity name="half" value="½"/>
+ <entity name="hamilt" value="ℋ"/>
+ <entity name="hardcy" value="ъ"/>
+ <entity name="HARDcy" value="Ъ"/>
+ <entity name="harr" value="↔"/>
+ <entity name="hArr" value="⇔"/>
+ <entity name="harrcir" value="⥈"/>
+ <entity name="harrw" value="↭"/>
+ <entity name="Hat" value="̂"/>
+ <entity name="hbar" value="ℏ︀"/>
+ <entity name="hcirc" value="ĥ"/>
+ <entity name="Hcirc" value="Ĥ"/>
+ <entity name="heartsuit" value="♡"/>
+ <entity name="hellip" value="…"/>
+ <entity name="hercon" value="⊹"/>
+ <entity name="hfr" value="𝔥"/>
+ <entity name="Hfr" value="ℌ"/>
+ <entity name="HilbertSpace" value="ℋ"/>
+ <entity name="hksearow" value="⤥"/>
+ <entity name="hkswarow" value="⤦"/>
+ <entity name="hoarr" value="⇿"/>
+ <entity name="homtht" value="∻"/>
+ <entity name="hookleftarrow" value="↩"/>
+ <entity name="hookrightarrow" value="↪"/>
+ <entity name="hopf" value="𝕙"/>
+ <entity name="Hopf" value="ℍ"/>
+ <entity name="horbar" value="―"/>
+ <entity name="HorizontalLine" value="─"/>
+ <entity name="hscr" value="𝒽"/>
+ <entity name="Hscr" value="ℋ"/>
+ <entity name="hslash" value="ℏ"/>
+ <entity name="hstrok" value="ħ"/>
+ <entity name="Hstrok" value="Ħ"/>
+ <entity name="HumpDownHump" value="≎"/>
+ <entity name="HumpEqual" value="≏"/>
+ <entity name="hybull" value="⁃"/>
+ <entity name="hyphen" value="‐"/>
+ <entity name="iacute" value="í"/>
+ <entity name="Iacute" value="Í"/>
+ <entity name="ic" value="​"/>
+ <entity name="icirc" value="î"/>
+ <entity name="Icirc" value="Î"/>
+ <entity name="icy" value="и"/>
+ <entity name="Icy" value="И"/>
+ <entity name="Idot" value="İ"/>
+ <entity name="iecy" value="е"/>
+ <entity name="IEcy" value="Е"/>
+ <entity name="iexcl" value="¡"/>
+ <entity name="iff" value="⇔"/>
+ <entity name="ifr" value="𝔦"/>
+ <entity name="Ifr" value="ℑ"/>
+ <entity name="igrave" value="ì"/>
+ <entity name="Igrave" value="Ì"/>
+ <entity name="ii" value="ⅈ"/>
+ <entity name="iiiint" value="⨌"/>
+ <entity name="iiint" value="∭"/>
+ <entity name="iinfin" value="⧜"/>
+ <entity name="iiota" value="℩"/>
+ <entity name="ijlig" value="ij"/>
+ <entity name="IJlig" value="IJ"/>
+ <entity name="Im" value="ℑ"/>
+ <entity name="imacr" value="ī"/>
+ <entity name="Imacr" value="Ī"/>
+ <entity name="image" value="ℑ"/>
+ <entity name="ImaginaryI" value="ⅈ"/>
+ <entity name="imagline" value="ℐ"/>
+ <entity name="imagpart" value="ℑ"/>
+ <entity name="imath" value="ı"/>
+ <entity name="imof" value="⊷"/>
+ <entity name="imped" value="𝕃"/>
+ <entity name="Implies" value="⇒"/>
+ <entity name="in" value="∈"/>
+ <entity name="incare" value="℅"/>
+ <entity name="infin" value="∞"/>
+ <entity name="inodot" value="ı"/>
+ <entity name="int" value="∫"/>
+ <entity name="Int" value="∬"/>
+ <entity name="intcal" value="⊺"/>
+ <entity name="integers" value="ℤ"/>
+ <entity name="Integral" value="∫"/>
+ <entity name="intercal" value="⊺"/>
+ <entity name="Intersection" value="⋂"/>
+ <entity name="intlarhk" value="⨗"/>
+ <entity name="intprod" value="⨼"/>
+ <entity name="InvisibleComma" value="​"/>
+ <entity name="InvisibleTimes" value="⁢"/>
+ <entity name="iocy" value="ё"/>
+ <entity name="IOcy" value="Ё"/>
+ <entity name="iogon" value="į"/>
+ <entity name="Iogon" value="Į"/>
+ <entity name="iopf" value="𝕚"/>
+ <entity name="Iopf" value="𝕀"/>
+ <entity name="iota" value="ι"/>
+ <entity name="iprod" value="⨼"/>
+ <entity name="iquest" value="¿"/>
+ <entity name="iscr" value="𝒾"/>
+ <entity name="Iscr" value="ℐ"/>
+ <entity name="isin" value="∈"/>
+ <entity name="isindot" value="⋵"/>
+ <entity name="isinE" value="⋹"/>
+ <entity name="isins" value="⋴"/>
+ <entity name="isinsv" value="⋳"/>
+ <entity name="isinv" value="∈"/>
+ <entity name="it" value="⁢"/>
+ <entity name="itilde" value="ĩ"/>
+ <entity name="Itilde" value="Ĩ"/>
+ <entity name="iukcy" value="і"/>
+ <entity name="Iukcy" value="І"/>
+ <entity name="iuml" value="ï"/>
+ <entity name="Iuml" value="Ï"/>
+ <entity name="jcirc" value="ĵ"/>
+ <entity name="Jcirc" value="Ĵ"/>
+ <entity name="jcy" value="й"/>
+ <entity name="Jcy" value="Й"/>
+ <entity name="jfr" value="𝔧"/>
+ <entity name="Jfr" value="𝔍"/>
+ <entity name="jmath" value="j︀"/>
+ <entity name="jopf" value="𝕛"/>
+ <entity name="Jopf" value="𝕁"/>
+ <entity name="jscr" value="𝒿"/>
+ <entity name="Jscr" value="𝒥"/>
+ <entity name="jsercy" value="ј"/>
+ <entity name="Jsercy" value="Ј"/>
+ <entity name="jukcy" value="є"/>
+ <entity name="Jukcy" value="Є"/>
+ <entity name="kappa" value="κ"/>
+ <entity name="kappav" value="ϰ"/>
+ <entity name="kcedil" value="ķ"/>
+ <entity name="Kcedil" value="Ķ"/>
+ <entity name="kcy" value="к"/>
+ <entity name="Kcy" value="К"/>
+ <entity name="kfr" value="𝔨"/>
+ <entity name="Kfr" value="𝔎"/>
+ <entity name="kgreen" value="ĸ"/>
+ <entity name="khcy" value="х"/>
+ <entity name="KHcy" value="Х"/>
+ <entity name="kjcy" value="ќ"/>
+ <entity name="KJcy" value="Ќ"/>
+ <entity name="kopf" value="𝕜"/>
+ <entity name="Kopf" value="𝕂"/>
+ <entity name="kscr" value="𝓀"/>
+ <entity name="Kscr" value="𝒦"/>
+ <entity name="lAarr" value="⇚"/>
+ <entity name="lacute" value="ĺ"/>
+ <entity name="Lacute" value="Ĺ"/>
+ <entity name="laemptyv" value="⦴"/>
+ <entity name="lagran" value="ℒ"/>
+ <entity name="lambda" value="λ"/>
+ <entity name="Lambda" value="Λ"/>
+ <entity name="lang" value="〈"/>
+ <entity name="Lang" value="《"/>
+ <entity name="langd" value="⦑"/>
+ <entity name="langle" value="〈"/>
+ <entity name="lap" value="≲"/>
+ <entity name="Laplacetrf" value="ℒ"/>
+ <entity name="laquo" value="«"/>
+ <entity name="larr" value="←"/>
+ <entity name="lArr" value="⇐"/>
+ <entity name="Larr" value="↞"/>
+ <entity name="larrb" value="⇤"/>
+ <entity name="larrbfs" value="⤟"/>
+ <entity name="larrfs" value="⤝"/>
+ <entity name="larrhk" value="↩"/>
+ <entity name="larrlp" value="↫"/>
+ <entity name="larrpl" value="⤹"/>
+ <entity name="larrsim" value="⥳"/>
+ <entity name="larrtl" value="↢"/>
+ <entity name="lat" value="⪫"/>
+ <entity name="latail" value="⤙"/>
+ <entity name="lAtail" value="⤛"/>
+ <entity name="late" value="⪭"/>
+ <entity name="lates" value="⪭︀"/>
+ <entity name="lbarr" value="⤌"/>
+ <entity name="lBarr" value="⤎"/>
+ <entity name="lbbrk" value="〔"/>
+ <entity name="lbrace" value="{"/>
+ <entity name="lbrack" value="["/>
+ <entity name="lbrke" value="⦋"/>
+ <entity name="lbrksld" value="⦏"/>
+ <entity name="lbrkslu" value="⦍"/>
+ <entity name="lcaron" value="ľ"/>
+ <entity name="Lcaron" value="Ľ"/>
+ <entity name="lcedil" value="ļ"/>
+ <entity name="Lcedil" value="Ļ"/>
+ <entity name="lceil" value="⌈"/>
+ <entity name="lcub" value="{"/>
+ <entity name="lcy" value="л"/>
+ <entity name="Lcy" value="Л"/>
+ <entity name="ldca" value="⤶"/>
+ <entity name="ldquo" value="“"/>
+ <entity name="ldquor" value="„"/>
+ <entity name="ldrdhar" value="⥧"/>
+ <entity name="ldrushar" value="⥋"/>
+ <entity name="ldsh" value="↲"/>
+ <entity name="le" value="≤"/>
+ <entity name="lE" value="≦"/>
+ <entity name="LeftAngleBracket" value="〈"/>
+ <entity name="leftarrow" value="←"/>
+ <entity name="Leftarrow" value="⇐"/>
+ <entity name="LeftArrow" value="←"/>
+ <entity name="LeftArrowBar" value="⇤"/>
+ <entity name="LeftArrowRightArrow" value="⇆"/>
+ <entity name="leftarrowtail" value="↢"/>
+ <entity name="LeftCeiling" value="⌈"/>
+ <entity name="LeftDoubleBracket" value="〚"/>
+ <entity name="LeftDownTeeVector" value="⥡"/>
+ <entity name="LeftDownVector" value="⇃"/>
+ <entity name="LeftDownVectorBar" value="⥙"/>
+ <entity name="LeftFloor" value="⌊"/>
+ <entity name="leftharpoondown" value="↽"/>
+ <entity name="leftharpoonup" value="↼"/>
+ <entity name="leftleftarrows" value="⇇"/>
+ <entity name="leftrightarrow" value="↔"/>
+ <entity name="Leftrightarrow" value="⇔"/>
+ <entity name="LeftRightArrow" value="↔"/>
+ <entity name="leftrightarrows" value="⇆"/>
+ <entity name="leftrightharpoons" value="⇋"/>
+ <entity name="leftrightsquigarrow" value="↭"/>
+ <entity name="LeftRightVector" value="⥎"/>
+ <entity name="LeftTee" value="⊣"/>
+ <entity name="LeftTeeArrow" value="↤"/>
+ <entity name="LeftTeeVector" value="⥚"/>
+ <entity name="leftthreetimes" value="⋋"/>
+ <entity name="LeftTriangle" value="⊲"/>
+ <entity name="LeftTriangleBar" value="⧏"/>
+ <entity name="LeftTriangleEqual" value="⊴"/>
+ <entity name="LeftUpDownVector" value="⥑"/>
+ <entity name="LeftUpTeeVector" value="⥠"/>
+ <entity name="LeftUpVector" value="↿"/>
+ <entity name="LeftUpVectorBar" value="⥘"/>
+ <entity name="LeftVector" value="↼"/>
+ <entity name="LeftVectorBar" value="⥒"/>
+ <entity name="leg" value="⋚"/>
+ <entity name="lEg" value="⋚"/>
+ <entity name="leq" value="≤"/>
+ <entity name="leqq" value="≦"/>
+ <entity name="leqslant" value="⩽"/>
+ <entity name="les" value="⩽"/>
+ <entity name="lescc" value="⪨"/>
+ <entity name="lesdot" value="⩿"/>
+ <entity name="lesdoto" value="⪁"/>
+ <entity name="lesdotor" value="⪃"/>
+ <entity name="lesg" value="⋚︀"/>
+ <entity name="lesges" value="⪓"/>
+ <entity name="lessapprox" value="≲"/>
+ <entity name="lessdot" value="⋖"/>
+ <entity name="lesseqgtr" value="⋚"/>
+ <entity name="lesseqqgtr" value="⋚"/>
+ <entity name="LessEqualGreater" value="⋚"/>
+ <entity name="LessFullEqual" value="≦"/>
+ <entity name="LessGreater" value="≶"/>
+ <entity name="lessgtr" value="≶"/>
+ <entity name="LessLess" value="⪡"/>
+ <entity name="lesssim" value="≲"/>
+ <entity name="LessSlantEqual" value="⩽"/>
+ <entity name="LessTilde" value="≲"/>
+ <entity name="lfisht" value="⥼"/>
+ <entity name="lfloor" value="⌊"/>
+ <entity name="lfr" value="𝔩"/>
+ <entity name="Lfr" value="𝔏"/>
+ <entity name="lg" value="≶"/>
+ <entity name="lgE" value="⪑"/>
+ <entity name="lHar" value="⥢"/>
+ <entity name="lhard" value="↽"/>
+ <entity name="lharu" value="↼"/>
+ <entity name="lharul" value="⥪"/>
+ <entity name="lhblk" value="▄"/>
+ <entity name="ljcy" value="љ"/>
+ <entity name="LJcy" value="Љ"/>
+ <entity name="ll" value="≪"/>
+ <entity name="Ll" value="⋘"/>
+ <entity name="llarr" value="⇇"/>
+ <entity name="llcorner" value="⌞"/>
+ <entity name="Lleftarrow" value="⇚"/>
+ <entity name="llhard" value="⥫"/>
+ <entity name="lltri" value="◺"/>
+ <entity name="lmidot" value="ŀ"/>
+ <entity name="Lmidot" value="Ŀ"/>
+ <entity name="lmoust" value="⎰"/>
+ <entity name="lmoustache" value="⎰"/>
+ <entity name="lnap" value="⪉"/>
+ <entity name="lnapprox" value="⪉"/>
+ <entity name="lne" value="≨"/>
+ <entity name="lnE" value="≨"/>
+ <entity name="lneq" value="≨"/>
+ <entity name="lneqq" value="≨"/>
+ <entity name="lnsim" value="⋦"/>
+ <entity name="loang" value=""/>
+ <entity name="loarr" value="⇽"/>
+ <entity name="lobrk" value="〚"/>
+ <entity name="longleftarrow" value=""/>
+ <entity name="Longleftarrow" value=""/>
+ <entity name="LongLeftArrow" value=""/>
+ <entity name="longleftrightarrow" value=""/>
+ <entity name="Longleftrightarrow" value=""/>
+ <entity name="LongLeftRightArrow" value=""/>
+ <entity name="longmapsto" value=""/>
+ <entity name="longrightarrow" value=""/>
+ <entity name="Longrightarrow" value=""/>
+ <entity name="LongRightArrow" value=""/>
+ <entity name="looparrowleft" value="↫"/>
+ <entity name="looparrowright" value="↬"/>
+ <entity name="lopar" value="〘"/>
+ <entity name="lopf" value="𝕝"/>
+ <entity name="Lopf" value="𝕃"/>
+ <entity name="loplus" value="⨭"/>
+ <entity name="lotimes" value="⨴"/>
+ <entity name="lowast" value="∗"/>
+ <entity name="lowbar" value="_"/>
+ <entity name="LowerLeftArrow" value="↙"/>
+ <entity name="LowerRightArrow" value="↘"/>
+ <entity name="loz" value="◊"/>
+ <entity name="lozenge" value="◊"/>
+ <entity name="lozf" value="⧫"/>
+ <entity name="lpar" value="("/>
+ <entity name="lparlt" value="⦓"/>
+ <entity name="lrarr" value="⇆"/>
+ <entity name="lrcorner" value="⌟"/>
+ <entity name="lrhar" value="⇋"/>
+ <entity name="lrhard" value="⥭"/>
+ <entity name="lrtri" value="⊿"/>
+ <entity name="lscr" value="ℓ"/>
+ <entity name="Lscr" value="ℒ"/>
+ <entity name="lsh" value="↰"/>
+ <entity name="Lsh" value="↰"/>
+ <entity name="lsim" value="≲"/>
+ <entity name="lsime" value="⪍"/>
+ <entity name="lsimg" value="⪏"/>
+ <entity name="lsqb" value="["/>
+ <entity name="lsquo" value="‘"/>
+ <entity name="lsquor" value="‚"/>
+ <entity name="lstrok" value="ł"/>
+ <entity name="Lstrok" value="Ł"/>
+ <entity name="lt" value="<"/>
+ <entity name="Lt" value="≪"/>
+ <entity name="ltcc" value="⪦"/>
+ <entity name="ltcir" value="⩹"/>
+ <entity name="ltdot" value="⋖"/>
+ <entity name="lthree" value="⋋"/>
+ <entity name="ltimes" value="⋉"/>
+ <entity name="ltlarr" value="⥶"/>
+ <entity name="ltquest" value="⩻"/>
+ <entity name="ltri" value="◃"/>
+ <entity name="ltrie" value="⊴"/>
+ <entity name="ltrif" value="◂"/>
+ <entity name="ltrPar" value="⦖"/>
+ <entity name="lurdshar" value="⥊"/>
+ <entity name="luruhar" value="⥦"/>
+ <entity name="lvertneqq" value="≨︀"/>
+ <entity name="lvnE" value="≨︀"/>
+ <entity name="macr" value="¯"/>
+ <entity name="male" value="♂"/>
+ <entity name="malt" value="✠"/>
+ <entity name="maltese" value="✠"/>
+ <entity name="map" value="↦"/>
+ <entity name="Map" value="⤅"/>
+ <entity name="mapsto" value="↦"/>
+ <entity name="mapstodown" value="↧"/>
+ <entity name="mapstoleft" value="↤"/>
+ <entity name="mapstoup" value="↥"/>
+ <entity name="marker" value="▮"/>
+ <entity name="mcomma" value="⨩"/>
+ <entity name="mcy" value="м"/>
+ <entity name="Mcy" value="М"/>
+ <entity name="mdash" value="—"/>
+ <entity name="mDDot" value="∺"/>
+ <entity name="measuredangle" value="∡"/>
+ <entity name="MediumSpace" value=" "/>
+ <entity name="Mellintrf" value="ℳ"/>
+ <entity name="mfr" value="𝔪"/>
+ <entity name="Mfr" value="𝔐"/>
+ <entity name="mho" value="℧"/>
+ <entity name="micro" value="µ"/>
+ <entity name="mid" value="∣"/>
+ <entity name="midast" value="*"/>
+ <entity name="midcir" value="⫰"/>
+ <entity name="middot" value="·"/>
+ <entity name="minus" value="−"/>
+ <entity name="minusb" value="⊟"/>
+ <entity name="minusd" value="∸"/>
+ <entity name="minusdu" value="⨪"/>
+ <entity name="MinusPlus" value="∓"/>
+ <entity name="mlcp" value="⫛"/>
+ <entity name="mldr" value="…"/>
+ <entity name="mnplus" value="∓"/>
+ <entity name="models" value="⊧"/>
+ <entity name="mopf" value="𝕞"/>
+ <entity name="Mopf" value="𝕄"/>
+ <entity name="mp" value="∓"/>
+ <entity name="mscr" value="𝓂"/>
+ <entity name="Mscr" value="ℳ"/>
+ <entity name="mstpos" value="∾"/>
+ <entity name="mu" value="μ"/>
+ <entity name="multimap" value="⊸"/>
+ <entity name="mumap" value="⊸"/>
+ <entity name="nabla" value="∇"/>
+ <entity name="nacute" value="ń"/>
+ <entity name="Nacute" value="Ń"/>
+ <entity name="nang" value="∠̸"/>
+ <entity name="nap" value="≉"/>
+ <entity name="napE" value="⩰̸"/>
+ <entity name="napid" value="≋̸"/>
+ <entity name="napos" value="ʼn"/>
+ <entity name="napprox" value="≉"/>
+ <entity name="natur" value="♮"/>
+ <entity name="natural" value="♮"/>
+ <entity name="naturals" value="ℕ"/>
+ <entity name="nbsp" value=" "/>
+ <entity name="nbump" value="≎̸"/>
+ <entity name="nbumpe" value="≏̸"/>
+ <entity name="ncap" value="⩃"/>
+ <entity name="ncaron" value="ň"/>
+ <entity name="Ncaron" value="Ň"/>
+ <entity name="ncedil" value="ņ"/>
+ <entity name="Ncedil" value="Ņ"/>
+ <entity name="ncong" value="≇"/>
+ <entity name="ncongdot" value="⩭̸"/>
+ <entity name="ncup" value="⩂"/>
+ <entity name="ncy" value="н"/>
+ <entity name="Ncy" value="Н"/>
+ <entity name="ndash" value="–"/>
+ <entity name="ne" value="≠"/>
+ <entity name="nearhk" value="⤤"/>
+ <entity name="nearr" value="↗"/>
+ <entity name="neArr" value="⇗"/>
+ <entity name="nearrow" value="↗"/>
+ <entity name="nedot" value="≠︀"/>
+ <entity name="NegativeMediumSpace" value=" ︀"/>
+ <entity name="NegativeThickSpace" value=" ︀"/>
+ <entity name="NegativeThinSpace" value=" ︀"/>
+ <entity name="NegativeVeryThinSpace" value=" ︀"/>
+ <entity name="nequiv" value="≢"/>
+ <entity name="nesear" value="⤨"/>
+ <entity name="nesim" value="≂̸"/>
+ <entity name="NestedGreaterGreater" value="≫"/>
+ <entity name="NestedLessLess" value="≪"/>
+ <entity name="NewLine" value="
"/>
+ <entity name="nexist" value="∄"/>
+ <entity name="nexists" value="∄"/>
+ <entity name="nfr" value="𝔫"/>
+ <entity name="Nfr" value="𝔑"/>
+ <entity name="nge" value="≱⃥"/>
+ <entity name="ngE" value="≱"/>
+ <entity name="ngeq" value="≱⃥"/>
+ <entity name="ngeqq" value="≱"/>
+ <entity name="ngeqslant" value="≱"/>
+ <entity name="nges" value="≱"/>
+ <entity name="nGg" value="⋙̸"/>
+ <entity name="ngsim" value="≵"/>
+ <entity name="ngt" value="≯"/>
+ <entity name="nGt" value="≫̸"/>
+ <entity name="ngtr" value="≯"/>
+ <entity name="nGtv" value="≫̸︀"/>
+ <entity name="nharr" value="↮"/>
+ <entity name="nhArr" value="⇎"/>
+ <entity name="nhpar" value="⫲"/>
+ <entity name="ni" value="∋"/>
+ <entity name="nis" value="⋼"/>
+ <entity name="nisd" value="⋺"/>
+ <entity name="niv" value="∋"/>
+ <entity name="njcy" value="њ"/>
+ <entity name="NJcy" value="Њ"/>
+ <entity name="nlarr" value="↚"/>
+ <entity name="nlArr" value="⇍"/>
+ <entity name="nldr" value="‥"/>
+ <entity name="nle" value="≰⃥"/>
+ <entity name="nlE" value="≰"/>
+ <entity name="nleftarrow" value="↚"/>
+ <entity name="nLeftarrow" value="⇍"/>
+ <entity name="nleftrightarrow" value="↮"/>
+ <entity name="nLeftrightarrow" value="⇎"/>
+ <entity name="nleq" value="≰⃥"/>
+ <entity name="nleqq" value="≰"/>
+ <entity name="nleqslant" value="≰"/>
+ <entity name="nles" value="≰"/>
+ <entity name="nless" value="≮"/>
+ <entity name="nLl" value="⋘̸"/>
+ <entity name="nlsim" value="≴"/>
+ <entity name="nlt" value="≮"/>
+ <entity name="nLt" value="≪̸"/>
+ <entity name="nltri" value="⋪"/>
+ <entity name="nltrie" value="⋬"/>
+ <entity name="nLtv" value="≪̸︀"/>
+ <entity name="nmid" value="∤"/>
+ <entity name="NoBreak" value=""/>
+ <entity name="NonBreakingSpace" value=" "/>
+ <entity name="nopf" value="𝕟"/>
+ <entity name="Nopf" value="ℕ"/>
+ <entity name="not" value="¬"/>
+ <entity name="Not" value="⫬"/>
+ <entity name="NotCongruent" value="≢"/>
+ <entity name="NotCupCap" value="≭"/>
+ <entity name="NotDoubleVerticalBar" value="∦"/>
+ <entity name="NotElement" value="∉"/>
+ <entity name="NotEqual" value="≠"/>
+ <entity name="NotEqualTilde" value="≂̸"/>
+ <entity name="NotExists" value="∄"/>
+ <entity name="NotGreater" value="≯"/>
+ <entity name="NotGreaterEqual" value="≱⃥"/>
+ <entity name="NotGreaterFullEqual" value="≰"/>
+ <entity name="NotGreaterGreater" value="≫̸︀"/>
+ <entity name="NotGreaterLess" value="≹"/>
+ <entity name="NotGreaterSlantEqual" value="≱"/>
+ <entity name="NotGreaterTilde" value="≵"/>
+ <entity name="NotHumpDownHump" value="≎̸"/>
+ <entity name="NotHumpEqual" value="≏̸"/>
+ <entity name="notin" value="∉"/>
+ <entity name="notindot" value="⋶︀"/>
+ <entity name="notinva" value="∉̸"/>
+ <entity name="notinvb" value="⋷"/>
+ <entity name="notinvc" value="⋶"/>
+ <entity name="NotLeftTriangle" value="⋪"/>
+ <entity name="NotLeftTriangleBar" value="⧏̸"/>
+ <entity name="NotLeftTriangleEqual" value="⋬"/>
+ <entity name="NotLess" value="≮"/>
+ <entity name="NotLessEqual" value="≰⃥"/>
+ <entity name="NotLessGreater" value="≸"/>
+ <entity name="NotLessLess" value="≪̸︀"/>
+ <entity name="NotLessSlantEqual" value="≰"/>
+ <entity name="NotLessTilde" value="≴"/>
+ <entity name="NotNestedGreaterGreater" value="⒢̸"/>
+ <entity name="NotNestedLessLess" value="⒡̸"/>
+ <entity name="notni" value="∌"/>
+ <entity name="notniva" value="∌"/>
+ <entity name="notnivb" value="⋾"/>
+ <entity name="notnivc" value="⋽"/>
+ <entity name="NotPrecedes" value="⊀"/>
+ <entity name="NotPrecedesEqual" value="⪯̸"/>
+ <entity name="NotPrecedesSlantEqual" value="⋠"/>
+ <entity name="NotReverseElement" value="∌"/>
+ <entity name="NotRightTriangle" value="⋫"/>
+ <entity name="NotRightTriangleBar" value="⧐̸"/>
+ <entity name="NotRightTriangleEqual" value="⋭"/>
+ <entity name="NotSquareSubset" value="⊏̸"/>
+ <entity name="NotSquareSubsetEqual" value="⋢"/>
+ <entity name="NotSquareSuperset" value="⊐̸"/>
+ <entity name="NotSquareSupersetEqual" value="⋣"/>
+ <entity name="NotSubset" value="⊄"/>
+ <entity name="NotSubsetEqual" value="⊈"/>
+ <entity name="NotSucceeds" value="⊁"/>
+ <entity name="NotSucceedsEqual" value="⪰̸"/>
+ <entity name="NotSucceedsSlantEqual" value="⋡"/>
+ <entity name="NotSucceedsTilde" value="≿̸"/>
+ <entity name="NotSuperset" value="⊅"/>
+ <entity name="NotSupersetEqual" value="⊉"/>
+ <entity name="NotTilde" value="≁"/>
+ <entity name="NotTildeEqual" value="≄"/>
+ <entity name="NotTildeFullEqual" value="≇"/>
+ <entity name="NotTildeTilde" value="≉"/>
+ <entity name="NotVerticalBar" value="∤"/>
+ <entity name="npar" value="∦"/>
+ <entity name="nparallel" value="∦"/>
+ <entity name="nparsl" value="∥︀⃥"/>
+ <entity name="npart" value="∂̸"/>
+ <entity name="npolint" value="⨔"/>
+ <entity name="npr" value="⊀"/>
+ <entity name="nprcue" value="⋠"/>
+ <entity name="npre" value="⪯̸"/>
+ <entity name="nprec" value="⊀"/>
+ <entity name="npreceq" value="⪯̸"/>
+ <entity name="nrarr" value="↛"/>
+ <entity name="nrArr" value="⇏"/>
+ <entity name="nrarrc" value="⤳̸"/>
+ <entity name="nrarrw" value="↝̸"/>
+ <entity name="nrightarrow" value="↛"/>
+ <entity name="nRightarrow" value="⇏"/>
+ <entity name="nrtri" value="⋫"/>
+ <entity name="nrtrie" value="⋭"/>
+ <entity name="nsc" value="⊁"/>
+ <entity name="nsccue" value="⋡"/>
+ <entity name="nsce" value="⪰̸"/>
+ <entity name="nscr" value="𝓃"/>
+ <entity name="Nscr" value="𝒩"/>
+ <entity name="nshortmid" value="∤︀"/>
+ <entity name="nshortparallel" value="∦︀"/>
+ <entity name="nsim" value="≁"/>
+ <entity name="nsime" value="≄"/>
+ <entity name="nsimeq" value="≄"/>
+ <entity name="nsmid" value="∤︀"/>
+ <entity name="nspar" value="∦︀"/>
+ <entity name="nsqsube" value="⋢"/>
+ <entity name="nsqsupe" value="⋣"/>
+ <entity name="nsub" value="⊄"/>
+ <entity name="nsube" value="⊈"/>
+ <entity name="nsubE" value="⊈"/>
+ <entity name="nsubset" value="⊄"/>
+ <entity name="nsubseteq" value="⊈"/>
+ <entity name="nsubseteqq" value="⊈"/>
+ <entity name="nsucc" value="⊁"/>
+ <entity name="nsucceq" value="⪰̸"/>
+ <entity name="nsup" value="⊅"/>
+ <entity name="nsupe" value="⊉"/>
+ <entity name="nsupE" value="⊉"/>
+ <entity name="nsupset" value="⊅"/>
+ <entity name="nsupseteq" value="⊉"/>
+ <entity name="nsupseteqq" value="⊉"/>
+ <entity name="ntgl" value="≹"/>
+ <entity name="ntilde" value="ñ"/>
+ <entity name="Ntilde" value="Ñ"/>
+ <entity name="ntlg" value="≸"/>
+ <entity name="ntriangleleft" value="⋪"/>
+ <entity name="ntrianglelefteq" value="⋬"/>
+ <entity name="ntriangleright" value="⋫"/>
+ <entity name="ntrianglerighteq" value="⋭"/>
+ <entity name="nu" value="ν"/>
+ <entity name="num" value="#"/>
+ <entity name="numero" value="№"/>
+ <entity name="numsp" value=" "/>
+ <entity name="nvap" value="≉̸"/>
+ <entity name="nvdash" value="⊬"/>
+ <entity name="nvDash" value="⊭"/>
+ <entity name="nVdash" value="⊮"/>
+ <entity name="nVDash" value="⊯"/>
+ <entity name="nvge" value="≱"/>
+ <entity name="nvgt" value="≯"/>
+ <entity name="nvHarr" value="⇎"/>
+ <entity name="nvinfin" value="⧞"/>
+ <entity name="nvlArr" value="⇍"/>
+ <entity name="nvle" value="≰"/>
+ <entity name="nvlt" value="≮"/>
+ <entity name="nvltrie" value="⋬̸"/>
+ <entity name="nvrArr" value="⇏"/>
+ <entity name="nvrtrie" value="⋭̸"/>
+ <entity name="nvsim" value="≁̸"/>
+ <entity name="nwarhk" value="⤣"/>
+ <entity name="nwarr" value="↖"/>
+ <entity name="nwArr" value="⇖"/>
+ <entity name="nwarrow" value="↖"/>
+ <entity name="nwnear" value="⤧"/>
+ <entity name="oacute" value="ó"/>
+ <entity name="Oacute" value="Ó"/>
+ <entity name="oast" value="⊛"/>
+ <entity name="ocir" value="⊚"/>
+ <entity name="ocirc" value="ô"/>
+ <entity name="Ocirc" value="Ô"/>
+ <entity name="ocy" value="о"/>
+ <entity name="Ocy" value="О"/>
+ <entity name="odash" value="⊝"/>
+ <entity name="odblac" value="ő"/>
+ <entity name="Odblac" value="Ő"/>
+ <entity name="odiv" value="⨸"/>
+ <entity name="odot" value="⊙"/>
+ <entity name="odsold" value="⦼"/>
+ <entity name="oelig" value="œ"/>
+ <entity name="OElig" value="Œ"/>
+ <entity name="ofcir" value="⦿"/>
+ <entity name="ofr" value="𝔬"/>
+ <entity name="Ofr" value="𝔒"/>
+ <entity name="ogon" value="˛"/>
+ <entity name="ograve" value="ò"/>
+ <entity name="Ograve" value="Ò"/>
+ <entity name="ogt" value="⧁"/>
+ <entity name="ohbar" value="⦵"/>
+ <entity name="ohm" value="Ω"/>
+ <entity name="oint" value="∮"/>
+ <entity name="olarr" value="↺"/>
+ <entity name="olcir" value="⦾"/>
+ <entity name="olcross" value="⦻"/>
+ <entity name="olt" value="⧀"/>
+ <entity name="omacr" value="ō"/>
+ <entity name="Omacr" value="Ō"/>
+ <entity name="omega" value="ω"/>
+ <entity name="Omega" value="Ω"/>
+ <entity name="omid" value="⦶"/>
+ <entity name="ominus" value="⊖"/>
+ <entity name="oopf" value="𝕠"/>
+ <entity name="Oopf" value="𝕆"/>
+ <entity name="opar" value="⦷"/>
+ <entity name="OpenCurlyDoubleQuote" value="“"/>
+ <entity name="OpenCurlyQuote" value="‘"/>
+ <entity name="operp" value="⦹"/>
+ <entity name="oplus" value="⊕"/>
+ <entity name="or" value="∨"/>
+ <entity name="Or" value="⩔"/>
+ <entity name="orarr" value="↻"/>
+ <entity name="ord" value="⩝"/>
+ <entity name="order" value="ℴ"/>
+ <entity name="orderof" value="ℴ"/>
+ <entity name="ordf" value="ª"/>
+ <entity name="ordm" value="º"/>
+ <entity name="origof" value="⊶"/>
+ <entity name="oror" value="⩖"/>
+ <entity name="orslope" value="⩗"/>
+ <entity name="orv" value="⩛"/>
+ <entity name="oS" value="Ⓢ"/>
+ <entity name="oscr" value="ℴ"/>
+ <entity name="Oscr" value="𝒪"/>
+ <entity name="oslash" value="ø"/>
+ <entity name="Oslash" value="Ø"/>
+ <entity name="osol" value="⊘"/>
+ <entity name="otilde" value="õ"/>
+ <entity name="Otilde" value="Õ"/>
+ <entity name="otimes" value="⊗"/>
+ <entity name="Otimes" value="⨷"/>
+ <entity name="otimesas" value="⨶"/>
+ <entity name="ouml" value="ö"/>
+ <entity name="Ouml" value="Ö"/>
+ <entity name="ovbar" value="⌽"/>
+ <entity name="OverBar" value="¯"/>
+ <entity name="OverBrace" value="︷"/>
+ <entity name="OverBracket" value="⎴"/>
+ <entity name="OverParenthesis" value="︵"/>
+ <entity name="par" value="∥"/>
+ <entity name="para" value="¶"/>
+ <entity name="parallel" value="∥"/>
+ <entity name="parsim" value="⫳"/>
+ <entity name="parsl" value="∥︀"/>
+ <entity name="part" value="∂"/>
+ <entity name="PartialD" value="∂"/>
+ <entity name="pcy" value="п"/>
+ <entity name="Pcy" value="П"/>
+ <entity name="percnt" value="%"/>
+ <entity name="period" value="."/>
+ <entity name="permil" value="‰"/>
+ <entity name="perp" value="⊥"/>
+ <entity name="pertenk" value="‱"/>
+ <entity name="pfr" value="𝔭"/>
+ <entity name="Pfr" value="𝔓"/>
+ <entity name="phi" value="φ"/>
+ <entity name="Phi" value="Φ"/>
+ <entity name="phiv" value="ϕ"/>
+ <entity name="phmmat" value="ℳ"/>
+ <entity name="phone" value="☎"/>
+ <entity name="pi" value="π"/>
+ <entity name="Pi" value="Π"/>
+ <entity name="pitchfork" value="⋔"/>
+ <entity name="piv" value="ϖ"/>
+ <entity name="planck" value="ℏ︀"/>
+ <entity name="planckh" value="ℎ"/>
+ <entity name="plankv" value="ℏ"/>
+ <entity name="plus" value="+"/>
+ <entity name="plusacir" value="⨣"/>
+ <entity name="plusb" value="⊞"/>
+ <entity name="pluscir" value="⨢"/>
+ <entity name="plusdo" value="∔"/>
+ <entity name="plusdu" value="⨥"/>
+ <entity name="pluse" value="⩲"/>
+ <entity name="PlusMinus" value="±"/>
+ <entity name="plusmn" value="±"/>
+ <entity name="plussim" value="⨦"/>
+ <entity name="plustwo" value="⨧"/>
+ <entity name="pm" value="±"/>
+ <entity name="Poincareplane" value="ℌ"/>
+ <entity name="pointint" value="⨕"/>
+ <entity name="popf" value="𝕡"/>
+ <entity name="Popf" value="ℙ"/>
+ <entity name="pound" value="£"/>
+ <entity name="pr" value="≺"/>
+ <entity name="Pr" value="⪻"/>
+ <entity name="prap" value="≾"/>
+ <entity name="prcue" value="≼"/>
+ <entity name="pre" value="⪯"/>
+ <entity name="prE" value="⪯"/>
+ <entity name="prec" value="≺"/>
+ <entity name="precapprox" value="≾"/>
+ <entity name="preccurlyeq" value="≼"/>
+ <entity name="Precedes" value="≺"/>
+ <entity name="PrecedesEqual" value="⪯"/>
+ <entity name="PrecedesSlantEqual" value="≼"/>
+ <entity name="PrecedesTilde" value="≾"/>
+ <entity name="preceq" value="⪯"/>
+ <entity name="precnapprox" value="⋨"/>
+ <entity name="precneqq" value="⪵"/>
+ <entity name="precnsim" value="⋨"/>
+ <entity name="precsim" value="≾"/>
+ <entity name="prime" value="′"/>
+ <entity name="Prime" value="″"/>
+ <entity name="primes" value="ℙ"/>
+ <entity name="prnap" value="⋨"/>
+ <entity name="prnE" value="⪵"/>
+ <entity name="prnsim" value="⋨"/>
+ <entity name="prod" value="∏"/>
+ <entity name="Product" value="∏"/>
+ <entity name="profalar" value="⌮"/>
+ <entity name="profline" value="⌒"/>
+ <entity name="profsurf" value="⌓"/>
+ <entity name="prop" value="∝"/>
+ <entity name="Proportion" value="∷"/>
+ <entity name="Proportional" value="∝"/>
+ <entity name="propto" value="∝"/>
+ <entity name="prsim" value="≾"/>
+ <entity name="prurel" value="⊰"/>
+ <entity name="pscr" value="𝓅"/>
+ <entity name="Pscr" value="𝒫"/>
+ <entity name="psi" value="ψ"/>
+ <entity name="Psi" value="Ψ"/>
+ <entity name="puncsp" value=" "/>
+ <entity name="qfr" value="𝔮"/>
+ <entity name="Qfr" value="𝔔"/>
+ <entity name="qint" value="⨌"/>
+ <entity name="qopf" value="𝕢"/>
+ <entity name="Qopf" value="ℚ"/>
+ <entity name="qprime" value="⁗"/>
+ <entity name="qscr" value="𝓆"/>
+ <entity name="Qscr" value="𝒬"/>
+ <entity name="quaternions" value="ℍ"/>
+ <entity name="quatint" value="⨖"/>
+ <entity name="quest" value="?"/>
+ <entity name="questeq" value="≟"/>
+ <entity name="quot" value="""/>
+ <entity name="rAarr" value="⇛"/>
+ <entity name="race" value="⧚"/>
+ <entity name="racute" value="ŕ"/>
+ <entity name="Racute" value="Ŕ"/>
+ <entity name="radic" value="√"/>
+ <entity name="raemptyv" value="⦳"/>
+ <entity name="rang" value="〉"/>
+ <entity name="Rang" value="》"/>
+ <entity name="rangd" value="⦒"/>
+ <entity name="range" value="⦥"/>
+ <entity name="rangle" value="〉"/>
+ <entity name="raquo" value="»"/>
+ <entity name="rarr" value="→"/>
+ <entity name="rArr" value="⇒"/>
+ <entity name="Rarr" value="↠"/>
+ <entity name="rarrap" value="⥵"/>
+ <entity name="rarrb" value="⇥"/>
+ <entity name="rarrbfs" value="⤠"/>
+ <entity name="rarrc" value="⤳"/>
+ <entity name="rarrfs" value="⤞"/>
+ <entity name="rarrhk" value="↪"/>
+ <entity name="rarrlp" value="↬"/>
+ <entity name="rarrpl" value="⥅"/>
+ <entity name="rarrsim" value="⥴"/>
+ <entity name="rarrtl" value="↣"/>
+ <entity name="Rarrtl" value="⤖"/>
+ <entity name="rarrw" value="↝"/>
+ <entity name="ratail" value="↣"/>
+ <entity name="rAtail" value="⤜"/>
+ <entity name="ratio" value="∶"/>
+ <entity name="rationals" value="ℚ"/>
+ <entity name="rbarr" value="⤍"/>
+ <entity name="rBarr" value="⤏"/>
+ <entity name="RBarr" value="⤐"/>
+ <entity name="rbbrk" value="〕"/>
+ <entity name="rbrace" value="}"/>
+ <entity name="rbrack" value="]"/>
+ <entity name="rbrke" value="⦌"/>
+ <entity name="rbrksld" value="⦎"/>
+ <entity name="rbrkslu" value="⦐"/>
+ <entity name="rcaron" value="ř"/>
+ <entity name="Rcaron" value="Ř"/>
+ <entity name="rcedil" value="ŗ"/>
+ <entity name="Rcedil" value="Ŗ"/>
+ <entity name="rceil" value="⌉"/>
+ <entity name="rcub" value="}"/>
+ <entity name="rcy" value="р"/>
+ <entity name="Rcy" value="Р"/>
+ <entity name="rdca" value="⤷"/>
+ <entity name="rdldhar" value="⥩"/>
+ <entity name="rdquo" value="”"/>
+ <entity name="rdquor" value="”"/>
+ <entity name="rdsh" value="↳"/>
+ <entity name="Re" value="ℜ"/>
+ <entity name="real" value="ℜ"/>
+ <entity name="realine" value="ℛ"/>
+ <entity name="realpart" value="ℜ"/>
+ <entity name="reals" value="ℝ"/>
+ <entity name="rect" value="▭"/>
+ <entity name="reg" value="®"/>
+ <entity name="ReverseElement" value="∋"/>
+ <entity name="ReverseEquilibrium" value="⇋"/>
+ <entity name="ReverseUpEquilibrium" value="⥯"/>
+ <entity name="rfisht" value="⥽"/>
+ <entity name="rfloor" value="⌋"/>
+ <entity name="rfr" value="𝔯"/>
+ <entity name="Rfr" value="ℜ"/>
+ <entity name="rHar" value="⥤"/>
+ <entity name="rhard" value="⇁"/>
+ <entity name="rharu" value="⇀"/>
+ <entity name="rharul" value="⥬"/>
+ <entity name="rho" value="ρ"/>
+ <entity name="rhov" value="ϱ"/>
+ <entity name="RightAngleBracket" value="〉"/>
+ <entity name="rightarrow" value="→"/>
+ <entity name="Rightarrow" value="⇒"/>
+ <entity name="RightArrow" value="→"/>
+ <entity name="RightArrowBar" value="⇥"/>
+ <entity name="RightArrowLeftArrow" value="⇄"/>
+ <entity name="rightarrowtail" value="↣"/>
+ <entity name="RightCeiling" value="⌉"/>
+ <entity name="RightDoubleBracket" value="〛"/>
+ <entity name="RightDownTeeVector" value="⥝"/>
+ <entity name="RightDownVector" value="⇂"/>
+ <entity name="RightDownVectorBar" value="⥕"/>
+ <entity name="RightFloor" value="⌋"/>
+ <entity name="rightharpoondown" value="⇁"/>
+ <entity name="rightharpoonup" value="⇀"/>
+ <entity name="rightleftarrows" value="⇄"/>
+ <entity name="rightleftharpoons" value="⇌"/>
+ <entity name="rightrightarrows" value="⇉"/>
+ <entity name="rightsquigarrow" value="↝"/>
+ <entity name="RightTee" value="⊢"/>
+ <entity name="RightTeeArrow" value="↦"/>
+ <entity name="RightTeeVector" value="⥛"/>
+ <entity name="rightthreetimes" value="⋌"/>
+ <entity name="RightTriangle" value="⊳"/>
+ <entity name="RightTriangleBar" value="⧐"/>
+ <entity name="RightTriangleEqual" value="⊵"/>
+ <entity name="RightUpDownVector" value="⥏"/>
+ <entity name="RightUpTeeVector" value="⥜"/>
+ <entity name="RightUpVector" value="↾"/>
+ <entity name="RightUpVectorBar" value="⥔"/>
+ <entity name="RightVector" value="⇀"/>
+ <entity name="RightVectorBar" value="⥓"/>
+ <entity name="ring" value="˚"/>
+ <entity name="risingdotseq" value="≓"/>
+ <entity name="rlarr" value="⇄"/>
+ <entity name="rlhar" value="⇌"/>
+ <entity name="rmoust" value="⎱"/>
+ <entity name="rmoustache" value="⎱"/>
+ <entity name="rnmid" value="⫮"/>
+ <entity name="roang" value=""/>
+ <entity name="roarr" value="⇾"/>
+ <entity name="robrk" value="〛"/>
+ <entity name="ropar" value="〙"/>
+ <entity name="ropf" value="𝕣"/>
+ <entity name="Ropf" value="ℝ"/>
+ <entity name="roplus" value="⨮"/>
+ <entity name="rotimes" value="⨵"/>
+ <entity name="RoundImplies" value="⥰"/>
+ <entity name="rpar" value=")"/>
+ <entity name="rpargt" value="⦔"/>
+ <entity name="rppolint" value="⨒"/>
+ <entity name="rrarr" value="⇉"/>
+ <entity name="Rrightarrow" value="⇛"/>
+ <entity name="rscr" value="𝓇"/>
+ <entity name="Rscr" value="ℛ"/>
+ <entity name="rsh" value="↱"/>
+ <entity name="Rsh" value="↱"/>
+ <entity name="rsqb" value="]"/>
+ <entity name="rsquo" value="’"/>
+ <entity name="rsquor" value="’"/>
+ <entity name="rthree" value="⋌"/>
+ <entity name="rtimes" value="⋊"/>
+ <entity name="rtri" value="▹"/>
+ <entity name="rtrie" value="⊵"/>
+ <entity name="rtrif" value="▸"/>
+ <entity name="rtriltri" value="⧎"/>
+ <entity name="RuleDelayed" value="⧴"/>
+ <entity name="ruluhar" value="⥨"/>
+ <entity name="rx" value="℞"/>
+ <entity name="sacute" value="ś"/>
+ <entity name="Sacute" value="Ś"/>
+ <entity name="sc" value="≻"/>
+ <entity name="Sc" value="⪼"/>
+ <entity name="scap" value="≿"/>
+ <entity name="scaron" value="š"/>
+ <entity name="Scaron" value="Š"/>
+ <entity name="sccue" value="≽"/>
+ <entity name="sce" value="≽"/>
+ <entity name="scE" value="≾"/>
+ <entity name="scedil" value="ş"/>
+ <entity name="Scedil" value="Ş"/>
+ <entity name="scirc" value="ŝ"/>
+ <entity name="Scirc" value="Ŝ"/>
+ <entity name="scnap" value="⋩"/>
+ <entity name="scnE" value="⪶"/>
+ <entity name="scnsim" value="⋩"/>
+ <entity name="scpolint" value="⨓"/>
+ <entity name="scsim" value="≿"/>
+ <entity name="scy" value="с"/>
+ <entity name="Scy" value="С"/>
+ <entity name="sdot" value="⋅"/>
+ <entity name="sdotb" value="⊡"/>
+ <entity name="sdote" value="⩦"/>
+ <entity name="searhk" value="⤥"/>
+ <entity name="searr" value="↘"/>
+ <entity name="seArr" value="⇘"/>
+ <entity name="searrow" value="↘"/>
+ <entity name="sect" value="§"/>
+ <entity name="semi" value=";"/>
+ <entity name="seswar" value="⤩"/>
+ <entity name="setminus" value="∖"/>
+ <entity name="setmn" value="∖"/>
+ <entity name="sext" value="✶"/>
+ <entity name="sfr" value="𝔰"/>
+ <entity name="Sfr" value="𝔖"/>
+ <entity name="sharp" value="♯"/>
+ <entity name="shchcy" value="щ"/>
+ <entity name="SHCHcy" value="Щ"/>
+ <entity name="shcy" value="ш"/>
+ <entity name="SHcy" value="Ш"/>
+ <entity name="ShortDownArrow" value="⌄︀"/>
+ <entity name="ShortLeftArrow" value="←︀"/>
+ <entity name="shortmid" value="∣︀"/>
+ <entity name="shortparallel" value="∥︀"/>
+ <entity name="ShortRightArrow" value="→︀"/>
+ <entity name="ShortUpArrow" value="⌃︀"/>
+ <entity name="shy" value="­"/>
+ <entity name="sigma" value="σ"/>
+ <entity name="Sigma" value="Σ"/>
+ <entity name="sigmav" value="ς"/>
+ <entity name="sim" value="∼"/>
+ <entity name="simdot" value="⩪"/>
+ <entity name="sime" value="≃"/>
+ <entity name="simeq" value="≃"/>
+ <entity name="simg" value="⪞"/>
+ <entity name="simgE" value="⪠"/>
+ <entity name="siml" value="⪝"/>
+ <entity name="simlE" value="⪟"/>
+ <entity name="simne" value="≆"/>
+ <entity name="simplus" value="⨤"/>
+ <entity name="simrarr" value="⥲"/>
+ <entity name="slarr" value="←︀"/>
+ <entity name="SmallCircle" value="∘"/>
+ <entity name="smallsetminus" value="∖︀"/>
+ <entity name="smashp" value="⨳"/>
+ <entity name="smeparsl" value="⧤"/>
+ <entity name="smid" value="∣︀"/>
+ <entity name="smile" value="⌣"/>
+ <entity name="smt" value="⪪"/>
+ <entity name="smte" value="⪬"/>
+ <entity name="smtes" value="⪬︀"/>
+ <entity name="softcy" value="ь"/>
+ <entity name="SOFTcy" value="Ь"/>
+ <entity name="sol" value="/"/>
+ <entity name="solb" value="⧄"/>
+ <entity name="solbar" value="⌿"/>
+ <entity name="sopf" value="𝕤"/>
+ <entity name="Sopf" value="𝕊"/>
+ <entity name="spades" value="♠"/>
+ <entity name="spadesuit" value="♠"/>
+ <entity name="spar" value="∥︀"/>
+ <entity name="sqcap" value="⊓"/>
+ <entity name="sqcaps" value="⊓︀"/>
+ <entity name="sqcup" value="⊔"/>
+ <entity name="sqcups" value="⊔︀"/>
+ <entity name="Sqrt" value="√"/>
+ <entity name="sqsub" value="⊏"/>
+ <entity name="sqsube" value="⊑"/>
+ <entity name="sqsubset" value="⊏"/>
+ <entity name="sqsubseteq" value="⊑"/>
+ <entity name="sqsup" value="⊐"/>
+ <entity name="sqsupe" value="⊒"/>
+ <entity name="sqsupset" value="⊐"/>
+ <entity name="sqsupseteq" value="⊒"/>
+ <entity name="squ" value="□"/>
+ <entity name="square" value="□"/>
+ <entity name="Square" value="□"/>
+ <entity name="SquareIntersection" value="⊓"/>
+ <entity name="SquareSubset" value="⊏"/>
+ <entity name="SquareSubsetEqual" value="⊑"/>
+ <entity name="SquareSuperset" value="⊐"/>
+ <entity name="SquareSupersetEqual" value="⊒"/>
+ <entity name="SquareUnion" value="⊔"/>
+ <entity name="squarf" value="▪"/>
+ <entity name="squf" value="▪"/>
+ <entity name="srarr" value="→︀"/>
+ <entity name="sscr" value="𝓈"/>
+ <entity name="Sscr" value="𝒮"/>
+ <entity name="ssetmn" value="∖︀"/>
+ <entity name="sstarf" value="⋆"/>
+ <entity name="star" value="⋆"/>
+ <entity name="Star" value="⋆"/>
+ <entity name="starf" value="★"/>
+ <entity name="straightepsilon" value="ε"/>
+ <entity name="straightphi" value="φ"/>
+ <entity name="Sub" value="⋐"/>
+ <entity name="subdot" value="⪽"/>
+ <entity name="sube" value="⊆"/>
+ <entity name="subE" value="⊆"/>
+ <entity name="subedot" value="⫃"/>
+ <entity name="submult" value="⫁"/>
+ <entity name="subne" value="⊊"/>
+ <entity name="subnE" value="⊊"/>
+ <entity name="subplus" value="⪿"/>
+ <entity name="subrarr" value="⥹"/>
+ <entity name="subset" value="⊂"/>
+ <entity name="Subset" value="⋐"/>
+ <entity name="subseteq" value="⊆"/>
+ <entity name="subseteqq" value="⊆"/>
+ <entity name="SubsetEqual" value="⊆"/>
+ <entity name="subsetneq" value="⊊"/>
+ <entity name="subsetneqq" value="⊊"/>
+ <entity name="subsim" value="⫇"/>
+ <entity name="subsub" value="⫕"/>
+ <entity name="subsup" value="⫓"/>
+ <entity name="succ" value="≻"/>
+ <entity name="succapprox" value="≿"/>
+ <entity name="succcurlyeq" value="≽"/>
+ <entity name="Succeeds" value="≻"/>
+ <entity name="SucceedsEqual" value="≽"/>
+ <entity name="SucceedsSlantEqual" value="≽"/>
+ <entity name="SucceedsTilde" value="≿"/>
+ <entity name="succeq" value="≽"/>
+ <entity name="succnapprox" value="⋩"/>
+ <entity name="succneqq" value="⪶"/>
+ <entity name="succnsim" value="⋩"/>
+ <entity name="succsim" value="≿"/>
+ <entity name="SuchThat" value="∋"/>
+ <entity name="sum" value="∑"/>
+ <entity name="Sum" value="∑"/>
+ <entity name="sung" value="♪"/>
+ <entity name="Sup" value="⋑"/>
+ <entity name="sup1" value="¹"/>
+ <entity name="sup2" value="²"/>
+ <entity name="sup3" value="³"/>
+ <entity name="supdot" value="⪾"/>
+ <entity name="supdsub" value="⫘"/>
+ <entity name="supe" value="⊇"/>
+ <entity name="supE" value="⊇"/>
+ <entity name="supedot" value="⫄"/>
+ <entity name="Superset" value="⊃"/>
+ <entity name="SupersetEqual" value="⊇"/>
+ <entity name="suphsol" value="⊃/"/>
+ <entity name="suphsub" value="⫗"/>
+ <entity name="suplarr" value="⥻"/>
+ <entity name="supmult" value="⫂"/>
+ <entity name="supne" value="⊋"/>
+ <entity name="supnE" value="⊋"/>
+ <entity name="supplus" value="⫀"/>
+ <entity name="supset" value="⊃"/>
+ <entity name="Supset" value="⋑"/>
+ <entity name="supseteq" value="⊇"/>
+ <entity name="supseteqq" value="⊇"/>
+ <entity name="supsetneq" value="⊋"/>
+ <entity name="supsetneqq" value="⊋"/>
+ <entity name="supsim" value="⫈"/>
+ <entity name="supsub" value="⫔"/>
+ <entity name="supsup" value="⫖"/>
+ <entity name="swarhk" value="⤦"/>
+ <entity name="swarr" value="↙"/>
+ <entity name="swArr" value="⇙"/>
+ <entity name="swarrow" value="↙"/>
+ <entity name="swnwar" value="⤪"/>
+ <entity name="szlig" value="ß"/>
+ <entity name="Tab" value="	"/>
+ <entity name="target" value="⌖"/>
+ <entity name="tau" value="τ"/>
+ <entity name="tbrk" value="⎴"/>
+ <entity name="tcaron" value="ť"/>
+ <entity name="Tcaron" value="Ť"/>
+ <entity name="tcedil" value="ţ"/>
+ <entity name="Tcedil" value="Ţ"/>
+ <entity name="tcy" value="т"/>
+ <entity name="Tcy" value="Т"/>
+ <entity name="tdot" value="⃛"/>
+ <entity name="telrec" value="⌕"/>
+ <entity name="tfr" value="𝔱"/>
+ <entity name="Tfr" value="𝔗"/>
+ <entity name="there4" value="∴"/>
+ <entity name="therefore" value="∴"/>
+ <entity name="Therefore" value="∴"/>
+ <entity name="theta" value="θ"/>
+ <entity name="Theta" value="Θ"/>
+ <entity name="thetav" value="ϑ"/>
+ <entity name="thickapprox" value="≈︀"/>
+ <entity name="thicksim" value="∼︀"/>
+ <entity name="ThickSpace" value="   "/>
+ <entity name="thinsp" value=" "/>
+ <entity name="ThinSpace" value=" "/>
+ <entity name="thkap" value="≈︀"/>
+ <entity name="thksim" value="∼︀"/>
+ <entity name="thorn" value="þ"/>
+ <entity name="THORN" value="Þ"/>
+ <entity name="tilde" value="˜"/>
+ <entity name="Tilde" value="∼"/>
+ <entity name="TildeEqual" value="≃"/>
+ <entity name="TildeFullEqual" value="≅"/>
+ <entity name="TildeTilde" value="≈"/>
+ <entity name="times" value="×"/>
+ <entity name="timesb" value="⊠"/>
+ <entity name="timesbar" value="⨱"/>
+ <entity name="timesd" value="⨰"/>
+ <entity name="tint" value="∭"/>
+ <entity name="toea" value="⤨"/>
+ <entity name="top" value="⊤"/>
+ <entity name="topbot" value="⌶"/>
+ <entity name="topcir" value="⫱"/>
+ <entity name="topf" value="𝕥"/>
+ <entity name="Topf" value="𝕋"/>
+ <entity name="topfork" value="⫚"/>
+ <entity name="tosa" value="⤩"/>
+ <entity name="tprime" value="‴"/>
+ <entity name="trade" value="™"/>
+ <entity name="triangle" value="▵"/>
+ <entity name="triangledown" value="▿"/>
+ <entity name="triangleleft" value="◃"/>
+ <entity name="trianglelefteq" value="⊴"/>
+ <entity name="triangleq" value="≜"/>
+ <entity name="triangleright" value="▹"/>
+ <entity name="trianglerighteq" value="⊵"/>
+ <entity name="tridot" value="◬"/>
+ <entity name="trie" value="≜"/>
+ <entity name="triminus" value="⨺"/>
+ <entity name="TripleDot" value="⃛"/>
+ <entity name="triplus" value="⨹"/>
+ <entity name="trisb" value="⧍"/>
+ <entity name="tritime" value="⨻"/>
+ <entity name="tscr" value="𝓉"/>
+ <entity name="Tscr" value="𝒯"/>
+ <entity name="tscy" value="ц"/>
+ <entity name="TScy" value="Ц"/>
+ <entity name="tshcy" value="ћ"/>
+ <entity name="TSHcy" value="Ћ"/>
+ <entity name="tstrok" value="ŧ"/>
+ <entity name="Tstrok" value="Ŧ"/>
+ <entity name="twixt" value="≬"/>
+ <entity name="twoheadleftarrow" value="↞"/>
+ <entity name="twoheadrightarrow" value="↠"/>
+ <entity name="uacute" value="ú"/>
+ <entity name="Uacute" value="Ú"/>
+ <entity name="uarr" value="↑"/>
+ <entity name="uArr" value="⇑"/>
+ <entity name="Uarr" value="↟"/>
+ <entity name="Uarrocir" value="⥉"/>
+ <entity name="ubrcy" value="ў"/>
+ <entity name="Ubrcy" value="Ў"/>
+ <entity name="ubreve" value="ŭ"/>
+ <entity name="Ubreve" value="Ŭ"/>
+ <entity name="ucirc" value="û"/>
+ <entity name="Ucirc" value="Û"/>
+ <entity name="ucy" value="у"/>
+ <entity name="Ucy" value="У"/>
+ <entity name="udarr" value="⇅"/>
+ <entity name="udblac" value="ű"/>
+ <entity name="Udblac" value="Ű"/>
+ <entity name="udhar" value="⥮"/>
+ <entity name="ufisht" value="⥾"/>
+ <entity name="ufr" value="𝔲"/>
+ <entity name="Ufr" value="𝔘"/>
+ <entity name="ugrave" value="ù"/>
+ <entity name="Ugrave" value="Ù"/>
+ <entity name="uHar" value="⥣"/>
+ <entity name="uharl" value="↿"/>
+ <entity name="uharr" value="↾"/>
+ <entity name="uhblk" value="▀"/>
+ <entity name="ulcorn" value="⌜"/>
+ <entity name="ulcorner" value="⌜"/>
+ <entity name="ulcrop" value="⌏"/>
+ <entity name="ultri" value="◸"/>
+ <entity name="umacr" value="ū"/>
+ <entity name="Umacr" value="Ū"/>
+ <entity name="uml" value="¨"/>
+ <entity name="UnderBar" value="̲"/>
+ <entity name="UnderBrace" value="︸"/>
+ <entity name="UnderBracket" value="⎵"/>
+ <entity name="UnderParenthesis" value="︶"/>
+ <entity name="Union" value="⋃"/>
+ <entity name="UnionPlus" value="⊎"/>
+ <entity name="uogon" value="ų"/>
+ <entity name="Uogon" value="Ų"/>
+ <entity name="uopf" value="𝕦"/>
+ <entity name="Uopf" value="𝕌"/>
+ <entity name="uparrow" value="↑"/>
+ <entity name="Uparrow" value="⇑"/>
+ <entity name="UpArrow" value="↑"/>
+ <entity name="UpArrowBar" value="⤒"/>
+ <entity name="UpArrowDownArrow" value="⇅"/>
+ <entity name="updownarrow" value="↕"/>
+ <entity name="Updownarrow" value="⇕"/>
+ <entity name="UpDownArrow" value="↕"/>
+ <entity name="UpEquilibrium" value="⥮"/>
+ <entity name="upharpoonleft" value="↿"/>
+ <entity name="upharpoonright" value="↾"/>
+ <entity name="uplus" value="⊎"/>
+ <entity name="UpperLeftArrow" value="↖"/>
+ <entity name="UpperRightArrow" value="↗"/>
+ <entity name="upsi" value="υ"/>
+ <entity name="Upsi" value="ϒ"/>
+ <entity name="upsilon" value="υ"/>
+ <entity name="Upsilon" value="ϒ"/>
+ <entity name="UpTee" value="⊥"/>
+ <entity name="UpTeeArrow" value="↥"/>
+ <entity name="upuparrows" value="⇈"/>
+ <entity name="urcorn" value="⌝"/>
+ <entity name="urcorner" value="⌝"/>
+ <entity name="urcrop" value="⌎"/>
+ <entity name="uring" value="ů"/>
+ <entity name="Uring" value="Ů"/>
+ <entity name="urtri" value="◹"/>
+ <entity name="uscr" value="𝓊"/>
+ <entity name="Uscr" value="𝒰"/>
+ <entity name="utdot" value="⋰"/>
+ <entity name="utilde" value="ũ"/>
+ <entity name="Utilde" value="Ũ"/>
+ <entity name="utri" value="▵"/>
+ <entity name="utrif" value="▴"/>
+ <entity name="uuarr" value="⇈"/>
+ <entity name="uuml" value="ü"/>
+ <entity name="Uuml" value="Ü"/>
+ <entity name="uwangle" value="⦧"/>
+ <entity name="vangrt" value="⊾"/>
+ <entity name="varepsilon" value="ɛ"/>
+ <entity name="varkappa" value="ϰ"/>
+ <entity name="varnothing" value="∅"/>
+ <entity name="varphi" value="ϕ"/>
+ <entity name="varpi" value="ϖ"/>
+ <entity name="varpropto" value="∝"/>
+ <entity name="varr" value="↕"/>
+ <entity name="vArr" value="⇕"/>
+ <entity name="varrho" value="ϱ"/>
+ <entity name="varsigma" value="ς"/>
+ <entity name="varsubsetneq" value="⊊︀"/>
+ <entity name="varsubsetneqq" value="⊊︀"/>
+ <entity name="varsupsetneq" value="⊋︀"/>
+ <entity name="varsupsetneqq" value="⊋︀"/>
+ <entity name="vartheta" value="ϑ"/>
+ <entity name="vartriangleleft" value="⊲"/>
+ <entity name="vartriangleright" value="⊳"/>
+ <entity name="vBar" value="⫨"/>
+ <entity name="Vbar" value="⫫"/>
+ <entity name="vBarv" value="⫩"/>
+ <entity name="vcy" value="в"/>
+ <entity name="Vcy" value="В"/>
+ <entity name="vdash" value="⊢"/>
+ <entity name="vDash" value="⊨"/>
+ <entity name="Vdash" value="⊩"/>
+ <entity name="VDash" value="⊫"/>
+ <entity name="Vdashl" value="⫦"/>
+ <entity name="vee" value="∨"/>
+ <entity name="Vee" value="⋁"/>
+ <entity name="veebar" value="⊻"/>
+ <entity name="veeeq" value="≚"/>
+ <entity name="vellip" value="⋮"/>
+ <entity name="verbar" value="|"/>
+ <entity name="Verbar" value="‖"/>
+ <entity name="vert" value="|"/>
+ <entity name="Vert" value="‖"/>
+ <entity name="VerticalBar" value="∣"/>
+ <entity name="VerticalLine" value="|"/>
+ <entity name="VerticalSeparator" value="❘"/>
+ <entity name="VerticalTilde" value="≀"/>
+ <entity name="VeryThinSpace" value=" "/>
+ <entity name="vfr" value="𝔳"/>
+ <entity name="Vfr" value="𝔙"/>
+ <entity name="vltri" value="⊲"/>
+ <entity name="vnsub" value="⊄"/>
+ <entity name="vnsup" value="⊅"/>
+ <entity name="vopf" value="𝕧"/>
+ <entity name="Vopf" value="𝕍"/>
+ <entity name="vprop" value="∝"/>
+ <entity name="vrtri" value="⊳"/>
+ <entity name="vscr" value="𝓋"/>
+ <entity name="Vscr" value="𝒱"/>
+ <entity name="vsubne" value="⊊︀"/>
+ <entity name="vsubnE" value="⊊︀"/>
+ <entity name="vsupne" value="⊋︀"/>
+ <entity name="vsupnE" value="⊋︀"/>
+ <entity name="Vvdash" value="⊪"/>
+ <entity name="vzigzag" value="⦚"/>
+ <entity name="wcirc" value="ŵ"/>
+ <entity name="Wcirc" value="Ŵ"/>
+ <entity name="wedbar" value="⩟"/>
+ <entity name="wedge" value="∧"/>
+ <entity name="Wedge" value="⋀"/>
+ <entity name="wedgeq" value="≙"/>
+ <entity name="weierp" value="℘"/>
+ <entity name="wfr" value="𝔴"/>
+ <entity name="Wfr" value="𝔚"/>
+ <entity name="wopf" value="𝕨"/>
+ <entity name="Wopf" value="𝕎"/>
+ <entity name="wp" value="℘"/>
+ <entity name="wr" value="≀"/>
+ <entity name="wreath" value="≀"/>
+ <entity name="wscr" value="𝓌"/>
+ <entity name="Wscr" value="𝒲"/>
+ <entity name="xcap" value="⋂"/>
+ <entity name="xcirc" value="◯"/>
+ <entity name="xcup" value="⋃"/>
+ <entity name="xdtri" value="▽"/>
+ <entity name="xfr" value="𝔵"/>
+ <entity name="Xfr" value="𝔛"/>
+ <entity name="xharr" value=""/>
+ <entity name="xhArr" value=""/>
+ <entity name="xi" value="ξ"/>
+ <entity name="Xi" value="Ξ"/>
+ <entity name="xlarr" value=""/>
+ <entity name="xlArr" value=""/>
+ <entity name="xmap" value=""/>
+ <entity name="xnis" value="⋻"/>
+ <entity name="xodot" value="⊙"/>
+ <entity name="xopf" value="𝕩"/>
+ <entity name="Xopf" value="𝕏"/>
+ <entity name="xoplus" value="⊕"/>
+ <entity name="xotime" value="⊗"/>
+ <entity name="xrarr" value=""/>
+ <entity name="xrArr" value=""/>
+ <entity name="xscr" value="𝓍"/>
+ <entity name="Xscr" value="𝒳"/>
+ <entity name="xsqcup" value="⊔"/>
+ <entity name="xuplus" value="⊎"/>
+ <entity name="xutri" value="△"/>
+ <entity name="xvee" value="⋁"/>
+ <entity name="xwedge" value="⋀"/>
+ <entity name="yacute" value="ý"/>
+ <entity name="Yacute" value="Ý"/>
+ <entity name="yacy" value="я"/>
+ <entity name="YAcy" value="Я"/>
+ <entity name="ycirc" value="ŷ"/>
+ <entity name="Ycirc" value="Ŷ"/>
+ <entity name="ycy" value="ы"/>
+ <entity name="Ycy" value="Ы"/>
+ <entity name="yen" value="¥"/>
+ <entity name="yfr" value="𝔶"/>
+ <entity name="Yfr" value="𝔜"/>
+ <entity name="yicy" value="ї"/>
+ <entity name="YIcy" value="Ї"/>
+ <entity name="yopf" value="𝕪"/>
+ <entity name="Yopf" value="𝕐"/>
+ <entity name="yscr" value="𝓎"/>
+ <entity name="Yscr" value="𝒴"/>
+ <entity name="yucy" value="ю"/>
+ <entity name="YUcy" value="Ю"/>
+ <entity name="yuml" value="ÿ"/>
+ <entity name="Yuml" value="Ÿ"/>
+ <entity name="zacute" value="ź"/>
+ <entity name="Zacute" value="Ź"/>
+ <entity name="zcaron" value="ž"/>
+ <entity name="Zcaron" value="Ž"/>
+ <entity name="zcy" value="з"/>
+ <entity name="Zcy" value="З"/>
+ <entity name="zdot" value="ż"/>
+ <entity name="Zdot" value="Ż"/>
+ <entity name="zeetrf" value="ℨ"/>
+ <entity name="ZeroWidthSpace" value="​"/>
+ <entity name="zeta" value="ζ"/>
+ <entity name="zfr" value="𝔷"/>
+ <entity name="Zfr" value="ℨ"/>
+ <entity name="zhcy" value="ж"/>
+ <entity name="ZHcy" value="Ж"/>
+ <entity name="zigrarr" value="⇝"/>
+ <entity name="zopf" value="𝕫"/>
+ <entity name="Zopf" value="ℤ"/>
+ <entity name="zscr" value="𝓏"/>
+ <entity name="Zscr" value="𝒵"/>
+</entities-table>
--- /dev/null
+<?xml version="1.0"?>
+
+<entities-table>
+ <entity name="def" value="≝"/> <!-- ≝ -->
+ <entity name="neq" value="≠"/> <!-- ≠ -->
+ <entity name="leq" value="≤"/> <!-- ≤ -->
+ <entity name="geq" value="≥"/> <!-- ≥ -->
+ <entity name="nleq" value="≰"/> <!-- ≰ -->
+ <entity name="ngeq" value="≱"/> <!-- ≱ -->
+ <entity name="to" value="→"/> <!-- → -->
+ <entity name="divides" value="∣"/> <!-- ∣ -->
+ <entity name="ndivides" value="∤"/> <!-- ∤ -->
+ <entity name="circ" value="∘"/> <!-- ∤ -->
+</entities-table>
+
+<!-- vim: set encoding=utf8: -->
--- /dev/null
+(* 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 ()
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* $Id$ *)
+
+prerr_endline <:unicode<lambda>>
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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"
--- /dev/null
+whelp.cmo: whelp.cmi
+whelp.cmx: whelp.cmi
+fwdQueries.cmo: fwdQueries.cmi
+fwdQueries.cmx: fwdQueries.cmi
--- /dev/null
+PACKAGE = whelp
+
+INTERFACE_FILES = \
+ whelp.mli \
+ fwdQueries.mli \
+ $(NULL)
+
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+xml.cmo: xml.cmi
+xml.cmx: xml.cmi
+xmlPushParser.cmo: xmlPushParser.cmi
+xmlPushParser.cmx: xmlPushParser.cmi
--- /dev/null
+PACKAGE = xml
+PREDICATES =
+
+INTERFACE_FILES = \
+ xml.mli \
+ xmlPushParser.mli
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+EXTRA_OBJECTS_TO_INSTALL =
+EXTRA_OBJECTS_TO_CLEAN =
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* $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*)
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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
+
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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))
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+xmlDiff.cmo: xmlDiff.cmi
+xmlDiff.cmx: xmlDiff.cmi
--- /dev/null
+PACKAGE = xmldiff
+PREDICATES =
+
+INTERFACE_FILES = xmlDiff.mli
+IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
+EXTRA_OBJECTS_TO_INSTALL =
+EXTRA_OBJECTS_TO_CLEAN =
+
+include ../../Makefile.defs
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* $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
+;;
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val 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
--- /dev/null
+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
--- /dev/null
+(* 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 ()
+;;
--- /dev/null
+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>
--- /dev/null
+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/
--- /dev/null
+export SHELL=/bin/bash
+
+include ../Makefile.defs
+
+NULL =
+H=@
+
+OCAML_FLAGS = -pp $(CAMLP4O)
+PKGS = -package "$(MATITA_REQUIRES)"
+CPKGS = -package "$(MATITA_CREQUIRES)"
+OCAML_THREADS_FLAGS = -thread
+OCAML_DEBUG_FLAGS = -g
+OCAMLC_FLAGS = $(OCAML_FLAGS) $(OCAML_THREADS_FLAGS)
+OCAMLC = $(OCAMLFIND) ocamlc $(OCAMLC_FLAGS) $(OCAML_DEBUG_FLAGS)
+OCAMLOPT = $(OCAMLFIND) opt $(OCAMLC_FLAGS)
+OCAMLDEP = $(OCAMLFIND) ocamldep $(OCAML_FLAGS)
+
+MATITA_FLAGS = -noprofile
+NODB=false
+ifeq ($(NODB),true)
+ MATITA_FLAGS += -nodb
+endif
+
+# objects for matita (GTK GUI)
+CMOS = \
+ buildTimeConf.cmo \
+ matitaTypes.cmo \
+ matitaMisc.cmo \
+ matitamakeLib.cmo \
+ matitaInit.cmo \
+ matitaExcPp.cmo \
+ matitaEngine.cmo \
+ matitacLib.cmo \
+ matitaScript.cmo \
+ matitaGeneratedGui.cmo \
+ matitaGtkMisc.cmo \
+ applyTransformation.cmo \
+ matitaMathView.cmo \
+ matitaGui.cmo \
+ $(NULL)
+# objects for matitac (batch compiler)
+CCMOS = \
+ buildTimeConf.cmo \
+ matitaTypes.cmo \
+ matitaMisc.cmo \
+ matitamakeLib.cmo \
+ matitaInit.cmo \
+ matitaExcPp.cmo \
+ matitaEngine.cmo \
+ matitacLib.cmo \
+ $(NULL)
+MAINCMOS = \
+ matitadep.cmo \
+ matitaclean.cmo \
+ matitamake.cmo \
+ $(NULL)
+PROGRAMS_BYTE = matita matitac cicbrowser matitadep matitaclean matitamake dump_moo
+PROGRAMS = $(PROGRAMS_BYTE) matitatop
+PROGRAMS_OPT = $(patsubst %,%.opt,$(PROGRAMS_BYTE))
+
+.PHONY: all
+all: $(PROGRAMS)
+# all: matita.conf.xml $(PROGRAMS) coq.moo
+
+# matita.conf.xml: matita.conf.xml.sample
+# @if diff matita.conf.xml.sample matita.conf.xml 1>/dev/null 2>/dev/null; then\
+# touch matita.conf.xml;\
+# else\
+# echo;\
+# echo "matita.conf.xml.sample is newer than matita.conf.xml";\
+# echo;\
+# echo "PLEASE update your configuration file!";\
+# echo "(copying matita.conf.xml.sample should work)";\
+# echo;\
+# false;\
+# fi
+
+# coq.moo: library/legacy/coq.ma matitac
+# ./matitac $(MATITA_FLAGS) $<
+# coq.moo.opt: library/legacy/coq.ma matitac.opt
+# ./matitac.opt $(MATITA_FLAGS) $<
+
+ifeq ($(HAVE_OCAMLOPT),yes)
+
+CMXS = $(patsubst %.cmo,%.cmx,$(CMOS))
+CCMXS = $(patsubst %.cmo,%.cmx,$(CCMOS))
+MAINCMXS = $(patsubst %.cmo,%.cmx,$(MAINCMOS))
+LIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(MATITA_REQUIRES))
+LIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(MATITA_REQUIRES))
+CLIB_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "byte" -format "%d/%a" $(MATITA_CREQUIRES))
+CLIBX_DEPS := $(shell $(OCAMLFIND) query -recursive -predicates "native" -format "%d/%a" $(MATITA_CREQUIRES))
+.PHONY: opt
+opt: $(PROGRAMS_OPT) coq.moo.opt
+.PHONY: upx
+upx: $(PROGRAMS_UPX) coq.moo.opt
+
+else
+
+opt:
+ @echo "Native code compilation is disabled"
+
+endif
+
+matita: matita.ml $(LIB_DEPS) $(CMOS)
+ @echo "OCAMLC $<"
+ $(H)$(OCAMLC) $(PKGS) -linkpkg -o $@ $(CMOS) matita.ml
+matita.opt: matita.ml $(LIBX_DEPS) $(CMXS)
+ @echo "OCAMLOPT $<"
+ $(H)$(OCAMLOPT) $(PKGS) -linkpkg -o $@ $(CMXS) matita.ml
+
+dump_moo: dump_moo.ml buildTimeConf.cmo
+ @echo "OCAMLC $<"
+ $(H)$(OCAMLC) $(PKGS) -linkpkg -o $@ buildTimeConf.cmo $<
+dump_moo.opt: dump_moo.ml buildTimeConf.cmx
+ @echo "OCAMLOPT $<"
+ $(H)$(OCAMLOPT) $(PKGS) -linkpkg -o $@ buildTimeConf.cmx $<
+
+matitac: matitac.ml $(CLIB_DEPS) $(CCMOS) $(MAINCMOS)
+ @echo "OCAMLC $<"
+ $(H)$(OCAMLC) $(CPKGS) -linkpkg -o $@ $(CCMOS) $(MAINCMOS) matitac.ml
+matitac.opt: matitac.ml $(CLIBX_DEPS) $(CCMXS) $(MAINCMXS)
+ @echo "OCAMLOPT $<"
+ $(H)$(OCAMLOPT) $(CPKGS) -linkpkg -o $@ $(CCMXS) $(MAINCMXS) matitac.ml
+
+matitatop: matitatop.ml $(CLIB_DEPS) $(CCMOS)
+ @echo "OCAMLC $<"
+ $(H)$(OCAMLC) $(CPKGS) -linkpkg -o $@ toplevellib.cma $(CCMOS) $<
+
+matitadep: matitac
+ @test -f $@ || ln -s $< $@
+matitadep.opt: matitac.opt
+ @test -f $@ || ln -s $< $@
+
+matitaclean: matitac
+ @test -f $@ || ln -s $< $@
+matitaclean.opt: matitac.opt
+ @test -f $@ || ln -s $< $@
+
+matitamake: matitac
+ @test -f $@ || ln -s $< $@
+matitamake.opt: matitac.opt
+ @test -f $@ || ln -s $< $@
+
+cicbrowser: matita
+ @test -f $@ || ln -s $< $@
+cicbrowser.opt: matita.opt
+ @test -f $@ || ln -s $< $@
+
+matitaGeneratedGui.ml matitaGeneratedGui.mli: matita.glade
+ $(LABLGLADECC) -embed $< > matitaGeneratedGui.ml
+ $(OCAMLC) $(PKGS) -i matitaGeneratedGui.ml > matitaGeneratedGui.mli
+
+.PHONY: clean
+clean:
+ rm -rf *.cma *.cmo *.cmi *.cmx *.cmxa *.a *.o \
+ $(PROGRAMS) \
+ $(PROGRAMS_OPT) \
+ $(PROGRAMS_STATIC) \
+ $(PROGRAMS_UPX) \
+ $(NULL)
+
+TEST_DIRS = \
+ library \
+ tests \
+ tests/bad_tests \
+ contribs/LAMBDA-TYPES \
+ contribs/PREDICATIVE-TOPOLOGY \
+ $(NULL)
+
+.PHONY: tests tests.opt cleantests cleantests.opt
+tests: $(foreach d,$(TEST_DIRS),$(d)-test)
+tests.opt: $(foreach d,$(TEST_DIRS),$(d)-test-opt)
+cleantests: $(foreach d,$(TEST_DIRS),$(d)-cleantests)
+cleantests.opt: $(foreach d,$(TEST_DIRS),$(d)-cleantests-opt)
+
+%-test: matitac matitadep matitaclean coq.moo
+ -cd $* && make -k clean all
+%-test-opt: matitac.opt matitadep.opt matitaclean.opt coq.moo.opt
+ -cd $* && make -k clean.opt opt
+%-cleantests: matitaclean
+ -cd $* && make clean
+%-cleantests-opt: matitaclean.opt
+ -cd $* && make clean.opt
+
+# {{{ Distribution stuff
+
+ifeq ($(wildcard matitac.opt),matitac.opt)
+BEST=opt
+else
+BEST=all
+endif
+
+stdlib:
+ MATITA_RT_BASE_DIR=`pwd` \
+ MATITA_FLAGS="-system -conffile `pwd`/matita.conf.xml.build" \
+ ./matitamake -init build_stdlib
+
+# MATITA_RT_BASE_DIR=`pwd` \
+ $(MAKE) MATITA_FLAGS="-system -conffile `pwd`/matita.conf.xml.build" -C library/ $(BEST)
+
+DEST = @RT_BASE_DIR@
+INSTALL_STUFF = \
+ icons/ \
+ matita.gtkrc \
+ matita.lang \
+ matita.ma.templ \
+ core_notation.moo \
+ matita.conf.xml \
+ closed.xml \
+ gtkmathview.matita.conf.xml \
+ template_makefile.in \
+ library/ \
+ $(PROGRAMS_BYTE) \
+ $(NULL)
+ifeq ($(HAVE_OCAMLOPT),yes)
+INSTALL_STUFF += $(PROGRAMS_OPT)
+endif
+
+install:
+ install -d $(DEST)
+ cp -a .matita/
+ cp -a $(INSTALL_STUFF) $(DEST)
+uninstall:
+
+STATIC_LINK = dist/static_link/static_link
+# for matita
+STATIC_LIBS = \
+ t1 t1x \
+ gtkmathview_gmetadom mathview mathview_backend_gtk mathview_frontend_gmetadom \
+ gtksourceview-1.0 \
+ gdome gmetadom_gdome_cpp_smart \
+ stdc++ \
+ mysqlclient \
+ expat \
+ $(NULL)
+STATIC_EXTRA_LIBS = -cclib -lt1x -cclib -lstdc++
+# for matitac & co
+STATIC_CLIBS = \
+ gdome \
+ mysqlclient \
+ $(NULL)
+STATIC_EXTRA_CLIBS =
+PROGRAMS_STATIC = $(patsubst %,%.static,$(PROGRAMS_OPT))
+PROGRAMS_UPX = $(patsubst %,%.upx,$(PROGRAMS_STATIC))
+
+ifeq ($(HAVE_OCAMLOPT),yes)
+static: $(STATIC_LINK) $(PROGRAMS_STATIC) coq.moo.opt
+else
+upx:
+ @echo "Native code compilation is disabled"
+static:
+ @echo "Native code compilation is disabled"
+endif
+
+$(STATIC_LINK):
+ $(MAKE) -C dist/ $(STATIC_LINK)
+
+matita.opt.static: $(STATIC_LINK) $(LIBX_DEPS) $(CMXS) matita.ml
+ $(STATIC_LINK) $(STATIC_LIBS) -- \
+ $(OCAMLOPT) $(PKGS) -linkpkg -o $@ $(CMXS) matita.ml \
+ $(STATIC_EXTRA_LIBS)
+ strip $@
+dump_moo.opt.static: $(STATIC_LINK) buildTimeConf.cmx dump_moo.ml
+ $(STATIC_LINK) $(STATIC_CLIBS) -- \
+ $(OCAMLOPT) $(PKGS) -linkpkg -o $@ $^ \
+ $(STATIC_EXTRA_CLIBS)
+ strip $@
+matitac.opt.static: $(STATIC_LINK) $(CLIBX_DEPS) $(CCMXS) $(MAINCMXS) matitac.ml
+ $(STATIC_LINK) $(STATIC_CLIBS) -- \
+ $(OCAMLOPT) $(CPKGS) -linkpkg -o $@ $(CCMXS) $(MAINCMXS) matitac.ml \
+ $(STATIC_EXTRA_CLIBS)
+ strip $@
+matitadep.opt.static: matitac.opt.static
+ @test -f $@ || ln -s $< $@
+matitaclean.opt.static: matitac.opt.static
+ @test -f $@ || ln -s $< $@
+matitamake.opt.static: matitac.opt.static
+ @test -f $@ || ln -s $< $@
+cicbrowser.opt.static: matita.opt.static
+ @test -f $@ || ln -s $< $@
+cicbrowser.opt.static.upx: matita.opt.static.upx
+ @test -f $@ || ln -s $< $@
+
+.PHONY: distclean
+distclean: clean
+ $(MAKE) -C dist/ clean
+ rm -f matitaGeneratedGui.ml matitaGeneratedGui.mli
+ rm -f buildTimeConf.ml
+ rm -f matita.glade.bak matita.gladep.bak
+ rm -f matita.conf.xml.sample
+
+%.upx: %
+ cp $< $@
+ strip $@
+ upx $@
+
+# }}} End of distribution stuff
+
+tags: TAGS
+.PHONY: TAGS
+TAGS:
+ cd ..; otags -vi -r ocaml/ matita/
+
+#.depend: matitaGeneratedGui.ml matitaGeneratedGui.mli *.ml *.mli
+
+.PHONY: depend
+depend:
+ $(OCAMLDEP) *.ml *.mli > .depend
+
+include .depend
+
+%.cmi: %.mli
+ @echo "OCAMLC $<"
+ $(H)$(OCAMLC) $(PKGS) -c $<
+%.cmo %.cmi: %.ml
+ @echo "OCAMLC $<"
+ $(H)$(OCAMLC) $(PKGS) -c $<
+%.cmx: %.ml
+ @echo "OCAMLOPT $<"
+ $(H)$(OCAMLOPT) $(PKGS) -c $<
+%.annot: %.ml
+ @echo "OCAMLC -dtypes $<"
+ $(H)$(OCAMLC) -dtypes $(PKGS) -c $<
+
+$(CMOS): $(LIB_DEPS)
+$(CMOS:%.cmo=%.cmx): $(LIBX_DEPS)
+
+ifeq ($(MAKECMDGOALS),all)
+ $(CMOS:%.cmo=%.cmi): $(LIB_DEPS)
+endif
+ifeq ($(MAKECMDGOALS),)
+ $(CMOS:%.cmo=%.cmi): $(LIB_DEPS)
+endif
+ifeq ($(MAKECMDGOALS),opt)
+ $(CMOS:%.cmo=%.cmi): $(LIBX_DEPS)
+endif
+
+# vim: set foldmethod=marker:
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(***************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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)))
+
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(***************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* 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 *)
+
--- /dev/null
+(* Copyright (C) 2004, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+let debug = @DEBUG@;;
+let version = "@MATITA_VERSION@";;
+let undo_history_size = 10;;
+let console_history_size = 100;;
+let browser_history_size = 100;;
+let base_uri = "cic:/matita";;
+let phrase_sep = ".";;
+let blank_uri = "about:blank";;
+let current_proof_uri = "about:current_proof";;
+let default_font_size = 10;;
+let script_font = "Monospace";;
+
+ (** may be overridden with MATITA_RT_BASE_DIR environment variable, useful for
+ * binary distribution installed in user home directories *)
+let runtime_base_dir =
+ try
+ Sys.getenv "MATITA_RT_BASE_DIR"
+ with Not_found -> "@RT_BASE_DIR@";;
+
+let images_dir = runtime_base_dir ^ "/icons"
+let gtkrc_file = runtime_base_dir ^ "/matita.gtkrc"
+let lang_file = runtime_base_dir ^ "/matita.lang"
+let script_template = runtime_base_dir ^ "/matita.ma.templ"
+let core_notation_script = runtime_base_dir ^ "/core_notation.moo"
+let matita_conf = runtime_base_dir ^ "/matita.conf.xml"
+let closed_xml = runtime_base_dir ^ "/closed.xml"
+let gtkmathview_conf = runtime_base_dir ^ "/gtkmathview.matita.conf.xml"
+let matitamake_makefile_template = runtime_base_dir ^ "/template_makefile.in"
+let stdlib_dir = runtime_base_dir ^ "/library"
+
--- /dev/null
+(* Copyright (C) 2006, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+val base_uri : string
+val blank_uri : string
+val browser_history_size : int
+val closed_xml : string
+val console_history_size : int
+val core_notation_script : string
+val current_proof_uri : string
+val debug : bool
+val default_font_size : int
+val gtkmathview_conf : string
+val gtkrc_file : string
+val images_dir : string
+val lang_file : string
+val matita_conf : string
+val matitamake_makefile_template : string
+val phrase_sep : string
+val runtime_base_dir : string
+val script_font : string
+val script_template : string
+val stdlib_dir : string
+val undo_history_size : int
+val version : string
+
--- /dev/null
+<?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>
--- /dev/null
+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
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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))).
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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
+}.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+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
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
+
+
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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 [].
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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}}}.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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 }.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+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 }.
--- /dev/null
+<?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>
--- /dev/null
+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 $< > $@
--- /dev/null
+#!/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
+
--- /dev/null
+all: static_link
+static_link: static_link.ml
+ ocamlfind ocamlc -package unix,str -linkpkg -o $@ $<
+clean:
+ rm -f static_link.cm* static_link
--- /dev/null
+
+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 ()
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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)
+
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+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
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* __ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||M|| *)
+(* ||A|| A project by Andrea Asperti *)
+(* ||T|| *)
+(* ||I|| Developers: *)
+(* ||T|| The HELM team. *)
+(* ||A|| http://helm.cs.unibo.it *)
+(* \ / *)
+(* \ / This file is distributed under the terms of the *)
+(* v GNU General Public License Version 2 *)
+(* *)
+(**************************************************************************)
+
+set "baseuri" "cic:/matita/algebra/groups/".
+
+include "algebra/monoids.ma".
+include "nat/le_arith.ma".
+include "datatypes/bool.ma".
+include "nat/compare.ma".
+
+record PreGroup : Type ≝
+ { premonoid:> PreMonoid;
+ opp: premonoid -> premonoid
+ }.
+
+record isGroup (G:PreGroup) : Prop ≝
+ { is_monoid: isMonoid G;
+ opp_is_left_inverse: is_left_inverse (mk_Monoid ? is_monoid) (opp G);
+ opp_is_right_inverse: is_right_inverse (mk_Monoid ? is_monoid) (opp G)
+ }.
+
+record Group : Type ≝
+ { pregroup:> PreGroup;
+ group_properties:> isGroup pregroup
+ }.
+
+(*notation < "G"
+for @{ 'monoid $G }.
+
+interpretation "Monoid coercion" 'monoid G =
+ (cic:/matita/algebra/groups/monoid.con G).*)
+
+notation < "G"
+for @{ 'type_of_group $G }.
+
+interpretation "Type_of_group coercion" 'type_of_group G =
+ (cic:/matita/algebra/groups/Type_of_Group.con G).
+
+notation < "G"
+for @{ 'magma_of_group $G }.
+
+interpretation "magma_of_group coercion" 'magma_of_group G =
+ (cic:/matita/algebra/groups/Magma_of_Group.con G).
+
+notation "hvbox(x \sup (-1))" with precedence 89
+for @{ 'gopp $x }.
+
+interpretation "Group inverse" 'gopp x =
+ (cic:/matita/algebra/groups/opp.con _ x).
+
+definition left_cancellable ≝
+ λT:Type. λop: T -> T -> T.
+ ∀x. injective ? ? (op x).
+
+definition right_cancellable ≝
+ λT:Type. λop: T -> T -> T.
+ ∀x. injective ? ? (λz.op z x).
+
+theorem eq_op_x_y_op_x_z_to_eq:
+ ∀G:Group. left_cancellable G (op G).
+intros;
+unfold left_cancellable;
+unfold injective;
+intros (x y z);
+rewrite < (e_is_left_unit ? (is_monoid ? (group_properties G)));
+rewrite < (e_is_left_unit ? (is_monoid ? (group_properties G)) z);
+rewrite < (opp_is_left_inverse ? (group_properties G) x);
+rewrite > (associative ? (is_semi_group ? (is_monoid ? (group_properties G))));
+rewrite > (associative ? (is_semi_group ? (is_monoid ? (group_properties G))));
+apply eq_f;
+assumption.
+qed.
+
+
+theorem eq_op_x_y_op_z_y_to_eq:
+ ∀G:Group. right_cancellable G (op G).
+intros;
+unfold right_cancellable;
+unfold injective;
+simplify;fold simplify (op G);
+intros (x y z);
+rewrite < (e_is_right_unit ? (is_monoid ? (group_properties G)));
+rewrite < (e_is_right_unit ? (is_monoid ? (group_properties G)) z);
+rewrite < (opp_is_right_inverse ? (group_properties G) x);
+rewrite < (associative ? (is_semi_group ? (is_monoid ? (group_properties G))));
+rewrite < (associative ? (is_semi_group ? (is_monoid ? (group_properties G))));
+rewrite > H;
+reflexivity.
+qed.
+
+
+record finite_enumerable (T:Type) : Type ≝
+ { order: nat;
+ repr: nat → T;
+ index_of: T → nat;
+ index_of_sur: ∀x.index_of x ≤ order;
+ index_of_repr: ∀n. n≤order → index_of (repr n) = n;
+ repr_index_of: ∀x. repr (index_of x) = x
+ }.
+
+notation "hvbox(C \sub i)" with precedence 89
+for @{ 'repr $C $i }.
+
+(* CSC: multiple interpretations in the same file are not considered in the
+ right order
+interpretation "Finite_enumerable representation" 'repr C i =
+ (cic:/matita/algebra/groups/repr.con C _ i).*)
+
+notation < "hvbox(|C|)" with precedence 89
+for @{ 'card $C }.
+
+interpretation "Finite_enumerable order" 'card C =
+ (cic:/matita/algebra/groups/order.con C _).
+
+record finite_enumerable_SemiGroup : Type ≝
+ { semigroup:> SemiGroup;
+ is_finite_enumerable:> finite_enumerable semigroup
+ }.
+
+notation < "S"
+for @{ 'semigroup_of_finite_enumerable_semigroup $S }.
+
+interpretation "Semigroup_of_finite_enumerable_semigroup"
+ 'semigroup_of_finite_enumerable_semigroup S
+=
+ (cic:/matita/algebra/groups/semigroup.con S).
+
+notation < "S"
+for @{ 'magma_of_finite_enumerable_semigroup $S }.
+
+interpretation "Magma_of_finite_enumerable_semigroup"
+ 'magma_of_finite_enumerable_semigroup S
+=
+ (cic:/matita/algebra/groups/Magma_of_finite_enumerable_SemiGroup.con S).
+
+notation < "S"
+for @{ 'type_of_finite_enumerable_semigroup $S }.
+
+interpretation "Type_of_finite_enumerable_semigroup"
+ 'type_of_finite_enumerable_semigroup S
+=
+ (cic:/matita/algebra/groups/Type_of_finite_enumerable_SemiGroup.con S).
+
+interpretation "Finite_enumerable representation" 'repr S i =
+ (cic:/matita/algebra/groups/repr.con S
+ (cic:/matita/algebra/groups/is_finite_enumerable.con S) i).
+
+notation "hvbox(ι e)" with precedence 60
+for @{ 'index_of_finite_enumerable_semigroup $e }.
+
+interpretation "Index_of_finite_enumerable representation"
+ 'index_of_finite_enumerable_semigroup e
+=
+ (cic:/matita/algebra/groups/index_of.con _
+ (cic:/matita/algebra/groups/is_finite_enumerable.con _) e).
+
+
+(* several definitions/theorems to be moved somewhere else *)
+
+definition ltb ≝ λn,m. leb n m ∧ notb (eqb n m).
+
+theorem not_eq_to_le_to_lt: ∀n,m. n≠m → n≤m → n<m.
+intros;
+elim (le_to_or_lt_eq ? ? H1);
+[ assumption
+| elim (H H2)
+].
+qed.
+
+theorem ltb_to_Prop :
+ ∀n,m.
+ match ltb n m with
+ [ true ⇒ n < m
+ | false ⇒ n ≮ m
+ ].
+intros;
+unfold ltb;
+apply leb_elim;
+apply eqb_elim;
+intros;
+simplify;
+[ rewrite < H;
+ apply le_to_not_lt;
+ constructor 1
+| apply (not_eq_to_le_to_lt ? ? H H1)
+| rewrite < H;
+ apply le_to_not_lt;
+ constructor 1
+| apply le_to_not_lt;
+ generalize in match (not_le_to_lt ? ? H1);
+ clear H1;
+ intro;
+ apply lt_to_le;
+ assumption
+].
+qed.
+
+theorem ltb_elim: \forall n,m:nat. \forall P:bool \to Prop.
+(n < m \to (P true)) \to (n ≮ m \to (P false)) \to
+P (ltb n m).
+intros.
+cut
+(match (ltb n m) with
+[ true \Rightarrow n < m
+| false \Rightarrow n ≮ m] \to (P (ltb n m))).
+apply Hcut.apply ltb_to_Prop.
+elim (ltb n m).
+apply ((H H2)).
+apply ((H1 H2)).
+qed.
+
+theorem Not_lt_n_n: ∀n. n ≮ n.
+intro;
+unfold Not;
+intro;
+unfold lt in H;
+apply (not_le_Sn_n ? H).
+qed.
+
+theorem eq_pred_to_eq:
+ ∀n,m. O < n → O < m → pred n = pred m → n = m.
+intros;
+generalize in match (eq_f ? ? S ? ? H2);
+intro;
+rewrite < S_pred in H3;
+rewrite < S_pred in H3;
+assumption.
+qed.
+
+theorem le_pred_to_le:
+ ∀n,m. O < m → pred n ≤ pred m \to n ≤ m.
+intros 2;
+elim n;
+[ apply le_O_n
+| simplify in H2;
+ rewrite > (S_pred m);
+ [ apply le_S_S;
+ assumption
+ | assumption
+ ]
+].
+qed.
+
+theorem le_to_le_pred:
+ ∀n,m. n ≤ m → pred n ≤ pred m.
+intros 2;
+elim n;
+[ simplify;
+ apply le_O_n
+| simplify;
+ generalize in match H1;
+ clear H1;
+ elim m;
+ [ elim (not_le_Sn_O ? H1)
+ | simplify;
+ apply le_S_S_to_le;
+ assumption
+ ]
+].
+qed.
+
+theorem lt_n_m_to_not_lt_m_Sn: ∀n,m. n < m → m ≮ S n.
+intros;
+unfold Not;
+intro;
+unfold lt in H;
+unfold lt in H1;
+generalize in match (le_S_S ? ? H);
+intro;
+generalize in match (transitive_le ? ? ? H2 H1);
+intro;
+apply (not_le_Sn_n ? H3).
+qed.
+
+theorem lt_S_S: ∀n,m. n < m → S n < S m.
+intros;
+unfold lt in H;
+apply (le_S_S ? ? H).
+qed.
+
+theorem lt_O_S: ∀n. O < S n.
+intro;
+unfold lt;
+apply le_S_S;
+apply le_O_n.
+qed.
+
+theorem le_n_m_to_lt_m_Sn_to_eq_n_m: ∀n,m. n ≤ m → m < S n → n=m.
+intros;
+unfold lt in H1;
+generalize in match (le_S_S_to_le ? ? H1);
+intro;
+apply cic:/matita/nat/orders/antisym_le.con;
+assumption.
+qed.
+
+theorem pigeonhole:
+ ∀n:nat.∀f:nat→nat.
+ (∀x,y.x≤n → y≤n → f x = f y → x=y) →
+ (∀m. m ≤ n → f m ≤ n) →
+ ∀x. x≤n \to ∃y.f y = x ∧ y ≤ n.
+intro;
+elim n;
+[ apply (ex_intro ? ? O);
+ split;
+ [ rewrite < (le_n_O_to_eq ? H2);
+ rewrite < (le_n_O_to_eq ? (H1 O ?));
+ [ reflexivity
+ | apply le_n
+ ]
+ | apply le_n
+ ]
+| clear n;
+ letin f' ≝
+ (λx.
+ let fSn1 ≝ f (S n1) in
+ let fx ≝ f x in
+ match ltb fSn1 fx with
+ [ true ⇒ pred fx
+ | false ⇒ fx
+ ]);
+ cut (∀x,y. x ≤ n1 → y ≤ n1 → f' x = f' y → x=y);
+ [ cut (∀x. x ≤ n1 → f' x ≤ n1);
+ [ apply (nat_compare_elim (f (S n1)) x);
+ [ intro;
+ elim (H f' ? ? (pred x));
+ [ simplify in H5;
+ clear Hcut;
+ clear Hcut1;
+ clear f';
+ elim H5;
+ clear H5;
+ apply (ex_intro ? ? a);
+ split;
+ [ generalize in match (eq_f ? ? S ? ? H6);
+ clear H6;
+ intro;
+ rewrite < S_pred in H5;
+ [ generalize in match H4;
+ clear H4;
+ rewrite < H5;
+ clear H5;
+ apply (ltb_elim (f (S n1)) (f a));
+ [ simplify;
+ intros;
+ rewrite < S_pred;
+ [ reflexivity
+ | apply (ltn_to_ltO ? ? H4)
+ ]
+ | simplify;
+ intros;
+ generalize in match (not_lt_to_le ? ? H4);
+ clear H4;
+ intro;
+ generalize in match (le_n_m_to_lt_m_Sn_to_eq_n_m ? ? H6 H5);
+ intro;
+ generalize in match (H1 ? ? ? ? H4);
+ [ intro;
+ |
+ |
+ ]
+ ]
+ | apply (ltn_to_ltO ? ? H4)
+ ]
+ | apply le_S;
+ assumption
+ ]
+ | apply Hcut
+ | apply Hcut1
+ | apply le_S_S_to_le;
+ rewrite < S_pred;
+ exact H3
+ ]
+ (* TODO: caso complicato, ma simile al terzo *)
+ | intros;
+ apply (ex_intro ? ? (S n1));
+ split;
+ [ assumption
+ | constructor 1
+ ]
+ | intro;
+ elim (H f' ? ? x);
+ [ simplify in H5;
+ clear Hcut;
+ clear Hcut1;
+ clear f';
+ elim H5;
+ clear H5;
+ apply (ex_intro ? ? a);
+ split;
+ [ generalize in match H4;
+ clear H4;
+ rewrite < H6;
+ clear H6;
+ apply (ltb_elim (f (S n1)) (f a));
+ [ simplify;
+ intros;
+ generalize in match (lt_S_S ? ? H5);
+ intro;
+ rewrite < S_pred in H6;
+ [ elim (lt_n_m_to_not_lt_m_Sn ? ? H4 H6)
+ | apply (ltn_to_ltO ? ? H4)
+ ]
+ | simplify;
+ intros;
+ reflexivity
+ ]
+ | apply le_S;
+ assumption
+ ]
+ | apply Hcut
+ | apply Hcut1
+ | rewrite > (pred_Sn n1);
+ simplify;
+ generalize in match (H2 (S n1));
+ intro;
+ generalize in match (lt_to_le_to_lt ? ? ? H4 (H5 (le_n ?)));
+ intro;
+ unfold lt in H6;
+ apply le_S_S_to_le;
+ assumption
+ ]
+ ]
+ | unfold f';
+ simplify;
+ intro;
+ apply (ltb_elim (f (S n1)) (f x1));
+ simplify;
+ intros;
+ [ generalize in match (H2 x1);
+ intro;
+ change in match n1 with (pred (S n1));
+ apply le_to_le_pred;
+ apply H6;
+ apply le_S;
+ assumption
+ | generalize in match (H2 (S n1) (le_n ?));
+ intro;
+ generalize in match (not_lt_to_le ? ? H4);
+ intro;
+ generalize in match (transitive_le ? ? ? H7 H6);
+ intro;
+ cut (f x1 ≠ f (S n1));
+ [ generalize in match (not_eq_to_le_to_lt ? ? Hcut1 H7);
+ intro;
+ unfold lt in H9;
+ generalize in match (transitive_le ? ? ? H9 H6);
+ intro;
+ apply le_S_S_to_le;
+ assumption
+ | unfold Not;
+ intro;
+ generalize in match (H1 ? ? ? ? H9);
+ [ intro;
+ rewrite > H10 in H5;
+ apply (not_le_Sn_n ? H5)
+ | apply le_S;
+ assumption
+ | apply le_n
+ ]
+ ]
+ ]
+ ]
+ | intros 4;
+ unfold f';
+ simplify;
+ apply (ltb_elim (f (S n1)) (f x1));
+ simplify;
+ apply (ltb_elim (f (S n1)) (f y));
+ simplify;
+ intros;
+ [ cut (f x1 = f y);
+ [ apply (H1 ? ? ? ? Hcut);
+ apply le_S;
+ assumption
+ | apply eq_pred_to_eq;
+ [ apply (ltn_to_ltO ? ? H7)
+ | apply (ltn_to_ltO ? ? H6)
+ | assumption
+ ]
+ ]
+ | (* pred (f x1) = f y absurd since y ≠ S n1 and thus f y ≠ f (S n1)
+ so that f y < f (S n1) < f x1; hence pred (f x1) = f y is absurd *)
+ cut (y < S n1);
+ [ generalize in match (lt_to_not_eq ? ? Hcut);
+ intro;
+ cut (f y ≠ f (S n1));
+ [ cut (f y < f (S n1));
+ [ rewrite < H8 in Hcut2;
+ unfold lt in Hcut2;
+ unfold lt in H7;
+ generalize in match (le_S_S ? ? Hcut2);
+ intro;
+ generalize in match (transitive_le ? ? ? H10 H7);
+ intros;
+ rewrite < (S_pred (f x1)) in H11;
+ [ elim (not_le_Sn_n ? H11)
+ | fold simplify ((f (S n1)) < (f x1)) in H7;
+ apply (ltn_to_ltO ? ? H7)
+ ]
+ | apply not_eq_to_le_to_lt;
+ [ assumption
+ | apply not_lt_to_le;
+ assumption
+ ]
+ ]
+ | unfold Not;
+ intro;
+ apply H9;
+ apply (H1 ? ? ? ? H10);
+ [ apply lt_to_le;
+ assumption
+ | constructor 1
+ ]
+ ]
+ | unfold lt;
+ apply le_S_S;
+ assumption
+ ]
+ | (* f x1 = pred (f y) absurd since it implies S (f x1) = f y and
+ f x1 ≤ f (S n1) < f y = S (f x1) so that f x1 = f (S n1); by
+ injectivity x1 = S n1 that is absurd since x1 ≤ n1 *)
+ generalize in match (eq_f ? ? S ? ? H8);
+ intro;
+ rewrite < S_pred in H9;
+ [ rewrite < H9 in H6;
+ generalize in match (not_lt_to_le ? ? H7);
+ intro;
+ unfold lt in H6;
+ generalize in match (le_S_S ? ? H10);
+ intro;
+ generalize in match (antisym_le ? ? H11 H6);
+ intro;
+ generalize in match (inj_S ? ? H12);
+ intro;
+ generalize in match (H1 ? ? ? ? H13);
+ [ intro;
+ rewrite > H14 in H4;
+ elim (not_le_Sn_n ? H4)
+ | apply le_S;
+ assumption
+ | apply le_n
+ ]
+ | apply (ltn_to_ltO ? ? H6)
+ ]
+ | apply (H1 ? ? ? ? H8);
+ apply le_S;
+ assumption
+ ]
+ ]
+].
+qed.
+
+theorem foo:
+ ∀G:finite_enumerable_SemiGroup.
+ left_cancellable ? (op G) →
+ right_cancellable ? (op G) →
+ ∃e:G. isMonoid (mk_PreMonoid G e).
+intros;
+letin f ≝ (λn.ι(G \sub O · G \sub n));
+cut (∀n.n ≤ order ? (is_finite_enumerable G) → ∃m.f m = n);
+[ letin EX ≝ (Hcut O ?);
+ [ apply le_O_n
+ | clearbody EX;
+ clear Hcut;
+ unfold f in EX;
+ elim EX;
+ clear EX;
+ letin HH ≝ (eq_f ? ? (repr ? (is_finite_enumerable G)) ? ? H2);
+ clearbody HH;
+ rewrite > (repr_index_of ? (is_finite_enumerable G)) in HH;
+ apply (ex_intro ? ? (G \sub a));
+ letin GOGO ≝ (refl_eq ? (repr ? (is_finite_enumerable G) O));
+ clearbody GOGO;
+ rewrite < HH in GOGO;
+ rewrite < HH in GOGO:(? ? % ?);
+ rewrite > (associative ? G) in GOGO;
+ letin GaGa ≝ (H ? ? ? GOGO);
+ clearbody GaGa;
+ clear GOGO;
+ constructor 1;
+ [ simplify;
+ apply (semigroup_properties G)
+ | unfold is_left_unit; intro;
+ letin GaxGax ≝ (refl_eq ? (G \sub a ·x));
+ clearbody GaxGax;
+ rewrite < GaGa in GaxGax:(? ? % ?);
+ rewrite > (associative ? (semigroup_properties G)) in GaxGax;
+ apply (H ? ? ? GaxGax)
+ | unfold is_right_unit; intro;
+ letin GaxGax ≝ (refl_eq ? (x·G \sub a));
+ clearbody GaxGax;
+ rewrite < GaGa in GaxGax:(? ? % ?);
+ rewrite < (associative ? (semigroup_properties G)) in GaxGax;
+ apply (H1 ? ? ? GaxGax)
+ ]
+ ]
+| apply pigeonhole
+].
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||M|| *)
+(* ||A|| A project by Andrea Asperti *)
+(* ||T|| *)
+(* ||I|| Developers: *)
+(* ||T|| The HELM team. *)
+(* ||A|| http://helm.cs.unibo.it *)
+(* \ / *)
+(* \ / This file is distributed under the terms of the *)
+(* v GNU General Public License Version 2 *)
+(* *)
+(**************************************************************************)
+
+set "baseuri" "cic:/matita/algebra/monoids/".
+
+include "algebra/semigroups.ma".
+
+record PreMonoid : Type ≝
+ { magma:> Magma;
+ e: magma
+ }.
+
+notation < "M" for @{ 'pmmagma $M }.
+interpretation "premonoid magma coercion" 'pmmagma M =
+ (cic:/matita/algebra/monoids/magma.con M).
+
+record isMonoid (M:PreMonoid) : Prop ≝
+ { is_semi_group: isSemiGroup M;
+ e_is_left_unit:
+ is_left_unit (mk_SemiGroup ? is_semi_group) (e M);
+ e_is_right_unit:
+ is_right_unit (mk_SemiGroup ? is_semi_group) (e M)
+ }.
+
+record Monoid : Type ≝
+ { premonoid:> PreMonoid;
+ monoid_properties:> isMonoid premonoid
+ }.
+
+notation < "M" for @{ 'semigroup $M }.
+interpretation "premonoid coercion" 'premonoid M =
+ (cic:/matita/algebra/monoids/premonoid.con M).
+
+notation < "M" for @{ 'typeofmonoid $M }.
+interpretation "premonoid coercion" 'typeofmonoid M =
+ (cic:/matita/algebra/monoids/Type_of_Monoid.con M).
+
+notation < "M" for @{ 'magmaofmonoid $M }.
+interpretation "premonoid coercion" 'magmaofmonoid M =
+ (cic:/matita/algebra/monoids/Magma_of_Monoid.con M).
+
+notation "1" with precedence 89
+for @{ 'munit }.
+
+interpretation "Monoid unit" 'munit =
+ (cic:/matita/algebra/monoids/e.con _).
+
+definition is_left_inverse ≝
+ λM:Monoid.
+ λopp: M → M.
+ ∀x:M. (opp x)·x = 1.
+
+definition is_right_inverse ≝
+ λM:Monoid.
+ λopp: M → M.
+ ∀x:M. x·(opp x) = 1.
+
+theorem is_left_inverse_to_is_right_inverse_to_eq:
+ ∀M:Monoid. ∀l,r.
+ is_left_inverse M l → is_right_inverse M r →
+ ∀x:M. l x = r x.
+ intros;
+ generalize in match (H x); intro;
+ generalize in match (eq_f ? ? (λy.y·(r x)) ? ? H2);
+ simplify; fold simplify (op M);
+ intro; clear H2;
+ generalize in match (associative ? (is_semi_group ? (monoid_properties M)));
+ intro;
+ rewrite > H2 in H3; clear H2;
+ rewrite > H1 in H3;
+ rewrite > (e_is_left_unit ? (monoid_properties M)) in H3;
+ rewrite > (e_is_right_unit ? (monoid_properties M)) in H3;
+ assumption.
+qed.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||M|| *)
+(* ||A|| A project by Andrea Asperti *)
+(* ||T|| *)
+(* ||I|| Developers: *)
+(* ||T|| The HELM team. *)
+(* ||A|| http://helm.cs.unibo.it *)
+(* \ / *)
+(* \ / This file is distributed under the terms of the *)
+(* v GNU General Public License Version 2 *)
+(* *)
+(**************************************************************************)
+
+set "baseuri" "cic:/matita/algebra/semigroups".
+
+include "higher_order_defs/functions.ma".
+
+(* Magmas *)
+
+record Magma : Type ≝
+ { carrier:> Type;
+ op: carrier → carrier → carrier
+ }.
+
+notation < "M" for @{ 'carrier $M }.
+interpretation "carrier coercion" 'carrier S =
+ (cic:/matita/algebra/semigroups/carrier.con S).
+
+notation "hvbox(a break \middot b)"
+ left associative with precedence 55
+for @{ 'magma_op $a $b }.
+
+interpretation "magma operation" 'magma_op a b =
+ (cic:/matita/algebra/semigroups/op.con _ a b).
+
+(* Semigroups *)
+
+record isSemiGroup (M:Magma) : Prop ≝
+ { associative: associative ? (op M) }.
+
+record SemiGroup : Type ≝
+ { magma:> Magma;
+ semigroup_properties:> isSemiGroup magma
+ }.
+
+notation < "S" for @{ 'magma $S }.
+interpretation "magma coercion" 'magma S =
+ (cic:/matita/algebra/semigroups/magma.con S).
+
+definition is_left_unit ≝
+ λS:SemiGroup. λe:S. ∀x:S. e·x = x.
+
+definition is_right_unit ≝
+ λS:SemiGroup. λe:S. ∀x:S. x·e = x.
+
+theorem is_left_unit_to_is_right_unit_to_eq:
+ ∀S:SemiGroup. ∀e,e':S.
+ is_left_unit ? e → is_right_unit ? e' → e=e'.
+ intros;
+ rewrite < (H e');
+ rewrite < (H1 e) in \vdash (? ? % ?);
+ reflexivity.
+qed.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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 ].
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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).
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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).
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||M|| *)
+(* ||A|| A project by Andrea Asperti *)
+(* ||T|| *)
+(* ||I|| Developers: *)
+(* ||T|| A.Asperti, C.Sacerdoti Coen, *)
+(* ||A|| E.Tassi, S.Zacchiroli *)
+(* \ / *)
+(* \ / This file is distributed under the terms of the *)
+(* v GNU Lesser General Public License Version 2.1 *)
+(* *)
+(**************************************************************************)
+
+set "baseuri" "cic:/matita/legacy/coq/".
+
+(* aritmetic operators *)
+
+interpretation "Coq's natural plus" 'plus x y = (cic:/Coq/Init/Peano/plus.con x y).
+interpretation "Coq's real plus" 'plus x y = (cic:/Coq/Reals/Rdefinitions/Rplus.con x y).
+interpretation "Coq's binary integer plus" 'plus x y = (cic:/Coq/ZArith/BinInt/Zplus.con x y).
+interpretation "Coq's binary positive plus" 'plus x y = (cic:/Coq/NArith/BinPos/Pplus.con x y).
+interpretation "Coq's natural minus" 'minus x y = (cic:/Coq/Init/Peano/minus.con x y).
+interpretation "Coq's real minus" 'minus x y = (cic:/Coq/Reals/Rdefinitions/Rminus.con x y).
+interpretation "Coq's binary integer minus" 'minus x y = (cic:/Coq/ZArith/BinInt/Zminus.con x y).
+interpretation "Coq's binary positive minus" 'minus x y = (cic:/Coq/NArith/BinPos/Pminus.con x y).
+interpretation "Coq's natural times" 'times x y = (cic:/Coq/Init/Peano/mult.con x y).
+interpretation "Coq's real times" 'times x y = (cic:/Coq/Reals/Rdefinitions/Rmult.con x y).
+interpretation "Coq's binary positive times" 'times x y = (cic:/Coq/NArith/BinPos/Pmult.con x y).
+interpretation "Coq's binary integer times" 'times x y = (cic:/Coq/ZArith/BinInt/Zmult.con x y).
+interpretation "Coq's real power" 'power x y = (cic:/Coq/Reals/Rfunctions/pow.con x y).
+interpretation "Coq's integer power" 'power x y = (cic:/Coq/ZArith/Zpower/Zpower.con x y).
+interpretation "Coq's real divide" 'divide x y = (cic:/Coq/Reals/Rdefinitions/Rdiv.con x y).
+interpretation "Coq's real unary minus" 'uminus x = (cic:/Coq/Reals/Rdefinitions/Ropp.con x).
+interpretation "Coq's binary integer negative sign" 'uminus x = (cic:/Coq/ZArith/BinInt/Z.ind#xpointer(1/1/3) x).
+interpretation "Coq's binary integer unary minus" 'uminus x = (cic:/Coq/ZArith/BinInt/Zopp.con x).
+
+(* logical operators *)
+
+interpretation "Coq's logical and" 'and x y = (cic:/Coq/Init/Logic/and.ind#xpointer(1/1) x y).
+interpretation "Coq's logical or" 'or x y = (cic:/Coq/Init/Logic/or.ind#xpointer(1/1) x y).
+interpretation "Coq's logical not" 'not x = (cic:/Coq/Init/Logic/not.con x).
+interpretation "Coq's exists" 'exists \eta.x = (cic:/Coq/Init/Logic/ex.ind#xpointer(1/1) _ x).
+
+(* relational operators *)
+
+interpretation "Coq's natural 'less or equal to'" 'leq x y = (cic:/Coq/Init/Peano/le.ind#xpointer(1/1) x y).
+interpretation "Coq's real 'less or equal to'" 'leq x y = (cic:/Coq/Reals/Rdefinitions/Rle.con x y).
+interpretation "Coq's natural 'greater or equal to'" 'geq x y = (cic:/Coq/Init/Peano/ge.con x y).
+interpretation "Coq's real 'greater or equal to'" 'geq x y = (cic:/Coq/Reals/Rdefinitions/Rge.con x y).
+interpretation "Coq's natural 'less than'" 'lt x y = (cic:/Coq/Init/Peano/lt.con x y).
+interpretation "Coq's real 'less than'" 'lt x y = (cic:/Coq/Reals/Rdefinitions/Rlt.con x y).
+interpretation "Coq's natural 'greater than'" 'gt x y = (cic:/Coq/Init/Peano/gt.con x y).
+interpretation "Coq's real 'greater than'" 'gt x y = (cic:/Coq/Reals/Rdefinitions/Rgt.con x y).
+
+interpretation "Coq's leibnitz's equality" 'eq x y = (cic:/Coq/Init/Logic/eq.ind#xpointer(1/1) _ x y).
+interpretation "Coq's not equal to (leibnitz)" 'neq x y = (cic:/Coq/Init/Logic/not.con (cic:/Coq/Init/Logic/eq.ind#xpointer(1/1) _ x y)).
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+*)
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+*)
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* __ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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 (? ? %).
+change with (f x < f y).
+apply H.apply H2.
+intros.assumption.
+intro.apply False_ind.apply (not_le_Sn_n (f y)).
+rewrite < H1 in \vdash (? ? %).
+change with (f y < f x).
+apply H.apply H2.
+qed.
+
+theorem increasing_to_injective: \forall f:nat\to nat.
+increasing f \to injective nat nat f.
+intros.apply monotonic_to_injective.
+apply increasing_to_monotonic.assumption.
+qed.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||M|| *)
+(* ||A|| A project by Andrea Asperti *)
+(* ||T|| *)
+(* ||I|| Developers: *)
+(* ||T|| A.Asperti, C.Sacerdoti Coen, *)
+(* ||A|| E.Tassi, S.Zacchiroli *)
+(* \ / *)
+(* \ / This file is distributed under the terms of the *)
+(* v GNU Lesser General Public License Version 2.1 *)
+(* *)
+(**************************************************************************)
+
+set "baseuri" "cic:/matita/nat/nat".
+
+include "higher_order_defs/functions.ma".
+
+inductive nat : Set \def
+ | O : nat
+ | S : nat \to nat.
+
+definition pred: nat \to nat \def
+ \lambda n:nat. match n with
+ [ O \Rightarrow O
+ | (S p) \Rightarrow p ].
+
+theorem pred_Sn : \forall n:nat.n=(pred (S n)).
+ intros. reflexivity.
+qed.
+
+theorem injective_S : injective nat nat S.
+ unfold injective.
+ intros.
+ rewrite > pred_Sn.
+ rewrite > (pred_Sn y).
+ apply eq_f. assumption.
+qed.
+
+theorem inj_S : \forall n,m:nat.(S n)=(S m) \to n=m \def
+ injective_S.
+
+theorem not_eq_S : \forall n,m:nat.
+ \lnot n=m \to S n \neq S m.
+ intros. unfold Not. intros.
+ apply H. apply injective_S. assumption.
+qed.
+
+definition not_zero : nat \to Prop \def
+ \lambda n: nat.
+ match n with
+ [ O \Rightarrow False
+ | (S p) \Rightarrow True ].
+
+theorem not_eq_O_S : \forall n:nat. O \neq S n.
+ intros. unfold Not. intros.
+ cut (not_zero O).
+ exact Hcut.
+ rewrite > H.exact I.
+qed.
+
+theorem not_eq_n_Sn : \forall n:nat. n \neq S n.
+ intros.elim n.
+ apply not_eq_O_S.
+ apply not_eq_S.assumption.
+qed.
+
+theorem nat_case:
+ \forall n:nat.\forall P:nat \to Prop.
+ P O \to (\forall m:nat. P (S m)) \to P n.
+intros.elim n
+ [ assumption
+ | apply H1 ]
+qed.
+
+theorem nat_case1:
+ \forall n:nat.\forall P:nat \to Prop.
+ (n=O \to P O) \to (\forall m:nat. (n=(S m) \to P (S m))) \to P n.
+intros 2; elim n
+ [ apply H;reflexivity
+ | apply H2;reflexivity ]
+qed.
+
+theorem nat_elim2 :
+ \forall R:nat \to nat \to Prop.
+ (\forall n:nat. R O n)
+ \to (\forall n:nat. R (S n) O)
+ \to (\forall n,m:nat. R n m \to R (S n) (S m))
+ \to \forall n,m:nat. R n m.
+intros 5;elim n
+ [ apply H
+ | apply (nat_case m)
+ [ apply H1
+ | intro; apply H2; apply H3 ] ]
+qed.
+
+theorem decidable_eq_nat : \forall n,m:nat.decidable (n=m).
+ intros.unfold decidable.
+ apply (nat_elim2 (\lambda n,m.(Or (n=m) ((n=m) \to False))))
+ [ intro; elim n1
+ [ left; reflexivity
+ | right; apply not_eq_O_S ]
+ | intro; right; intro; apply (not_eq_O_S n1); apply sym_eq; assumption
+ | intros; elim H
+ [ left; apply eq_f; assumption
+ | right; intro; apply H1; apply inj_S; assumption ] ]
+qed.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||M|| *)
+(* ||A|| A project by Andrea Asperti *)
+(* ||T|| *)
+(* ||I|| Developers: *)
+(* ||T|| A.Asperti, C.Sacerdoti Coen, *)
+(* ||A|| E.Tassi, S.Zacchiroli *)
+(* \ / *)
+(* \ / This file is distributed under the terms of the *)
+(* v GNU Lesser General Public License Version 2.1 *)
+(* *)
+(**************************************************************************)
+
+set "baseuri" "cic:/matita/nat/permutation".
+
+include "nat/compare.ma".
+include "nat/sigma_and_pi.ma".
+
+definition injn: (nat \to nat) \to nat \to Prop \def
+\lambda f:nat \to nat.\lambda n:nat.\forall i,j:nat.
+i \le n \to j \le n \to f i = f j \to i = j.
+
+theorem injn_Sn_n: \forall f:nat \to nat. \forall n:nat.
+injn f (S n) \to injn f n.unfold injn.
+intros.apply H.
+apply le_S.assumption.
+apply le_S.assumption.
+assumption.
+qed.
+
+theorem injective_to_injn: \forall f:nat \to nat. \forall n:nat.
+injective nat nat f \to injn f n.
+unfold injective.unfold injn.intros.apply H.assumption.
+qed.
+
+definition permut : (nat \to nat) \to nat \to Prop
+\def \lambda f:nat \to nat. \lambda m:nat.
+(\forall i:nat. i \le m \to f i \le m )\land injn f m.
+
+theorem permut_O_to_eq_O: \forall h:nat \to nat.
+permut h O \to (h O) = O.
+intros.unfold permut in H.
+elim H.apply sym_eq.apply le_n_O_to_eq.
+apply H1.apply le_n.
+qed.
+
+theorem permut_S_to_permut: \forall f:nat \to nat. \forall m:nat.
+permut f (S m) \to f (S m) = (S m) \to permut f m.
+unfold permut.intros.
+elim H.
+split.intros.
+cut (f i < S m \lor f i = S m).
+elim Hcut.
+apply le_S_S_to_le.assumption.
+apply False_ind.
+apply (not_le_Sn_n m).
+cut ((S m) = i).
+rewrite > Hcut1.assumption.
+apply H3.apply le_n.apply le_S.assumption.
+rewrite > H5.assumption.
+apply le_to_or_lt_eq.apply H2.apply le_S.assumption.
+apply (injn_Sn_n f m H3).
+qed.
+
+(* transpositions *)
+
+definition transpose : nat \to nat \to nat \to nat \def
+\lambda i,j,n:nat.
+match eqb n i with
+ [ true \Rightarrow j
+ | false \Rightarrow
+ match eqb n j with
+ [ true \Rightarrow i
+ | false \Rightarrow n]].
+
+lemma transpose_i_j_i: \forall i,j:nat. transpose i j i = j.
+intros.unfold transpose.
+rewrite > (eqb_n_n i).simplify. reflexivity.
+qed.
+
+lemma transpose_i_j_j: \forall i,j:nat. transpose i j j = i.
+intros.unfold transpose.
+apply (eqb_elim j i).simplify.intro.assumption.
+rewrite > (eqb_n_n j).simplify.
+intros. reflexivity.
+qed.
+
+theorem transpose_i_i: \forall i,n:nat. (transpose i i n) = n.
+intros.unfold transpose.
+apply (eqb_elim n i).
+intro.simplify.apply sym_eq. assumption.
+intro.simplify.reflexivity.
+qed.
+
+theorem transpose_i_j_j_i: \forall i,j,n:nat.
+transpose i j n = transpose j i n.
+intros.unfold transpose.
+apply (eqb_elim n i).
+apply (eqb_elim n j).
+intros. simplify.rewrite < H. rewrite < H1.
+reflexivity.
+intros.simplify.reflexivity.
+apply (eqb_elim n j).
+intros.simplify.reflexivity.
+intros.simplify.reflexivity.
+qed.
+
+theorem transpose_transpose: \forall i,j,n:nat.
+(transpose i j (transpose i j n)) = n.
+intros.unfold transpose. unfold transpose.
+apply (eqb_elim n i).simplify.
+intro.
+apply (eqb_elim j i).
+simplify.intros.rewrite > H. rewrite > H1.reflexivity.
+rewrite > (eqb_n_n j).simplify.intros.
+apply sym_eq.
+assumption.
+apply (eqb_elim n j).simplify.
+rewrite > (eqb_n_n i).intros.simplify.
+apply sym_eq. assumption.
+simplify.intros.
+rewrite > (not_eq_to_eqb_false n i H1).
+rewrite > (not_eq_to_eqb_false n j H).
+simplify.reflexivity.
+qed.
+
+theorem injective_transpose : \forall i,j:nat.
+injective nat nat (transpose i j).
+unfold injective.
+intros.
+rewrite < (transpose_transpose i j x).
+rewrite < (transpose_transpose i j y).
+apply eq_f.assumption.
+qed.
+
+variant inj_transpose: \forall i,j,n,m:nat.
+transpose i j n = transpose i j m \to n = m \def
+injective_transpose.
+
+theorem permut_transpose: \forall i,j,n:nat. i \le n \to j \le n \to
+permut (transpose i j) n.
+unfold permut.intros.
+split.unfold transpose.
+intros.
+elim (eqb i1 i).simplify.assumption.
+elim (eqb i1 j).simplify.assumption.
+simplify.assumption.
+apply (injective_to_injn (transpose i j) n).
+apply injective_transpose.
+qed.
+
+theorem permut_fg: \forall f,g:nat \to nat. \forall n:nat.
+permut f n \to permut g n \to permut (\lambda m.(f(g m))) n.
+unfold permut. intros.
+elim H.elim H1.
+split.intros.simplify.apply H2.
+apply H4.assumption.
+simplify.intros.
+apply H5.assumption.assumption.
+apply H3.apply H4.assumption.apply H4.assumption.
+assumption.
+qed.
+
+theorem permut_transpose_l:
+\forall f:nat \to nat. \forall m,i,j:nat.
+i \le m \to j \le m \to permut f m \to permut (\lambda n.transpose i j (f n)) m.
+intros.apply (permut_fg (transpose i j) f m ? ?).
+apply permut_transpose.assumption.assumption.
+assumption.
+qed.
+
+theorem permut_transpose_r:
+\forall f:nat \to nat. \forall m,i,j:nat.
+i \le m \to j \le m \to permut f m \to permut (\lambda n.f (transpose i j n)) m.
+intros.apply (permut_fg f (transpose i j) m ? ?).
+assumption.apply permut_transpose.assumption.assumption.
+qed.
+
+theorem eq_transpose : \forall i,j,k,n:nat. \lnot j=i \to
+ \lnot i=k \to \lnot j=k \to
+transpose i j n = transpose i k (transpose k j (transpose i k n)).
+(* uffa: triplo unfold? *)
+intros.unfold transpose.unfold transpose.unfold transpose.
+apply (eqb_elim n i).intro.
+simplify.rewrite > (eqb_n_n k).
+simplify.rewrite > (not_eq_to_eqb_false j i H).
+rewrite > (not_eq_to_eqb_false j k H2).
+reflexivity.
+intro.apply (eqb_elim n j).
+intro.
+cut (\lnot n = k).
+cut (\lnot n = i).
+rewrite > (not_eq_to_eqb_false n k Hcut).
+simplify.
+rewrite > (not_eq_to_eqb_false n k Hcut).
+rewrite > (eq_to_eqb_true n j H4).
+simplify.
+rewrite > (not_eq_to_eqb_false k i).
+rewrite > (eqb_n_n k).
+simplify.reflexivity.
+unfold Not.intro.apply H1.apply sym_eq.assumption.
+assumption.
+unfold Not.intro.apply H2.apply (trans_eq ? ? n).
+apply sym_eq.assumption.assumption.
+intro.apply (eqb_elim n k).intro.
+simplify.
+rewrite > (not_eq_to_eqb_false i k H1).
+rewrite > (not_eq_to_eqb_false i j).
+simplify.
+rewrite > (eqb_n_n i).
+simplify.assumption.
+unfold Not.intro.apply H.apply sym_eq.assumption.
+intro.simplify.
+rewrite > (not_eq_to_eqb_false n k H5).
+rewrite > (not_eq_to_eqb_false n j H4).
+simplify.
+rewrite > (not_eq_to_eqb_false n i H3).
+rewrite > (not_eq_to_eqb_false n k H5).
+simplify.reflexivity.
+qed.
+
+theorem permut_S_to_permut_transpose: \forall f:nat \to nat.
+\forall m:nat. permut f (S m) \to permut (\lambda n.transpose (f (S m)) (S m)
+(f n)) m.
+unfold permut.intros.
+elim H.
+split.intros.simplify.unfold transpose.
+apply (eqb_elim (f i) (f (S m))).
+intro.apply False_ind.
+cut (i = (S m)).
+apply (not_le_Sn_n m).
+rewrite < Hcut.assumption.
+apply H2.apply le_S.assumption.apply le_n.assumption.
+intro.simplify.
+apply (eqb_elim (f i) (S m)).
+intro.
+cut (f (S m) \lt (S m) \lor f (S m) = (S m)).
+elim Hcut.apply le_S_S_to_le.assumption.
+apply False_ind.apply H4.rewrite > H6.assumption.
+apply le_to_or_lt_eq.apply H1.apply le_n.
+intro.simplify.
+cut (f i \lt (S m) \lor f i = (S m)).
+elim Hcut.apply le_S_S_to_le.assumption.
+apply False_ind.apply H5.assumption.
+apply le_to_or_lt_eq.apply H1.apply le_S.assumption.
+unfold injn.intros.
+apply H2.apply le_S.assumption.apply le_S.assumption.
+apply (inj_transpose (f (S m)) (S m)).
+apply H5.
+qed.
+
+(* bounded bijectivity *)
+
+definition bijn : (nat \to nat) \to nat \to Prop \def
+\lambda f:nat \to nat. \lambda n. \forall m:nat. m \le n \to
+ex nat (\lambda p. p \le n \land f p = m).
+
+theorem eq_to_bijn: \forall f,g:nat\to nat. \forall n:nat.
+(\forall i:nat. i \le n \to (f i) = (g i)) \to
+bijn f n \to bijn g n.
+intros 4.unfold bijn.
+intros.elim (H1 m).
+apply (ex_intro ? ? a).
+rewrite < (H a).assumption.
+elim H3.assumption.assumption.
+qed.
+
+theorem bijn_Sn_n: \forall f:nat \to nat. \forall n:nat.
+bijn f (S n) \to f (S n) = (S n) \to bijn f n.
+unfold bijn.intros.elim (H m).
+elim H3.
+apply (ex_intro ? ? a).split.
+cut (a < S n \lor a = S n).
+elim Hcut.apply le_S_S_to_le.assumption.
+apply False_ind.
+apply (not_le_Sn_n n).
+rewrite < H1.rewrite < H6.rewrite > H5.assumption.
+apply le_to_or_lt_eq.assumption.assumption.
+apply le_S.assumption.
+qed.
+
+theorem bijn_n_Sn: \forall f:nat \to nat. \forall n:nat.
+bijn f n \to f (S n) = (S n) \to bijn f (S n).
+unfold bijn.intros.
+cut (m < S n \lor m = S n).
+elim Hcut.
+elim (H m).
+elim H4.
+apply (ex_intro ? ? a).split.
+apply le_S.assumption.assumption.
+apply le_S_S_to_le.assumption.
+apply (ex_intro ? ? (S n)).
+split.apply le_n.
+rewrite > H3.assumption.
+apply le_to_or_lt_eq.assumption.
+qed.
+
+theorem bijn_fg: \forall f,g:nat\to nat. \forall n:nat.
+bijn f n \to bijn g n \to bijn (\lambda p.f(g p)) n.
+unfold bijn.
+intros.simplify.
+elim (H m).elim H3.
+elim (H1 a).elim H6.
+apply (ex_intro ? ? a1).
+split.assumption.
+rewrite > H8.assumption.
+assumption.assumption.
+qed.
+
+theorem bijn_transpose : \forall n,i,j. i \le n \to j \le n \to
+bijn (transpose i j) n.
+intros.unfold bijn.unfold transpose.intros.
+cut (m = i \lor \lnot m = i).
+elim Hcut.
+apply (ex_intro ? ? j).
+split.assumption.
+apply (eqb_elim j i).
+intro.simplify.rewrite > H3.rewrite > H4.reflexivity.
+rewrite > (eqb_n_n j).simplify.
+intros. apply sym_eq.assumption.
+cut (m = j \lor \lnot m = j).
+elim Hcut1.
+apply (ex_intro ? ? i).
+split.assumption.
+rewrite > (eqb_n_n i).simplify.
+apply sym_eq. assumption.
+apply (ex_intro ? ? m).
+split.assumption.
+rewrite > (not_eq_to_eqb_false m i).
+rewrite > (not_eq_to_eqb_false m j).
+simplify. reflexivity.
+assumption.
+assumption.
+apply (decidable_eq_nat m j).
+apply (decidable_eq_nat m i).
+qed.
+
+theorem bijn_transpose_r: \forall f:nat\to nat.\forall n,i,j. i \le n \to j \le n \to
+bijn f n \to bijn (\lambda p.f (transpose i j p)) n.
+intros.
+apply (bijn_fg f ?).assumption.
+apply (bijn_transpose n i j).assumption.assumption.
+qed.
+
+theorem bijn_transpose_l: \forall f:nat\to nat.\forall n,i,j. i \le n \to j \le n \to
+bijn f n \to bijn (\lambda p.transpose i j (f p)) n.
+intros.
+apply (bijn_fg ? f).
+apply (bijn_transpose n i j).assumption.assumption.
+assumption.
+qed.
+
+theorem permut_to_bijn: \forall n:nat.\forall f:nat\to nat.
+permut f n \to bijn f n.
+intro.
+elim n.unfold bijn.intros.
+apply (ex_intro ? ? m).
+split.assumption.
+apply (le_n_O_elim m ? (\lambda p. f p = p)).
+assumption.unfold permut in H.
+elim H.apply sym_eq. apply le_n_O_to_eq.apply H2.apply le_n.
+apply (eq_to_bijn (\lambda p.
+(transpose (f (S n1)) (S n1)) (transpose (f (S n1)) (S n1) (f p))) f).
+intros.apply transpose_transpose.
+apply (bijn_fg (transpose (f (S n1)) (S n1))).
+apply bijn_transpose.
+unfold permut in H1.
+elim H1.apply H2.apply le_n.apply le_n.
+apply bijn_n_Sn.
+apply H.
+apply permut_S_to_permut_transpose.
+assumption.unfold transpose.
+rewrite > (eqb_n_n (f (S n1))).simplify.reflexivity.
+qed.
+
+let rec invert_permut n f m \def
+ match eqb m (f n) with
+ [true \Rightarrow n
+ |false \Rightarrow
+ match n with
+ [O \Rightarrow O
+ |(S p) \Rightarrow invert_permut p f m]].
+
+theorem invert_permut_f: \forall f:nat \to nat. \forall n,m:nat.
+m \le n \to injn f n\to invert_permut n f (f m) = m.
+intros 4.
+elim H.
+apply (nat_case1 m).
+intro.simplify.
+rewrite > (eqb_n_n (f O)).simplify.reflexivity.
+intros.simplify.
+rewrite > (eqb_n_n (f (S m1))).simplify.reflexivity.
+simplify.
+rewrite > (not_eq_to_eqb_false (f m) (f (S n1))).
+simplify.apply H2.
+apply injn_Sn_n. assumption.
+unfold Not.intro.absurd (m = S n1).
+apply H3.apply le_S.assumption.apply le_n.assumption.
+unfold Not.intro.
+apply (not_le_Sn_n n1).rewrite < H5.assumption.
+qed.
+
+theorem injective_invert_permut: \forall f:nat \to nat. \forall n:nat.
+permut f n \to injn (invert_permut n f) n.
+intros.
+unfold injn.intros.
+cut (bijn f n).
+unfold bijn in Hcut.
+generalize in match (Hcut i H1).intro.
+generalize in match (Hcut j H2).intro.
+elim H4.elim H6.
+elim H5.elim H9.
+rewrite < H8.
+rewrite < H11.
+apply eq_f.
+rewrite < (invert_permut_f f n a).
+rewrite < (invert_permut_f f n a1).
+rewrite > H8.
+rewrite > H11.
+assumption.assumption.
+unfold permut in H.elim H. assumption.
+assumption.
+unfold permut in H.elim H. assumption.
+apply permut_to_bijn.assumption.
+qed.
+
+theorem permut_invert_permut: \forall f:nat \to nat. \forall n:nat.
+permut f n \to permut (invert_permut n f) n.
+intros.unfold permut.split.
+intros.simplify.elim n.
+simplify.elim (eqb i (f O)).simplify.apply le_n.simplify.apply le_n.
+simplify.elim (eqb i (f (S n1))).simplify.apply le_n.
+simplify.apply le_S. assumption.
+apply injective_invert_permut.assumption.
+qed.
+
+theorem f_invert_permut: \forall f:nat \to nat. \forall n,m:nat.
+m \le n \to permut f n\to f (invert_permut n f m) = m.
+intros.
+apply (injective_invert_permut f n H1).
+unfold permut in H1.elim H1.
+apply H2.
+cut (permut (invert_permut n f) n).unfold permut in Hcut.
+elim Hcut.apply H4.assumption.
+apply permut_invert_permut.assumption.assumption.
+apply invert_permut_f.
+cut (permut (invert_permut n f) n).unfold permut in Hcut.
+elim Hcut.apply H2.assumption.
+apply permut_invert_permut.assumption.
+unfold permut in H1.elim H1.assumption.
+qed.
+
+theorem permut_n_to_eq_n: \forall h:nat \to nat.\forall n:nat.
+permut h n \to (\forall m:nat. m < n \to h m = m) \to h n = n.
+intros.unfold permut in H.elim H.
+cut (invert_permut n h n < n \lor invert_permut n h n = n).
+elim Hcut.
+rewrite < (f_invert_permut h n n) in \vdash (? ? ? %).
+apply eq_f.
+rewrite < (f_invert_permut h n n) in \vdash (? ? % ?).
+apply H1.assumption.apply le_n.assumption.apply le_n.assumption.
+rewrite < H4 in \vdash (? ? % ?).
+apply (f_invert_permut h).apply le_n.assumption.
+apply le_to_or_lt_eq.
+cut (permut (invert_permut n h) n).
+unfold permut in Hcut.elim Hcut.
+apply H4.apply le_n.
+apply permut_invert_permut.assumption.
+qed.
+
+theorem permut_n_to_le: \forall h:nat \to nat.\forall k,n:nat.
+k \le n \to permut h n \to (\forall m:nat. m < k \to h m = m) \to
+\forall j. k \le j \to j \le n \to k \le h j.
+intros.unfold permut in H1.elim H1.
+cut (h j < k \lor \not(h j < k)).
+elim Hcut.absurd (k \le j).assumption.
+apply lt_to_not_le.
+cut (h j = j).rewrite < Hcut1.assumption.
+apply H6.apply H5.assumption.assumption.
+apply H2.assumption.
+apply not_lt_to_le.assumption.
+apply (decidable_lt (h j) k).
+qed.
+
+(* applications *)
+
+let rec map_iter_i k (g:nat \to nat) f (i:nat) \def
+ match k with
+ [ O \Rightarrow g i
+ | (S k) \Rightarrow f (g (S (k+i))) (map_iter_i k g f i)].
+
+theorem eq_map_iter_i: \forall g1,g2:nat \to nat.
+\forall f:nat \to nat \to nat. \forall n,i:nat.
+(\forall m:nat. i\le m \to m \le n+i \to g1 m = g2 m) \to
+map_iter_i n g1 f i = map_iter_i n g2 f i.
+intros 5.elim n.simplify.apply H.apply le_n.
+apply le_n.simplify.apply eq_f2.apply H1.simplify.
+apply le_S.apply le_plus_n.simplify.apply le_n.
+apply H.intros.apply H1.assumption.simplify.apply le_S.assumption.
+qed.
+
+(* map_iter examples *)
+
+theorem eq_map_iter_i_sigma: \forall g:nat \to nat. \forall n,m:nat.
+map_iter_i n g plus m = sigma n g m.
+intros.elim n.simplify.reflexivity.
+simplify.
+apply eq_f.assumption.
+qed.
+
+theorem eq_map_iter_i_pi: \forall g:nat \to nat. \forall n,m:nat.
+map_iter_i n g times m = pi n g m.
+intros.elim n.simplify.reflexivity.
+simplify.
+apply eq_f.assumption.
+qed.
+
+theorem eq_map_iter_i_fact: \forall n:nat.
+map_iter_i n (\lambda m.m) times (S O) = (S n)!.
+intros.elim n.
+simplify.reflexivity.
+change with
+(((S n1)+(S O))*(map_iter_i n1 (\lambda m.m) times (S O)) = (S(S n1))*(S n1)!).
+rewrite < plus_n_Sm.rewrite < plus_n_O.
+apply eq_f.assumption.
+qed.
+
+theorem eq_map_iter_i_transpose_l : \forall f:nat\to nat \to nat.associative nat f \to
+symmetric2 nat nat f \to \forall g:nat \to nat. \forall n,k:nat.
+map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose (k+n) (S k+n) m)) f n.
+intros.apply (nat_case1 k).
+intros.simplify.
+change with
+(f (g (S n)) (g n) =
+f (g (transpose n (S n) (S n))) (g (transpose n (S n) n))).
+rewrite > transpose_i_j_i.
+rewrite > transpose_i_j_j.
+apply H1.
+intros.
+change with
+(f (g (S (S (m+n)))) (f (g (S (m+n))) (map_iter_i m g f n)) =
+f (g (transpose (S m + n) (S (S m) + n) (S (S m)+n)))
+(f (g (transpose (S m + n) (S (S m) + n) (S m+n)))
+(map_iter_i m (\lambda m1. g (transpose (S m+n) (S (S m)+n) m1)) f n))).
+rewrite > transpose_i_j_i.
+rewrite > transpose_i_j_j.
+rewrite < H.
+rewrite < H.
+rewrite < (H1 (g (S m + n))).
+apply eq_f.
+apply eq_map_iter_i.
+intros.simplify.unfold transpose.
+rewrite > (not_eq_to_eqb_false m1 (S m+n)).
+rewrite > (not_eq_to_eqb_false m1 (S (S m)+n)).
+simplify.
+reflexivity.
+apply (lt_to_not_eq m1 (S ((S m)+n))).
+unfold lt.apply le_S_S.change with (m1 \leq S (m+n)).apply le_S.assumption.
+apply (lt_to_not_eq m1 (S m+n)).
+simplify.unfold lt.apply le_S_S.assumption.
+qed.
+
+theorem eq_map_iter_i_transpose_i_Si : \forall f:nat\to nat \to nat.associative nat f \to
+symmetric2 nat nat f \to \forall g:nat \to nat. \forall n,k,i:nat. n \le i \to i \le k+n \to
+map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i (S i) m)) f n.
+intros 6.elim k.cut (i=n).
+rewrite > Hcut.
+apply (eq_map_iter_i_transpose_l f H H1 g n O).
+apply antisymmetric_le.assumption.assumption.
+cut (i < S n1 + n \lor i = S n1 + n).
+elim Hcut.
+change with
+(f (g (S (S n1)+n)) (map_iter_i (S n1) g f n) =
+f (g (transpose i (S i) (S (S n1)+n))) (map_iter_i (S n1) (\lambda m. g (transpose i (S i) m)) f n)).
+apply eq_f2.unfold transpose.
+rewrite > (not_eq_to_eqb_false (S (S n1)+n) i).
+rewrite > (not_eq_to_eqb_false (S (S n1)+n) (S i)).
+simplify.reflexivity.
+simplify.unfold Not.intro.
+apply (lt_to_not_eq i (S n1+n)).assumption.
+apply inj_S.apply sym_eq. assumption.
+simplify.unfold Not.intro.
+apply (lt_to_not_eq i (S (S n1+n))).simplify.unfold lt.
+apply le_S_S.assumption.
+apply sym_eq. assumption.
+apply H2.assumption.apply le_S_S_to_le.
+assumption.
+rewrite > H5.
+apply (eq_map_iter_i_transpose_l f H H1 g n (S n1)).
+apply le_to_or_lt_eq.assumption.
+qed.
+
+theorem eq_map_iter_i_transpose:
+\forall f:nat\to nat \to nat.
+associative nat f \to symmetric2 nat nat f \to \forall n,k,o:nat.
+\forall g:nat \to nat. \forall i:nat. n \le i \to S (o + i) \le S k+n \to
+map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i (S(o + i)) m)) f n.
+intros 6.
+apply (nat_elim1 o).
+intro.
+apply (nat_case m ?).
+intros.
+apply (eq_map_iter_i_transpose_i_Si ? H H1).
+exact H3.apply le_S_S_to_le.assumption.
+intros.
+apply (trans_eq ? ? (map_iter_i (S k) (\lambda m. g (transpose i (S(m1 + i)) m)) f n)).
+apply H2.
+unfold lt. apply le_n.assumption.
+apply (trans_le ? (S(S (m1+i)))).
+apply le_S.apply le_n.assumption.
+apply (trans_eq ? ? (map_iter_i (S k) (\lambda m. g
+(transpose i (S(m1 + i)) (transpose (S(m1 + i)) (S(S(m1 + i))) m))) f n)).
+apply (H2 O ? ? (S(m1+i))).
+unfold lt.apply le_S_S.apply le_O_n.
+apply (trans_le ? i).assumption.
+change with (i \le (S m1)+i).apply le_plus_n.
+exact H4.
+apply (trans_eq ? ? (map_iter_i (S k) (\lambda m. g
+(transpose i (S(m1 + i))
+(transpose (S(m1 + i)) (S(S(m1 + i)))
+(transpose i (S(m1 + i)) m)))) f n)).
+apply (H2 m1).
+unfold lt. apply le_n.assumption.
+apply (trans_le ? (S(S (m1+i)))).
+apply le_S.apply le_n.assumption.
+apply eq_map_iter_i.
+intros.apply eq_f.
+apply sym_eq. apply eq_transpose.
+unfold Not. intro.
+apply (not_le_Sn_n i).
+rewrite < H7 in \vdash (? ? %).
+apply le_S_S.apply le_S.
+apply le_plus_n.
+unfold Not. intro.
+apply (not_le_Sn_n i).
+rewrite > H7 in \vdash (? ? %).
+apply le_S_S.
+apply le_plus_n.
+unfold Not. intro.
+apply (not_eq_n_Sn (S m1+i)).
+apply sym_eq.assumption.
+qed.
+
+theorem eq_map_iter_i_transpose1: \forall f:nat\to nat \to nat.associative nat f \to
+symmetric2 nat nat f \to \forall n,k,i,j:nat.
+\forall g:nat \to nat. n \le i \to i < j \to j \le S k+n \to
+map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i j m)) f n.
+intros.
+simplify in H3.
+cut ((S i) < j \lor (S i) = j).
+elim Hcut.
+cut (j = S ((j - (S i)) + i)).
+rewrite > Hcut1.
+apply (eq_map_iter_i_transpose f H H1 n k (j - (S i)) g i).
+assumption.
+rewrite < Hcut1.assumption.
+rewrite > plus_n_Sm.
+apply plus_minus_m_m.apply lt_to_le.assumption.
+rewrite < H5.
+apply (eq_map_iter_i_transpose_i_Si f H H1 g).
+simplify.
+assumption.apply le_S_S_to_le.
+apply (trans_le ? j).assumption.assumption.
+apply le_to_or_lt_eq.assumption.
+qed.
+
+theorem eq_map_iter_i_transpose2: \forall f:nat\to nat \to nat.associative nat f \to
+symmetric2 nat nat f \to \forall n,k,i,j:nat.
+\forall g:nat \to nat. n \le i \to i \le (S k+n) \to n \le j \to j \le (S k+n) \to
+map_iter_i (S k) g f n = map_iter_i (S k) (\lambda m. g (transpose i j m)) f n.
+intros.
+apply (nat_compare_elim i j).
+intro.apply (eq_map_iter_i_transpose1 f H H1 n k i j g H2 H6 H5).
+intro.rewrite > H6.
+apply eq_map_iter_i.intros.
+rewrite > (transpose_i_i j).reflexivity.
+intro.
+apply (trans_eq ? ? (map_iter_i (S k) (\lambda m:nat.g (transpose j i m)) f n)).
+apply (eq_map_iter_i_transpose1 f H H1 n k j i g H4 H6 H3).
+apply eq_map_iter_i.
+intros.apply eq_f.apply transpose_i_j_j_i.
+qed.
+
+theorem permut_to_eq_map_iter_i:\forall f:nat\to nat \to nat.associative nat f \to
+symmetric2 nat nat f \to \forall k,n:nat.\forall g,h:nat \to nat.
+permut h (k+n) \to (\forall m:nat. m \lt n \to h m = m) \to
+map_iter_i k g f n = map_iter_i k (\lambda m.g(h m)) f n.
+intros 4.elim k.
+simplify.rewrite > (permut_n_to_eq_n h).reflexivity.assumption.assumption.
+apply (trans_eq ? ? (map_iter_i (S n) (\lambda m.g ((transpose (h (S n+n1)) (S n+n1)) m)) f n1)).
+unfold permut in H3.
+elim H3.
+apply (eq_map_iter_i_transpose2 f H H1 n1 n ? ? g).
+apply (permut_n_to_le h n1 (S n+n1)).
+apply le_plus_n.assumption.assumption.apply le_plus_n.apply le_n.
+apply H5.apply le_n.apply le_plus_n.apply le_n.
+apply (trans_eq ? ? (map_iter_i (S n) (\lambda m.
+(g(transpose (h (S n+n1)) (S n+n1)
+(transpose (h (S n+n1)) (S n+n1) (h m)))) )f n1)).
+change with
+(f (g (transpose (h (S n+n1)) (S n+n1) (S n+n1)))
+(map_iter_i n (\lambda m.
+g (transpose (h (S n+n1)) (S n+n1) m)) f n1)
+=
+f
+(g(transpose (h (S n+n1)) (S n+n1)
+(transpose (h (S n+n1)) (S n+n1) (h (S n+n1)))))
+(map_iter_i n
+(\lambda m.
+(g(transpose (h (S n+n1)) (S n+n1)
+(transpose (h (S n+n1)) (S n+n1) (h m))))) f n1)).
+apply eq_f2.apply eq_f.
+rewrite > transpose_i_j_j.
+rewrite > transpose_i_j_i.
+rewrite > transpose_i_j_j.reflexivity.
+apply (H2 n1 (\lambda m.(g(transpose (h (S n+n1)) (S n+n1) m)))).
+apply permut_S_to_permut_transpose.
+assumption.
+intros.
+unfold transpose.
+rewrite > (not_eq_to_eqb_false (h m) (h (S n+n1))).
+rewrite > (not_eq_to_eqb_false (h m) (S n+n1)).
+simplify.apply H4.assumption.
+rewrite > H4.
+apply lt_to_not_eq.apply (trans_lt ? n1).assumption.
+simplify.unfold lt.apply le_S_S.apply le_plus_n.assumption.
+unfold permut in H3.elim H3.
+simplify.unfold Not.intro.
+apply (lt_to_not_eq m (S n+n1)).apply (trans_lt ? n1).assumption.
+simplify.unfold lt.apply le_S_S.apply le_plus_n.
+unfold injn in H7.
+apply (H7 m (S n+n1)).apply (trans_le ? n1).
+apply lt_to_le.assumption.apply le_plus_n.apply le_n.
+assumption.
+apply eq_map_iter_i.intros.
+rewrite > transpose_transpose.reflexivity.
+qed.
\ No newline at end of file
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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). *)
+
--- /dev/null
+(**************************************************************************)
+(* __ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* __ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* __ *)
+(* ||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
--- /dev/null
+matita.conf.xml.devel
\ No newline at end of file
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+<helm_registry>
+ <section name="user">
+ <key name="home">$(HOME)</key>
+ </section>
+ <section name="matita">
+ <key name="basedir">.matita</key>
+ <key name="owner">nobody</key>
+ </section>
+ <section name="db">
+ <key name="host">@DBHOST@</key>
+ <key name="user">helm</key>
+ <key name="database">matita</key>
+ </section>
+ <section name="getter">
+ <key name="cache_dir">.matita/getter/cache</key>
+ <key name="prefix">
+ cic:/matita/
+ file://.matita/xml/matita/
+ </key>
+ <key name="prefix">
+ cic:/
+ file:///does_not_exists/
+ legacy
+ </key>
+ </section>
+</helm_registry>
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+<helm_registry>
+ <section name="user">
+ <!-- User home directory. Here a ".matita" directory will be created
+ and used to store the part of the library developed by the user. -->
+ <key name="home">$(HOME)</key>
+ <!-- User name. It is used down in this configuration file. If left
+ unspecified, name of the user executing matita will be used (as per
+ getent) -->
+ <!-- <key name="name">foo</key> -->
+ </section>
+ <section name="matita">
+ <!-- Debug only. Stay away. -->
+ <!-- <key name="auto_disambiguation">true</key> -->
+ <!-- Debug only. Stay away. -->
+ <!-- <key name="environment_trust">true</key> -->
+ <key name="basedir">$(user.home)/.matita</key>
+ <!-- Metadata owner. It will be used to create user-specific tables
+ in the SQL database. -->
+ <key name="owner">$(user.name)</key>
+ <!-- Initial GUI font size. -->
+ <!-- <key name="font_size">10</key> -->
+ </section>
+ <section name="db">
+ <!-- Access parameter to the (MySql) metadata database. They are not
+ needed if Matita is always run with -nodb, but this is _not_
+ recommended since a lot of features wont work.
+ Hint. The simplest way to create a database is:
+ 0) # become an user with database administration privileges
+ 1) mysqladmin create matita
+ 2) echo "grant all privileges on matita.* to helm;" | mysql matita
+ Note that this way the database will be open to anyone, apply
+ stricter permissions if needed.
+ -->
+ <key name="host">@DBHOST@</key>
+ <key name="user">helm</key>
+ <key name="database">matita</key>
+ </section>
+ <section name="getter">
+ <!-- Cache dir for CIC XML documents downloaded from the net.
+ Beware that this dir may become really space-consuming. It wont be
+ used if all prefexises below are local (i.e. "file:///" URI scheme).
+ -->
+ <key name="cache_dir">$(user.home)/.matita/getter/cache</key>
+ <!-- "Prefixes", i.e.: mappings URI -> URL of the global library
+ Each prefix mapps an URI of the cic:/ namespace to an URL where the
+ documents can actually be accessed. URL can be in the "file://" or
+ "http://" scheme. Only "file://" scheme can be used to store
+ documents created by the user.
+ Each prefix may be given a list of attributes. Currently supported
+ attributes are:
+ - "legacy" for parts of the library not generated by Matita (e.g.
+ exported from Coq)
+ - "ro" for parts of the library which are not writable by the user
+ (e.g. the Matita standard library)
+ "legacy" implies "ro"
+ -->
+ <key name="prefix">
+ cic:/matita/
+ file://$(user.home)/.matita/xml/matita/
+ </key>
+ <key name="prefix">
+ cic:/
+ file:///projects/helm/library/coq_contribs/
+ legacy
+ </key>
+ </section>
+</helm_registry>
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+<helm_registry>
+ <section name="user">
+ <!-- User home directory. Here a ".matita" directory will be created
+ and used to store the part of the library developed by the user. -->
+ <key name="home">$(HOME)</key>
+ <!-- User name. It is used down in this configuration file. If left
+ unspecified, name of the user executing matita will be used (as per
+ getent) -->
+ <!-- <key name="name">foo</key> -->
+ </section>
+ <section name="matita">
+ <!-- Debug only. Stay away. -->
+ <!-- <key name="auto_disambiguation">true</key> -->
+ <!-- Debug only. Stay away. -->
+ <!-- <key name="environment_trust">true</key> -->
+ <key name="basedir">$(user.home)/.matita</key>
+ <!-- Metadata owner. It will be used to create user-specific tables
+ in the SQL database. -->
+ <key name="owner">$(user.name)</key>
+ <!-- Initial GUI font size. -->
+ <!-- <key name="font_size">10</key> -->
+ </section>
+ <section name="db">
+ <!-- Access parameter to the (MySql) metadata database. They are not
+ needed if Matita is always run with -nodb, but this is _not_
+ recommended since a lot of features wont work.
+ Hint. The simplest way to create a database is:
+ 0) # become an user with database administration privileges
+ 1) mysqladmin create matita
+ 2) echo "grant all privileges on matita.* to helm;" | mysql matita
+ Note that this way the database will be open to anyone, apply
+ stricter permissions if needed.
+ -->
+ <key name="host">@DBHOST@</key>
+ <key name="user">helm</key>
+ <key name="database">matita</key>
+ </section>
+ <section name="getter">
+ <!-- Cache dir for CIC XML documents downloaded from the net.
+ Beware that this dir may become really space-consuming. It wont be
+ used if all prefexises below are local (i.e. "file:///" URI scheme).
+ -->
+ <key name="cache_dir">$(user.home)/.matita/getter/cache</key>
+ <!-- "Prefixes", i.e.: mappings URI -> URL of the global library
+ Each prefix mapps an URI of the cic:/ namespace to an URL where the
+ documents can actually be accessed. URL can be in the "file://" or
+ "http://" scheme. Only "file://" scheme can be used to store
+ documents created by the user.
+ Each prefix may be given a list of attributes. Currently supported
+ attributes are:
+ - "legacy" for parts of the library not generated by Matita (e.g.
+ exported from Coq)
+ - "ro" for parts of the library which are not writable by the user
+ (e.g. the Matita standard library)
+ "legacy" implies "ro"
+ -->
+ <key name="prefix">
+ cic:/matita/
+ file://@RT_BASE_DIR@/library/
+ ro
+ </key>
+ <key name="prefix">
+ cic:/matita/$(user.name)/
+ file://$(user.home)/.matita/xml/matita/
+ </key>
+ <key name="prefix">
+ cic:/
+ file://@RT_BASE_DIR@/legacy/coq/
+ legacy
+ </key>
+ </section>
+</helm_registry>
--- /dev/null
+<?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 & 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 & 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>
--- /dev/null
+# 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"
+
--- /dev/null
+<?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>"</start-regex>
+ <end-regex>"</end-regex>
+ </string>
+
+</language>
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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/".
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+open MatitaGtkMisc
+open GrafiteTypes
+
+(** {2 Initialization} *)
+
+let _ = MatitaInit.initialize_all ()
+(* let _ = Saturation.init () (* ALB to link paramodulation *) *)
+
+(** {2 GUI callbacks} *)
+
+let gui = MatitaGui.instance ()
+
+let script =
+ let s =
+ MatitaScript.script
+ ~source_view:gui#sourceView
+ ~mathviewer:(MatitaMathView.mathViewer ())
+ ~urichooser:(fun uris ->
+ try
+ MatitaGui.interactive_uri_choice ~selection_mode:`SINGLE
+ ~title:"Matita: URI chooser"
+ ~msg:"Select the URI" ~hide_uri_entry:true
+ ~hide_try:true ~ok_label:"_Apply" ~ok_action:`SELECT
+ ~copy_cb:(fun s -> gui#sourceView#buffer#insert ("\n"^s^"\n"))
+ () ~id:"boh?" uris
+ with MatitaTypes.Cancel -> [])
+ ~set_star:gui#setStar
+ ~ask_confirmation:
+ (fun ~title ~message ->
+ MatitaGtkMisc.ask_confirmation ~title ~message
+ ~parent:gui#main#toplevel ())
+ ~develcreator:gui#createDevelopment
+ ()
+ in
+ gui#sourceView#source_buffer#begin_not_undoable_action ();
+ s#reset ();
+ s#template ();
+ gui#sourceView#source_buffer#end_not_undoable_action ();
+ s
+
+ (* math viewers *)
+let _ =
+ let cic_math_view = MatitaMathView.cicMathView_instance () in
+ let sequents_viewer = MatitaMathView.sequentsViewer_instance () in
+ sequents_viewer#load_logo;
+ cic_math_view#set_href_callback
+ (Some (fun uri -> (MatitaMathView.cicBrowser ())#load
+ (`Uri (UriManager.uri_of_string uri))));
+ let browser_observer _ _ = MatitaMathView.refresh_all_browsers () in
+ let sequents_observer _ grafite_status =
+ sequents_viewer#reset;
+ match grafite_status.proof_status with
+ | Incomplete_proof ({ stack = stack } as incomplete_proof) ->
+ sequents_viewer#load_sequents incomplete_proof;
+ (try
+ script#setGoal (Some (Continuationals.Stack.find_goal stack));
+ let goal =
+ match script#goal with
+ None -> assert false
+ | Some n -> n
+ in
+ sequents_viewer#goto_sequent goal
+ with Failure _ -> script#setGoal None);
+ | Proof proof -> sequents_viewer#load_logo_with_qed
+ | No_proof -> sequents_viewer#load_logo
+ | Intermediate _ -> assert false (* only the engine may be in this state *)
+ in
+ script#addObserver sequents_observer;
+ script#addObserver browser_observer
+
+ (** {{{ Debugging *)
+let _ =
+ if BuildTimeConf.debug then begin
+ gui#main#debugMenu#misc#show ();
+ let addDebugItem ~label callback =
+ let item =
+ GMenu.menu_item ~packing:gui#main#debugMenu_menu#append ~label ()
+ in
+ ignore (item#connect#activate callback)
+ in
+ addDebugItem "dump environment to \"env.dump\"" (fun _ ->
+ let oc = open_out "env.dump" in
+ CicEnvironment.dump_to_channel oc;
+ close_out oc);
+ addDebugItem "load environment from \"env.dump\"" (fun _ ->
+ let ic = open_in "env.dump" in
+ CicEnvironment.restore_from_channel ic;
+ close_in ic);
+ addDebugItem "dump universes" (fun _ ->
+ List.iter (fun (u,_,g) ->
+ prerr_endline (UriManager.string_of_uri u);
+ CicUniv.print_ugraph g) (CicEnvironment.list_obj ())
+ );
+ addDebugItem "dump environment content" (fun _ ->
+ List.iter (fun (u,_,_) ->
+ prerr_endline (UriManager.string_of_uri u))
+ (CicEnvironment.list_obj ()));
+(* addDebugItem "print selections" (fun () ->
+ let cicMathView = MatitaMathView.cicMathView_instance () in
+ List.iter HLog.debug (cicMathView#string_of_selections)); *)
+ addDebugItem "dump script status" script#dump;
+ addDebugItem "dump configuration file to ./foo.conf.xml" (fun _ ->
+ Helm_registry.save_to "./foo.conf.xml");
+ addDebugItem "dump metasenv"
+ (fun _ ->
+ if script#onGoingProof () then
+ HLog.debug (CicMetaSubst.ppmetasenv [] script#proofMetasenv));
+ addDebugItem "dump coercions Db" (fun _ ->
+ List.iter
+ (fun (s,t,u) ->
+ HLog.debug
+ (UriManager.name_of_uri u ^ ":"
+ ^ CoercDb.name_of_carr s ^ " -> " ^ CoercDb.name_of_carr t))
+ (CoercDb.to_list ()));
+ addDebugItem "print top-level grammar entries"
+ CicNotationParser.print_l2_pattern;
+ addDebugItem "dump moo to stderr" (fun _ ->
+ let grafite_status = (MatitaScript.current ())#grafite_status in
+ let moo = grafite_status.moo_content_rev in
+ List.iter
+ (fun cmd ->
+ prerr_endline (GrafiteAstPp.pp_command ~obj_pp:(fun _ -> assert false)
+ cmd))
+ (List.rev moo));
+ addDebugItem "print metasenv goals and stack to stderr"
+ (fun _ ->
+ prerr_endline ("metasenv goals: " ^ String.concat " "
+ (List.map (fun (g, _, _) -> string_of_int g)
+ (MatitaScript.current ())#proofMetasenv));
+ prerr_endline ("stack: " ^ Continuationals.Stack.pp
+ (GrafiteTypes.get_stack (MatitaScript.current ())#grafite_status)));
+(* addDebugItem "ask record choice"
+ (fun _ ->
+ HLog.debug (string_of_int
+ (MatitaGtkMisc.ask_record_choice ~gui ~title:"title" ~message:"msg"
+ ~fields:["a"; "b"; "c"]
+ ~records:[
+ ["0"; "0"; "0"]; ["0"; "0"; "1"]; ["0"; "1"; "0"]; ["0"; "1"; "1"];
+ ["1"; "0"; "0"]; ["1"; "0"; "1"]; ["1"; "1"; "0"]; ["1"; "1"; "1"]]
+ ()))); *)
+ addDebugItem "rotate light bulbs"
+ (fun _ ->
+ let nb = gui#main#hintNotebook in
+ nb#goto_page ((nb#current_page + 1) mod 3));
+ addDebugItem "print runtime dir"
+ (fun _ ->
+ prerr_endline BuildTimeConf.runtime_base_dir);
+ addDebugItem "disable all (pretty printing) notations"
+ (fun _ -> CicNotation.set_active_notations []);
+ addDebugItem "enable all (pretty printing) notations"
+ (fun _ ->
+ CicNotation.set_active_notations
+ (List.map fst (CicNotation.get_all_notations ())));
+ end
+ (** Debugging }}} *)
+
+ (** {2 Command line parsing} *)
+
+let set_matita_mode () =
+ let matita_mode =
+ if Filename.basename Sys.argv.(0) = "cicbrowser" ||
+ Filename.basename Sys.argv.(0) = "cicbrowser.opt"
+ then "cicbrowser"
+ else "matita"
+ in
+ Helm_registry.set "matita.mode" matita_mode
+
+ (** {2 Main} *)
+
+let _ =
+ set_matita_mode ();
+ at_exit (fun () -> print_endline "\nThanks for using Matita!\n");
+ Sys.catch_break true;
+ let args = Helm_registry.get_list Helm_registry.string "matita.args" in
+ if Helm_registry.get "matita.mode" = "cicbrowser" then (* cicbrowser *)
+ let browser = MatitaMathView.cicBrowser () in
+ let uri = match args with [] -> "cic:/" | _ -> String.concat " " args in
+ browser#loadInput uri
+ else begin (* matita *)
+ (try gui#loadScript (List.hd args) with Failure _ -> ());
+ gui#main#mainWin#show ();
+ end;
+ try
+ GtkThread.main ()
+ with Sys.Break -> ()
+
+(* vim:set foldmethod=marker: *)
--- /dev/null
+ 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 *)
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 _ _ -> ())
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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)
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 :=
+ (function
+ | MatitaScript.ActionCancelled -> ()
+ | exn ->
+ if not (Helm_registry.get_bool "matita.debug") then
+ let floc, msg = MatitaExcPp.to_string exn in
+ begin
+ match floc with
+ None -> ()
+ | Some floc ->
+ let (x, y) = HExtlib.loc_of_floc floc in
+ let script = MatitaScript.current () in
+ let locked_mark = script#locked_mark in
+ let error_tag = script#error_tag in
+ let baseoffset =
+ (source_buffer#get_iter_at_mark (`MARK locked_mark))#offset in
+ let x' = baseoffset + x in
+ let y' = baseoffset + y in
+ let x_iter = source_buffer#get_iter (`OFFSET x') in
+ let y_iter = source_buffer#get_iter (`OFFSET y') in
+ source_buffer#apply_tag error_tag ~start:x_iter ~stop:y_iter;
+ let id = ref None in
+ id := Some (source_buffer#connect#changed ~callback:(fun () ->
+ source_buffer#remove_tag error_tag
+ ~start:source_buffer#start_iter
+ ~stop:source_buffer#end_iter;
+ match !id with
+ | None -> assert false (* a race condition occurred *)
+ | Some id ->
+ (new GObj.gobject_ops source_buffer#as_buffer)#disconnect id));
+ source_buffer#place_cursor
+ (source_buffer#get_iter (`OFFSET x'));
+ end;
+ HLog.error msg
+ else raise exn);
+ (* script *)
+ ignore (source_buffer#connect#mark_set (fun _ _ -> next_ligatures <- []));
+ let _ =
+ match GSourceView.source_language_from_file BuildTimeConf.lang_file with
+ | None ->
+ HLog.warn (sprintf "can't load language file %s"
+ BuildTimeConf.lang_file)
+ | Some matita_lang ->
+ source_buffer#set_language matita_lang;
+ source_buffer#set_highlight true
+ in
+ let s () = MatitaScript.current () in
+ let disableSave () =
+ script_fname <- None;
+ main#saveMenuItem#misc#set_sensitive false
+ in
+ let saveAsScript () =
+ let script = s () in
+ match self#chooseFile ~ok_not_exists:true () with
+ | Some f ->
+ script#assignFileName f;
+ script#saveToFile ();
+ console#message ("'"^f^"' saved.\n");
+ self#_enableSaveTo f
+ | None -> ()
+ in
+ let saveScript () =
+ match script_fname with
+ | None -> saveAsScript ()
+ | Some f ->
+ (s ())#assignFileName f;
+ (s ())#saveToFile ();
+ console#message ("'"^f^"' saved.\n");
+ in
+ let abandon_script () =
+ let lexicon_status = (s ())#lexicon_status in
+ let grafite_status = (s ())#grafite_status in
+ if source_view#buffer#modified then
+ (match ask_unsaved main#toplevel with
+ | `YES -> saveScript ()
+ | `NO -> ()
+ | `CANCEL -> raise MatitaTypes.Cancel);
+ (match script_fname with
+ | None -> ()
+ | Some fname ->
+ ask_and_save_moo_if_needed main#toplevel fname
+ lexicon_status grafite_status);
+ in
+ let loadScript () =
+ let script = s () in
+ try
+ match self#chooseFile () with
+ | Some f ->
+ abandon_script ();
+ script#reset ();
+ script#assignFileName f;
+ source_view#source_buffer#begin_not_undoable_action ();
+ script#loadFromFile f;
+ source_view#source_buffer#end_not_undoable_action ();
+ console#message ("'"^f^"' loaded.\n");
+ self#_enableSaveTo f
+ | None -> ()
+ with MatitaTypes.Cancel -> ()
+ in
+ let newScript () =
+ abandon_script ();
+ source_view#source_buffer#begin_not_undoable_action ();
+ (s ())#reset ();
+ (s ())#template ();
+ source_view#source_buffer#end_not_undoable_action ();
+ disableSave ();
+ script_fname <- None
+ in
+ let cursor () =
+ source_buffer#place_cursor
+ (source_buffer#get_iter_at_mark (`NAME "locked")) in
+ let advance _ = (MatitaScript.current ())#advance (); cursor () in
+ let retract _ = (MatitaScript.current ())#retract (); cursor () in
+ let top _ = (MatitaScript.current ())#goto `Top (); cursor () in
+ let bottom _ = (MatitaScript.current ())#goto `Bottom (); cursor () in
+ let jump _ = (MatitaScript.current ())#goto `Cursor (); cursor () in
+ let advance = locker (keep_focus advance) in
+ let retract = locker (keep_focus retract) in
+ let top = locker (keep_focus top) in
+ let bottom = locker (keep_focus bottom) in
+ let jump = locker (keep_focus jump) in
+ (* quit *)
+ self#setQuitCallback (fun () ->
+ let lexicon_status = (MatitaScript.current ())#lexicon_status in
+ let grafite_status = (MatitaScript.current ())#grafite_status in
+ if source_view#buffer#modified then
+ begin
+ let rc = ask_unsaved main#toplevel in
+ try
+ match rc with
+ | `YES -> saveScript ();
+ if not source_view#buffer#modified then
+ begin
+ (match script_fname with
+ | None -> ()
+ | Some fname ->
+ ask_and_save_moo_if_needed main#toplevel
+ fname lexicon_status grafite_status);
+ GMain.Main.quit ()
+ end
+ | `NO -> GMain.Main.quit ()
+ | `CANCEL -> raise MatitaTypes.Cancel
+ with MatitaTypes.Cancel -> ()
+ end
+ else
+ begin
+ (match script_fname with
+ | None -> clean_current_baseuri grafite_status; GMain.Main.quit ()
+ | Some fname ->
+ try
+ ask_and_save_moo_if_needed main#toplevel fname lexicon_status
+ grafite_status;
+ GMain.Main.quit ()
+ with MatitaTypes.Cancel -> ())
+ end);
+ connect_button main#scriptAdvanceButton advance;
+ connect_button main#scriptRetractButton retract;
+ connect_button main#scriptTopButton top;
+ connect_button main#scriptBottomButton bottom;
+ connect_button main#scriptJumpButton jump;
+ connect_menu_item main#scriptAdvanceMenuItem advance;
+ connect_menu_item main#scriptRetractMenuItem retract;
+ connect_menu_item main#scriptTopMenuItem top;
+ connect_menu_item main#scriptBottomMenuItem bottom;
+ connect_menu_item main#scriptJumpMenuItem jump;
+ connect_menu_item main#openMenuItem loadScript;
+ connect_menu_item main#saveMenuItem saveScript;
+ connect_menu_item main#saveAsMenuItem saveAsScript;
+ connect_menu_item main#newMenuItem newScript;
+ (* script monospace font stuff *)
+ self#updateFontSize ();
+ (* debug menu *)
+ main#debugMenu#misc#hide ();
+ (* status bar *)
+ main#hintLowImage#set_file (image_path "matita-bulb-low.png");
+ main#hintMediumImage#set_file (image_path "matita-bulb-medium.png");
+ main#hintHighImage#set_file (image_path "matita-bulb-high.png");
+ (* focus *)
+ self#sourceView#misc#grab_focus ();
+ (* main win dimension *)
+ let width = Gdk.Screen.width () in
+ let height = Gdk.Screen.height () in
+ let main_w = width * 90 / 100 in
+ let main_h = height * 80 / 100 in
+ let script_w = main_w * 6 / 10 in
+ main#toplevel#resize ~width:main_w ~height:main_h;
+ main#hpaneScriptSequent#set_position script_w;
+ (* source_view *)
+ ignore(source_view#connect#after#paste_clipboard
+ ~callback:(fun () -> (MatitaScript.current ())#clean_dirty_lock));
+ (* clean_locked is set to true only "during" a PRIMARY paste
+ operation (i.e. by clicking with the second mouse button) *)
+ let clean_locked = ref false in
+ ignore(source_view#event#connect#button_press
+ ~callback:
+ (fun button ->
+ if GdkEvent.Button.button button = 2 then
+ clean_locked := true;
+ false
+ ));
+ ignore(source_view#event#connect#button_release
+ ~callback:(fun button -> clean_locked := false; false));
+ ignore(source_view#buffer#connect#after#apply_tag
+ ~callback:(
+ fun tag ~start:_ ~stop:_ ->
+ if !clean_locked &&
+ tag#get_oid = (MatitaScript.current ())#locked_tag#get_oid
+ then
+ begin
+ clean_locked := false;
+ (MatitaScript.current ())#clean_dirty_lock;
+ clean_locked := true
+ end));
+ (* math view handling *)
+ connect_menu_item main#newCicBrowserMenuItem (fun () ->
+ ignore (MatitaMathView.cicBrowser ()));
+ connect_menu_item main#increaseFontSizeMenuItem (fun () ->
+ self#increaseFontSize ();
+ MatitaMathView.increase_font_size ();
+ MatitaMathView.update_font_sizes ());
+ connect_menu_item main#decreaseFontSizeMenuItem (fun () ->
+ self#decreaseFontSize ();
+ MatitaMathView.decrease_font_size ();
+ MatitaMathView.update_font_sizes ());
+ connect_menu_item main#normalFontSizeMenuItem (fun () ->
+ self#resetFontSize ();
+ MatitaMathView.reset_font_size ();
+ MatitaMathView.update_font_sizes ());
+ MatitaMathView.reset_font_size ();
+
+ (** selections / clipboards handling *)
+
+ method markupSelected = MatitaMathView.has_selection ()
+ method private textSelected =
+ (source_buffer#get_iter_at_mark `INSERT)#compare
+ (source_buffer#get_iter_at_mark `SEL_BOUND) <> 0
+ method private somethingSelected = self#markupSelected || self#textSelected
+ method private markupStored = MatitaMathView.has_clipboard ()
+ method private textStored = clipboard#text <> None
+ method private somethingStored = self#markupStored || self#textStored
+
+ method canCopy = self#somethingSelected
+ method canCut = self#textSelected
+ method canDelete = self#textSelected
+ method canPaste = self#somethingStored
+ method canPastePattern = self#markupStored
+
+ method copy () =
+ if self#textSelected
+ then begin
+ MatitaMathView.empty_clipboard ();
+ source_view#buffer#copy_clipboard clipboard;
+ end else
+ MatitaMathView.copy_selection ()
+ method cut () =
+ source_view#buffer#cut_clipboard clipboard;
+ MatitaMathView.empty_clipboard ()
+ method delete () = ignore (source_view#buffer#delete_selection ())
+ method paste () =
+ if MatitaMathView.has_clipboard ()
+ then source_view#buffer#insert (MatitaMathView.paste_clipboard `Term)
+ else source_view#buffer#paste_clipboard clipboard;
+ (MatitaScript.current ())#clean_dirty_lock
+ method pastePattern () =
+ source_view#buffer#insert (MatitaMathView.paste_clipboard `Pattern)
+
+ method private nextLigature () =
+ let iter = source_buffer#get_iter_at_mark `INSERT in
+ let write_ligature len s =
+ source_buffer#delete ~start:iter ~stop:(iter#copy#backward_chars len);
+ source_buffer#insert ~iter:(source_buffer#get_iter_at_mark `INSERT) s
+ in
+ let get_ligature word =
+ let len = String.length word in
+ let aux_tex () =
+ try
+ for i = len - 1 downto 0 do
+ if HExtlib.is_alpha word.[i] then ()
+ else
+ (if word.[i] = '\\' then raise (Found i) else raise (Found ~-1))
+ done;
+ None
+ with Found i ->
+ if i = ~-1 then None else Some (String.sub word i (len - i))
+ in
+ let aux_ligature () =
+ try
+ for i = len - 1 downto 0 do
+ if CicNotationLexer.is_ligature_char word.[i] then ()
+ else raise (Found (i+1))
+ done;
+ raise (Found 0)
+ with
+ | Found i ->
+ (try
+ Some (String.sub word i (len - i))
+ with Invalid_argument _ -> None)
+ in
+ match aux_tex () with
+ | Some macro -> macro
+ | None -> (match aux_ligature () with Some l -> l | None -> word)
+ in
+ (match next_ligatures with
+ | [] -> (* find ligatures and fill next_ligatures, then try again *)
+ let last_word =
+ iter#get_slice
+ ~stop:(iter#copy#backward_find_char Glib.Unichar.isspace)
+ in
+ let ligature = get_ligature last_word in
+ (match CicNotationLexer.lookup_ligatures ligature with
+ | [] -> ()
+ | hd :: tl ->
+ write_ligature (String.length ligature) hd;
+ next_ligatures <- tl @ [ hd ])
+ | hd :: tl ->
+ write_ligature 1 hd;
+ next_ligatures <- tl @ [ hd ])
+
+ method private externalEditor () =
+ let cmd = Helm_registry.get "matita.external_editor" in
+(* ZACK uncomment to enable interactive ask of external editor command *)
+(* let cmd =
+ let msg =
+ "External editor command:
+%f will be substitute for the script name,
+%p for the cursor position in bytes,
+%l for the execution point in bytes."
+ in
+ ask_text ~gui:self ~title:"External editor" ~msg ~multiline:false
+ ~default:(Helm_registry.get "matita.external_editor") ()
+ in *)
+ let fname = (MatitaScript.current ())#filename in
+ let slice mark =
+ source_buffer#start_iter#get_slice
+ ~stop:(source_buffer#get_iter_at_mark mark)
+ in
+ let script = MatitaScript.current () in
+ let locked = `MARK script#locked_mark in
+ let string_pos mark = string_of_int (String.length (slice mark)) in
+ let cursor_pos = string_pos `INSERT in
+ let locked_pos = string_pos locked in
+ let cmd =
+ Pcre.replace ~pat:"%f" ~templ:fname
+ (Pcre.replace ~pat:"%p" ~templ:cursor_pos
+ (Pcre.replace ~pat:"%l" ~templ:locked_pos
+ cmd))
+ in
+ let locked_before = slice locked in
+ let locked_offset = (source_buffer#get_iter_at_mark locked)#offset in
+ ignore (Unix.system cmd);
+ source_buffer#set_text (HExtlib.input_file fname);
+ let locked_iter = source_buffer#get_iter (`OFFSET locked_offset) in
+ source_buffer#move_mark locked locked_iter;
+ source_buffer#apply_tag script#locked_tag
+ ~start:source_buffer#start_iter ~stop:locked_iter;
+ let locked_after = slice locked in
+ let line = ref 0 in
+ let col = ref 0 in
+ try
+ for i = 0 to String.length locked_before - 1 do
+ if locked_before.[i] <> locked_after.[i] then begin
+ source_buffer#place_cursor
+ ~where:(source_buffer#get_iter (`LINEBYTE (!line, !col)));
+ script#goto `Cursor ();
+ raise Exit
+ end else if locked_before.[i] = '\n' then begin
+ incr line;
+ col := 0
+ end
+ done
+ with
+ | Exit -> ()
+ | Invalid_argument _ -> script#goto `Bottom ()
+
+ method loadScript file =
+ let script = MatitaScript.current () in
+ script#reset ();
+ script#assignFileName file;
+ let content =
+ if Sys.file_exists file then file
+ else BuildTimeConf.script_template
+ in
+ source_view#source_buffer#begin_not_undoable_action ();
+ script#loadFromFile content;
+ source_view#source_buffer#end_not_undoable_action ();
+ console#message ("'"^file^"' loaded.");
+ self#_enableSaveTo file
+
+ method setStar name b =
+ let l = main#scriptLabel in
+ if b then
+ l#set_text (name ^ " *")
+ else
+ l#set_text (name)
+
+ method private _enableSaveTo file =
+ script_fname <- Some file;
+ self#main#saveMenuItem#misc#set_sensitive true
+
+ method console = console
+ method sourceView: GSourceView.source_view =
+ (source_view: GSourceView.source_view)
+ method fileSel = fileSel
+ method findRepl = findRepl
+ method main = main
+ method develList = develList
+ method newDevel = newDevel
+
+ method newBrowserWin () =
+ object (self)
+ inherit browserWin ()
+ val combo = GEdit.combo_box_entry ()
+ initializer
+ self#check_widgets ();
+ let combo_widget = combo#coerce in
+ uriHBox#pack ~from:`END ~fill:true ~expand:true combo_widget;
+ combo#entry#misc#grab_focus ()
+ method browserUri = combo
+ end
+
+ method newUriDialog () =
+ let dialog = new uriChoiceDialog () in
+ dialog#check_widgets ();
+ dialog
+
+ method newRecordDialog () =
+ let dialog = new recordChoiceDialog () in
+ dialog#check_widgets ();
+ dialog
+
+ method newConfirmationDialog () =
+ let dialog = new confirmationDialog () in
+ dialog#check_widgets ();
+ dialog
+
+ method newEmptyDialog () =
+ let dialog = new emptyDialog () in
+ dialog#check_widgets ();
+ dialog
+
+ method private addKeyBinding key callback =
+ List.iter (fun evbox -> add_key_binding key callback evbox)
+ keyBindingBoxes
+
+ method setQuitCallback callback =
+ connect_menu_item main#quitMenuItem callback;
+ ignore (main#toplevel#event#connect#delete
+ (fun _ -> callback ();true));
+ self#addKeyBinding GdkKeysyms._q callback
+
+ method chooseFile ?(ok_not_exists = false) () =
+ _ok_not_exists <- ok_not_exists;
+ _only_directory <- false;
+ fileSel#fileSelectionWin#show ();
+ GtkThread.main ();
+ chosen_file
+
+ method private chooseDir ?(ok_not_exists = false) () =
+ _ok_not_exists <- ok_not_exists;
+ _only_directory <- true;
+ fileSel#fileSelectionWin#show ();
+ GtkThread.main ();
+ (* we should check that this is a directory *)
+ chosen_file
+
+ method createDevelopment ~containing =
+ next_devel_must_contain <- containing;
+ newDevel#toplevel#misc#show()
+
+ method askText ?(title = "") ?(msg = "") () =
+ let dialog = new textDialog () in
+ dialog#textDialog#set_title title;
+ dialog#textDialogLabel#set_label msg;
+ let text = ref None in
+ let return v =
+ text := v;
+ dialog#textDialog#destroy ();
+ GMain.Main.quit ()
+ in
+ ignore (dialog#textDialog#event#connect#delete (fun _ -> true));
+ connect_button dialog#textDialogCancelButton (fun _ -> return None);
+ connect_button dialog#textDialogOkButton (fun _ ->
+ let text = dialog#textDialogTextView#buffer#get_text () in
+ return (Some text));
+ dialog#textDialog#show ();
+ GtkThread.main ();
+ !text
+
+ method private updateFontSize () =
+ self#sourceView#misc#modify_font_by_name
+ (sprintf "%s %d" BuildTimeConf.script_font font_size)
+
+ method increaseFontSize () =
+ font_size <- font_size + 1;
+ self#updateFontSize ()
+
+ method decreaseFontSize () =
+ font_size <- font_size - 1;
+ self#updateFontSize ()
+
+ method resetFontSize () =
+ font_size <- default_font_size;
+ self#updateFontSize ()
+
+ end
+
+let gui () =
+ let g = new gui () in
+ gui_instance := Some g;
+ MatitaMathView.set_gui g;
+ g
+
+let instance = singleton gui
+
+let non p x = not (p x)
+
+(* this is a shit and should be changed :-{ *)
+let interactive_uri_choice
+ ?(selection_mode:[`SINGLE|`MULTIPLE] = `MULTIPLE) ?(title = "")
+ ?(msg = "") ?(nonvars_button = false) ?(hide_uri_entry=false)
+ ?(hide_try=false) ?(ok_label="_Auto") ?(ok_action:[`SELECT|`AUTO] = `AUTO)
+ ?copy_cb ()
+ ~id uris
+=
+ let gui = instance () in
+ let nonvars_uris = lazy (List.filter (non UriManager.uri_is_var) uris) in
+ if (selection_mode <> `SINGLE) &&
+ (Helm_registry.get_bool "matita.auto_disambiguation")
+ then
+ Lazy.force nonvars_uris
+ else begin
+ let dialog = gui#newUriDialog () in
+ if hide_uri_entry then
+ dialog#uriEntryHBox#misc#hide ();
+ if hide_try then
+ begin
+ dialog#uriChoiceSelectedButton#misc#hide ();
+ dialog#uriChoiceConstantsButton#misc#hide ();
+ end;
+ dialog#okLabel#set_label ok_label;
+ dialog#uriChoiceTreeView#selection#set_mode
+ (selection_mode :> Gtk.Tags.selection_mode);
+ let model = new stringListModel dialog#uriChoiceTreeView in
+ let choices = ref None in
+ (match copy_cb with
+ | None -> ()
+ | Some cb ->
+ dialog#copyButton#misc#show ();
+ connect_button dialog#copyButton
+ (fun _ ->
+ match model#easy_selection () with
+ | [u] -> (cb u)
+ | _ -> ()));
+ dialog#uriChoiceDialog#set_title title;
+ dialog#uriChoiceLabel#set_text msg;
+ List.iter model#easy_append (List.map UriManager.string_of_uri uris);
+ dialog#uriChoiceConstantsButton#misc#set_sensitive nonvars_button;
+ let return v =
+ choices := v;
+ dialog#uriChoiceDialog#destroy ();
+ GMain.Main.quit ()
+ in
+ ignore (dialog#uriChoiceDialog#event#connect#delete (fun _ -> true));
+ connect_button dialog#uriChoiceConstantsButton (fun _ ->
+ return (Some (Lazy.force nonvars_uris)));
+ if ok_action = `AUTO then
+ connect_button dialog#uriChoiceAutoButton (fun _ ->
+ Helm_registry.set_bool "matita.auto_disambiguation" true;
+ return (Some (Lazy.force nonvars_uris)))
+ else
+ connect_button dialog#uriChoiceAutoButton (fun _ ->
+ match model#easy_selection () with
+ | [] -> ()
+ | uris -> return (Some (List.map UriManager.uri_of_string uris)));
+ connect_button dialog#uriChoiceSelectedButton (fun _ ->
+ match model#easy_selection () with
+ | [] -> ()
+ | uris -> return (Some (List.map UriManager.uri_of_string uris)));
+ connect_button dialog#uriChoiceAbortButton (fun _ -> return None);
+ dialog#uriChoiceDialog#show ();
+ GtkThread.main ();
+ (match !choices with
+ | None -> raise MatitaTypes.Cancel
+ | Some uris -> uris)
+ end
+
+class interpModel =
+ let cols = new GTree.column_list in
+ let id_col = cols#add Gobject.Data.string in
+ let dsc_col = cols#add Gobject.Data.string in
+ let interp_no_col = cols#add Gobject.Data.int in
+ let tree_store = GTree.tree_store cols in
+ let id_renderer = GTree.cell_renderer_text [], ["text", id_col] in
+ let dsc_renderer = GTree.cell_renderer_text [], ["text", dsc_col] in
+ let id_view_col = GTree.view_column ~renderer:id_renderer () in
+ let dsc_view_col = GTree.view_column ~renderer:dsc_renderer () in
+ fun tree_view choices ->
+ object
+ initializer
+ tree_view#set_model (Some (tree_store :> GTree.model));
+ ignore (tree_view#append_column id_view_col);
+ ignore (tree_view#append_column dsc_view_col);
+ let name_of_interp =
+ (* try to find a reasonable name for an interpretation *)
+ let idx = ref 0 in
+ fun interp ->
+ try
+ List.assoc "0" interp
+ with Not_found ->
+ incr idx; string_of_int !idx
+ in
+ tree_store#clear ();
+ let idx = ref ~-1 in
+ List.iter
+ (fun interp ->
+ incr idx;
+ let interp_row = tree_store#append () in
+ tree_store#set ~row:interp_row ~column:id_col
+ (name_of_interp interp);
+ tree_store#set ~row:interp_row ~column:interp_no_col !idx;
+ List.iter
+ (fun (id, dsc) ->
+ let row = tree_store#append ~parent:interp_row () in
+ tree_store#set ~row ~column:id_col id;
+ tree_store#set ~row ~column:dsc_col dsc;
+ tree_store#set ~row ~column:interp_no_col !idx)
+ interp)
+ choices
+
+ method get_interp_no tree_path =
+ let iter = tree_store#get_iter tree_path in
+ tree_store#get ~row:iter ~column:interp_no_col
+ end
+
+let interactive_interp_choice () choices =
+ let gui = instance () in
+ assert (choices <> []);
+ let dialog = gui#newRecordDialog () in
+ let model = new interpModel dialog#recordChoiceTreeView choices in
+ dialog#recordChoiceDialog#set_title "Interpretation choice";
+ dialog#recordChoiceDialogLabel#set_label "Choose an interpretation:";
+ let interp_no = ref None in
+ let return _ =
+ dialog#recordChoiceDialog#destroy ();
+ GMain.Main.quit ()
+ in
+ let fail _ = interp_no := None; return () in
+ ignore (dialog#recordChoiceDialog#event#connect#delete (fun _ -> true));
+ connect_button dialog#recordChoiceOkButton (fun _ ->
+ match !interp_no with None -> () | Some _ -> return ());
+ connect_button dialog#recordChoiceCancelButton fail;
+ ignore (dialog#recordChoiceTreeView#connect#row_activated (fun path _ ->
+ interp_no := Some (model#get_interp_no path);
+ return ()));
+ let selection = dialog#recordChoiceTreeView#selection in
+ ignore (selection#connect#changed (fun _ ->
+ match selection#get_selected_rows with
+ | [path] -> interp_no := Some (model#get_interp_no path)
+ | _ -> assert false));
+ dialog#recordChoiceDialog#show ();
+ GtkThread.main ();
+ (match !interp_no with Some row -> [row] | _ -> raise MatitaTypes.Cancel)
+
+let _ =
+ (* disambiguator callbacks *)
+ GrafiteDisambiguator.set_choose_uris_callback (interactive_uri_choice ());
+ GrafiteDisambiguator.set_choose_interp_callback (interactive_interp_choice ());
+ (* gtk initialization *)
+ GtkMain.Rc.add_default_file BuildTimeConf.gtkrc_file; (* loads gtk rc *)
+ GMathView.add_configuration_path BuildTimeConf.gtkmathview_conf;
+ ignore (GMain.Main.init ())
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+type thingsToInitilaize =
+ ConfigurationFile | Db | Environment | Getter | Makelib | CmdLine | Registry
+
+exception FailedToInitialize of thingsToInitilaize
+
+let wants s l =
+ List.iter (
+ fun item ->
+ if not (List.exists (fun x -> x = item) l) then
+ raise (FailedToInitialize item))
+ s
+
+let already_configured s l =
+ List.for_all (fun item -> List.exists (fun x -> x = item) l) s
+
+let conffile = ref BuildTimeConf.matita_conf
+
+let registry_defaults =
+ [
+ "db.nodb", "false";
+ "matita.system", "false";
+ "matita.debug", "false";
+ "matita.external_editor", "gvim -f -c 'go %p' %f";
+ "matita.preserve", "false";
+ "matita.quiet", "false";
+ "matita.profile", "true";
+ ]
+
+let set_registry_values =
+ List.iter (fun key, value -> Helm_registry.set ~key ~value)
+
+let fill_registry init_status =
+ if not (already_configured [ Registry ] init_status) then begin
+ set_registry_values registry_defaults;
+ Registry :: init_status
+ end else
+ init_status
+
+let load_configuration init_status =
+ wants [ Registry ] init_status;
+ if not (already_configured [ConfigurationFile] init_status) then
+ begin
+ Helm_registry.load_from !conffile;
+ if not (Helm_registry.has "user.name") then begin
+ let login = (Unix.getpwuid (Unix.getuid ())).Unix.pw_name in
+ Helm_registry.set "user.name" login
+ end;
+ if Helm_registry.get_bool "matita.system" then
+ Helm_registry.set "user.home" BuildTimeConf.runtime_base_dir;
+ ConfigurationFile::init_status
+ end
+ else
+ init_status
+
+let initialize_db init_status =
+ wants [ ConfigurationFile; CmdLine ] init_status;
+ if not (already_configured [ Db ] init_status) then
+ begin
+ if not (Helm_registry.get_bool "matita.system") then
+ MetadataTypes.ownerize_tables (Helm_registry.get "matita.owner");
+ LibraryDb.create_owner_environment ();
+ Db::init_status
+ end
+ else
+ init_status
+
+let initialize_makelib init_status =
+ wants [ConfigurationFile] init_status;
+ if not (already_configured [Makelib] init_status) then
+ begin
+ MatitamakeLib.initialize ();
+ Makelib::init_status
+ end
+ else
+ init_status
+
+let initialize_environment init_status =
+ wants [ConfigurationFile] init_status;
+ if not (already_configured [Getter;Environment] init_status) then
+ begin
+ Http_getter.init ();
+ CicEnvironment.set_trust (* environment trust *)
+ (let trust =
+ Helm_registry.get_opt_default Helm_registry.get_bool
+ ~default:true "matita.environment_trust" in
+ fun _ -> trust);
+ Getter::Environment::init_status
+ end
+ else
+ init_status
+
+let status = ref []
+
+let usages = Hashtbl.create 11
+let _ =
+ List.iter
+ (fun (name, s) -> Hashtbl.replace usages name s)
+ [ "matitac",
+ sprintf "MatitaC v%s
+Usage: matitac [ OPTION ... ] FILE
+Options:"
+ BuildTimeConf.version;
+ "matita",
+ sprintf "Matita v%s
+Usage: matita [ OPTION ... ] [ FILE ... ]
+Options:"
+ BuildTimeConf.version;
+ "cicbrowser",
+ sprintf
+ "CIC Browser v%s
+Usage: cicbrowser [ URL | WHELP QUERY ]
+Options:"
+ BuildTimeConf.version;
+ "matitadep",
+ sprintf "MatitaDep v%s
+Usage: matitadep [ OPTION ... ] FILE ...
+Options:"
+ BuildTimeConf.version;
+ "matitaclean",
+ sprintf "MatitaClean v%s
+Usage: matitaclean all
+ matitaclean [ (FILE | URI) ... ]
+Options:"
+ BuildTimeConf.version;
+ ]
+let default_usage =
+ sprintf "Matita v%s\nUsage: matita [ ARG ]\nOptions:" BuildTimeConf.version
+
+let usage () =
+ let basename = Filename.basename Sys.argv.(0) in
+ let usage_key =
+ try Filename.chop_extension basename with Invalid_argument _ -> basename
+ in
+ try Hashtbl.find usages usage_key with Not_found -> default_usage
+
+let parse_cmdline init_status =
+ if not (already_configured [CmdLine] init_status) then begin
+ let includes = ref [ BuildTimeConf.stdlib_dir ] in
+ let args = ref [] in
+ let add_l l = fun s -> l := s :: !l in
+ let arg_spec =
+ let std_arg_spec = [
+ "-I", Arg.String (add_l includes),
+ ("<path> Adds path to the list of searched paths for the "
+ ^ "include command");
+ "-conffile", Arg.Set_string conffile,
+ (Printf.sprintf "<filename> Read configuration from filename (default: %s)"
+ BuildTimeConf.matita_conf);
+ "-q", Arg.Unit (fun () -> Helm_registry.set_bool "matita.quiet" true),
+ "Turn off verbose compilation";
+ "-preserve",
+ Arg.Unit (fun () -> Helm_registry.set_bool "matita.preserve" true),
+ "Turns off automatic baseuri cleaning";
+ "-nodb", Arg.Unit (fun () -> Helm_registry.set_bool "db.nodb" true),
+ ("Avoid using external database connection "
+ ^ "(WARNING: disable many features)");
+ "-system", Arg.Unit (fun () ->
+ Helm_registry.set_bool "matita.system" true),
+ ("Act on the system library instead of the user one"
+ ^ "(WARNING: not for the casual user)");
+ "-noprofile",
+ Arg.Unit (fun () -> Helm_registry.set_bool "matita.profile" false),
+ "Turns off profiling printings";
+ ] in
+ let debug_arg_spec =
+ if BuildTimeConf.debug then
+ [ "-debug",
+ Arg.Unit (fun () -> Helm_registry.set_bool "matita.debug" true),
+ ("Do not catch top-level exception "
+ ^ "(useful for backtrace inspection)");
+ ]
+ else []
+ in
+ std_arg_spec @ debug_arg_spec
+ in
+ let set_list ~key l =
+ Helm_registry.set_list Helm_registry.of_string ~key ~value:(List.rev !l)
+ in
+ Arg.parse arg_spec (add_l args) (usage ());
+ set_list ~key:"matita.includes" includes;
+ set_list ~key:"matita.args" args;
+ HExtlib.set_profiling_printings
+ (fun () -> Helm_registry.get_bool "matita.profile");
+ CmdLine :: init_status
+ end else
+ init_status
+
+let die_usage () =
+ print_endline (usage ());
+ exit 1
+
+let initialize_all () =
+ status :=
+ List.fold_left (fun s f -> f s) !status
+ [ fill_registry;
+ parse_cmdline; load_configuration; initialize_makelib;
+ initialize_db; initialize_environment ]
+(* initialize_notation
+ (initialize_environment
+ (initialize_db
+ (initialize_makelib
+ (load_configuration
+ (parse_cmdline !status))))) *)
+
+let load_configuration_file () =
+ status := load_configuration !status
+
+let parse_cmdline () =
+ status := parse_cmdline !status
+
+let fill_registry () =
+ status := fill_registry !status
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+ (** {2 global initialization} *)
+val initialize_all: unit -> unit
+
+ (** {2 per-components initialization} *)
+val fill_registry: unit -> unit (** fill registry with default values *)
+val parse_cmdline: unit -> unit (** parse cmdline setting registry keys *)
+val load_configuration_file: unit -> unit
+
+ (** {2 Utilities} *)
+
+ (** die nicely: exit with return code 1 printing usage error message *)
+val die_usage: unit -> 'a
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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));
+ if BuildTimeConf.debug then begin
+ let name = "sequent_viewer.xml" in
+ HLog.debug ("load_sequent: dumping MathML to ./" ^ name);
+ ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ())
+ end;
+ self#load_root ~root:mathml#get_documentElement
+
+ method load_object obj =
+ let use_diff = false in (* ZACK TODO use XmlDiff when re-rendering? *)
+ let (mathml,
+ (annobj, (ids_to_terms, ids_to_father_ids, _, ids_to_hypotheses, _, ids_to_inner_types)))
+ =
+ ApplyTransformation.mml_of_cic_object obj
+ in
+ self#set_cic_info
+ (Some (None, ids_to_terms, ids_to_hypotheses, ids_to_father_ids, ids_to_inner_types, Some annobj));
+ (match current_mathml with
+ | Some current_mathml when use_diff ->
+ self#freeze;
+ XmlDiff.update_dom ~from:current_mathml mathml;
+ self#thaw
+ | _ ->
+ if BuildTimeConf.debug then begin
+ let name = "cic_browser.xml" in
+ HLog.debug ("cic_browser: dumping MathML to ./" ^ name);
+ ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ())
+ end;
+ self#load_root ~root:mathml#get_documentElement;
+ current_mathml <- Some mathml);
+end
+
+let tab_label meta_markup =
+ let rec aux =
+ function
+ | `Current m -> sprintf "<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)
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+open Printf
+open GrafiteTypes
+
+module TA = GrafiteAst
+
+let debug = false
+let debug_print = if debug then prerr_endline else ignore
+
+ (** raised when one of the script margins (top or bottom) is reached *)
+exception Margin
+exception NoUnfinishedProof
+exception ActionCancelled
+
+let safe_substring s i j =
+ try String.sub s i j with Invalid_argument _ -> assert false
+
+let heading_nl_RE = Pcre.regexp "^\\s*\n\\s*"
+let heading_nl_RE' = Pcre.regexp "^(\\s*\n\\s*)((.|\n)*)"
+let only_dust_RE = Pcre.regexp "^(\\s|\n|%%[^\n]*\n)*$"
+let multiline_RE = Pcre.regexp "^\n[^\n]+$"
+let newline_RE = Pcre.regexp "\n"
+
+let comment str =
+ if Pcre.pmatch ~rex:multiline_RE str then
+ "\n(** " ^ (Pcre.replace ~rex:newline_RE str) ^ " *)"
+ else
+ "\n(**\n" ^ str ^ "\n*)"
+
+let first_line s =
+ let s = Pcre.replace ~rex:heading_nl_RE s in
+ try
+ let nl_pos = String.index s '\n' in
+ String.sub s 0 nl_pos
+ with Not_found -> s
+
+ (** creates a statement AST for the Goal tactic, e.g. "goal 7" *)
+let goal_ast n =
+ let module A = GrafiteAst in
+ let loc = HExtlib.dummy_floc in
+ A.Executable (loc, A.Tactical (loc,
+ A.Tactic (loc, A.Goal (loc, n)),
+ Some (A.Dot loc)))
+
+type guistuff = {
+ mathviewer:MatitaTypes.mathViewer;
+ urichooser: UriManager.uri list -> UriManager.uri list;
+ ask_confirmation: title:string -> message:string -> [`YES | `NO | `CANCEL];
+ develcreator: containing:string option -> unit;
+ mutable filenamedata: string option * MatitamakeLib.development option
+}
+
+let eval_with_engine guistuff lexicon_status grafite_status user_goal
+ parsed_text st
+=
+ let module TAPp = GrafiteAstPp in
+ let parsed_text_length = String.length parsed_text in
+ let initial_space,parsed_text =
+ try
+ let pieces = Pcre.extract ~rex:heading_nl_RE' parsed_text in
+ pieces.(1), pieces.(2)
+ with
+ Not_found -> "", parsed_text in
+ let inital_space,new_grafite_status,new_lexicon_status,new_status_and_text_list' =
+ (* the code commented out adds the "select" command if needed *)
+ initial_space,grafite_status,lexicon_status,[] in
+(* let loc, ex =
+ match st with TA.Executable (loc,ex) -> loc, ex | _ -> assert false in
+ match grafite_status.proof_status with
+ | Incomplete_proof { stack = stack }
+ when not (List.mem user_goal (Continuationals.head_goals stack)) ->
+ let grafite_status =
+ MatitaEngine.eval_ast
+ ~do_heavy_checks:true grafite_status (goal_ast user_goal)
+ in
+ let initial_space = if initial_space = "" then "\n" else initial_space
+ in
+ "\n", grafite_status,
+ [ grafite_status,
+ initial_space ^ TAPp.pp_tactical (TA.Select (loc, [user_goal])) ]
+ | _ -> initial_space,grafite_status,[] in *)
+ let enriched_history_fragment =
+ MatitaEngine.eval_ast ~do_heavy_checks:true
+ new_lexicon_status new_grafite_status st
+ in
+ let _,new_text_list_rev =
+ let module DTE = DisambiguateTypes.Environment in
+ let module UM = UriManager in
+ List.fold_right (
+ fun (_,alias) (initial_space,acc) ->
+ match alias with
+ None -> initial_space,initial_space::acc
+ | Some (k,((v,_) as value)) ->
+ let new_text =
+ let initial_space =
+ if initial_space = "" then "\n" else initial_space
+ in
+ initial_space ^
+ DisambiguatePp.pp_environment
+ (DisambiguateTypes.Environment.add k value
+ DisambiguateTypes.Environment.empty)
+ in
+ "\n",new_text::acc
+ ) enriched_history_fragment (initial_space,[]) in
+ let new_text_list_rev =
+ match enriched_history_fragment,new_text_list_rev with
+ (_,None)::_, initial_space::tl -> (initial_space ^ parsed_text)::tl
+ | _,_ -> assert false
+ in
+ let res =
+ try
+ List.combine (fst (List.split enriched_history_fragment)) new_text_list_rev
+ with
+ Invalid_argument _ -> assert false
+ in
+ res,parsed_text_length
+
+let wrap_with_developments guistuff f arg =
+ try
+ f arg
+ with
+ | DependenciesParser.UnableToInclude what
+ | LexiconEngine.IncludedFileNotCompiled what
+ | GrafiteEngine.IncludedFileNotCompiled what as exc ->
+ let compile_needed_and_go_on d =
+ let target = Pcre.replace ~pat:"lexicon$" ~templ:"moo" what in
+ let refresh_cb () =
+ while Glib.Main.pending () do ignore(Glib.Main.iteration false); done
+ in
+ if not(MatitamakeLib.build_development_in_bg ~target refresh_cb d) then
+ raise exc
+ else
+ f arg
+ in
+ let do_nothing () = raise ActionCancelled in
+ let handle_with_devel d =
+ let name = MatitamakeLib.name_for_development d in
+ let title = "Unable to include " ^ what in
+ let message =
+ what ^ " is handled by development <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 eval_with_engine
+ guistuff lexicon_status grafite_status user_goal parsed_text st
+=
+ wrap_with_developments guistuff
+ (eval_with_engine
+ guistuff lexicon_status grafite_status user_goal parsed_text) st
+;;
+
+let pp_eager_statement_ast =
+ GrafiteAstPp.pp_statement ~term_pp:CicNotationPp.pp_term
+ ~lazy_term_pp:(fun _ -> assert false) ~obj_pp:(fun _ -> assert false)
+
+let rec eval_macro include_paths (buffer : GText.buffer) guistuff lexicon_status grafite_status user_goal unparsed_text parsed_text script mac =
+ let module TAPp = GrafiteAstPp in
+ let module MQ = MetadataQuery in
+ let module MDB = LibraryDb in
+ let module CTC = CicTypeChecker in
+ let module CU = CicUniv in
+ (* no idea why ocaml wants this *)
+ let parsed_text_length = String.length parsed_text in
+ let dbd = LibraryDb.instance () in
+ (* XXX use a real CIC -> string pretty printer *)
+ let pp_macro = TAPp.pp_macro ~term_pp:CicPp.ppterm in
+ match mac with
+ (* WHELP's stuff *)
+ | TA.WMatch (loc, term) ->
+ let l = Whelp.match_term ~dbd term in
+ let query_url =
+ MatitaMisc.strip_suffix ~suffix:"."
+ (HExtlib.trim_blanks unparsed_text)
+ in
+ let entry = `Whelp (query_url, l) in
+ guistuff.mathviewer#show_uri_list ~reuse:true ~entry l;
+ [], parsed_text_length
+ | TA.WInstance (loc, term) ->
+ let l = Whelp.instance ~dbd term in
+ let entry = `Whelp (pp_macro (TA.WInstance (loc, term)), l) in
+ guistuff.mathviewer#show_uri_list ~reuse:true ~entry l;
+ [], parsed_text_length
+ | TA.WLocate (loc, s) ->
+ let l = Whelp.locate ~dbd s in
+ let entry = `Whelp (pp_macro (TA.WLocate (loc, s)), l) in
+ guistuff.mathviewer#show_uri_list ~reuse:true ~entry l;
+ [], parsed_text_length
+ | TA.WElim (loc, term) ->
+ let uri =
+ match term with
+ | Cic.MutInd (uri,n,_) -> UriManager.uri_of_uriref uri n None
+ | _ -> failwith "Not a MutInd"
+ in
+ let l = Whelp.elim ~dbd uri in
+ let entry = `Whelp (pp_macro (TA.WElim (loc, term)), l) in
+ guistuff.mathviewer#show_uri_list ~reuse:true ~entry l;
+ [], parsed_text_length
+ | TA.WHint (loc, term) ->
+ let s = ((None,[0,[],term], Cic.Meta (0,[]) ,term),0) in
+ let l = List.map fst (MQ.experimental_hint ~dbd s) in
+ let entry = `Whelp (pp_macro (TA.WHint (loc, term)), l) in
+ guistuff.mathviewer#show_uri_list ~reuse:true ~entry l;
+ [], parsed_text_length
+ (* REAL macro *)
+ | TA.Hint loc ->
+ let user_goal' =
+ match user_goal with
+ Some n -> n
+ | None -> raise NoUnfinishedProof
+ in
+ let proof = GrafiteTypes.get_current_proof grafite_status in
+ let proof_status = proof,user_goal' in
+ let l = List.map fst (MQ.experimental_hint ~dbd proof_status) in
+ let selected = guistuff.urichooser l in
+ (match selected with
+ | [] -> [], parsed_text_length
+ | [uri] ->
+ let suri = UriManager.string_of_uri uri in
+ let ast loc =
+ TA.Executable (loc, (TA.Tactical (loc,
+ TA.Tactic (loc,
+ TA.Apply (loc, CicNotationPt.Uri (suri, None))),
+ Some (TA.Dot loc)))) in
+ let text =
+ comment parsed_text ^ "\n" ^
+ pp_eager_statement_ast (ast HExtlib.dummy_floc) in
+ let text_len = String.length text in
+ let loc = HExtlib.floc_of_loc (0,text_len) in
+ let statement = `Ast (GrafiteParser.LSome (ast loc),text) in
+ let res,_parsed_text_len =
+ eval_statement include_paths buffer guistuff lexicon_status
+ grafite_status user_goal script statement
+ in
+ (* we need to replace all the parsed_text *)
+ res,String.length parsed_text
+ | _ ->
+ HLog.error
+ "The result of the urichooser should be only 1 uri, not:\n";
+ List.iter (
+ fun u -> HLog.error (UriManager.string_of_uri u ^ "\n")
+ ) selected;
+ assert false)
+ | TA.Check (_,term) ->
+ let metasenv = GrafiteTypes.get_proof_metasenv grafite_status in
+ let context =
+ match user_goal with
+ None -> []
+ | Some n -> GrafiteTypes.get_proof_context grafite_status n in
+ let ty,_ = CTC.type_of_aux' metasenv context term CicUniv.empty_ugraph in
+ let t_and_ty = Cic.Cast (term,ty) in
+ guistuff.mathviewer#show_entry (`Cic (t_and_ty,metasenv));
+ [], parsed_text_length
+ (* TODO *)
+ | TA.Quit _ -> failwith "not implemented"
+ | TA.Print (_,kind) -> failwith "not implemented"
+ | TA.Search_pat (_, search_kind, str) -> failwith "not implemented"
+ | TA.Search_term (_, search_kind, term) -> failwith "not implemented"
+
+and eval_executable include_paths (buffer : GText.buffer) guistuff lexicon_status grafite_status user_goal unparsed_text parsed_text script loc ex
+=
+ let module TAPp = GrafiteAstPp in
+ let module MD = GrafiteDisambiguator in
+ let module ML = MatitaMisc in
+ try
+ begin
+ match ex with
+ | TA.Command (_,TA.Set (_,"baseuri",u)) ->
+ if not (GrafiteMisc.is_empty u) then
+ (match
+ guistuff.ask_confirmation
+ ~title:"Baseuri redefinition"
+ ~message:(
+ "Baseuri " ^ u ^ " already exists.\n" ^
+ "Do you want to redefine the corresponding "^
+ "part of the library?")
+ with
+ | `YES ->
+ let basedir = Helm_registry.get "matita.basedir" in
+ LibraryClean.clean_baseuris ~basedir [u]
+ | `NO -> ()
+ | `CANCEL -> raise MatitaTypes.Cancel)
+ | _ -> ()
+ end;
+ eval_with_engine
+ guistuff lexicon_status grafite_status user_goal parsed_text
+ (TA.Executable (loc, ex))
+ with
+ MatitaTypes.Cancel -> [], 0
+ | GrafiteEngine.Macro (_loc,lazy_macro) ->
+ let context =
+ match user_goal with
+ None -> []
+ | Some n -> GrafiteTypes.get_proof_context grafite_status n in
+ let grafite_status,macro = lazy_macro context in
+ eval_macro include_paths buffer guistuff lexicon_status grafite_status
+ user_goal unparsed_text parsed_text script macro
+
+and eval_statement include_paths (buffer : GText.buffer) guistuff lexicon_status
+ grafite_status user_goal script statement
+=
+ let (lexicon_status,st), unparsed_text =
+ match statement with
+ | `Raw text ->
+ if Pcre.pmatch ~rex:only_dust_RE text then raise Margin;
+ let ast =
+ wrap_with_developments guistuff
+ (GrafiteParser.parse_statement
+ (Ulexing.from_utf8_string text) ~include_paths) lexicon_status
+ in
+ ast, text
+ | `Ast (st, text) -> (lexicon_status, st), text
+ in
+ let text_of_loc loc =
+ let parsed_text_length = snd (HExtlib.loc_of_floc loc) in
+ let parsed_text = safe_substring unparsed_text 0 parsed_text_length in
+ parsed_text, parsed_text_length
+ in
+ match st with
+ | GrafiteParser.LNone loc ->
+ let parsed_text, parsed_text_length = text_of_loc loc in
+ [(grafite_status,lexicon_status),parsed_text],
+ parsed_text_length
+ | GrafiteParser.LSome (GrafiteAst.Comment (loc, _)) ->
+ let parsed_text, parsed_text_length = text_of_loc loc in
+ let remain_len = String.length unparsed_text - parsed_text_length in
+ let s = String.sub unparsed_text parsed_text_length remain_len in
+ let s,len =
+ try
+ eval_statement include_paths buffer guistuff lexicon_status
+ grafite_status user_goal script (`Raw s)
+ with
+ HExtlib.Localized (floc, exn) ->
+ HExtlib.raise_localized_exception ~offset:parsed_text_length floc exn
+ | GrafiteDisambiguator.DisambiguationError (offset,errorll) ->
+ raise
+ (GrafiteDisambiguator.DisambiguationError
+ (offset+parsed_text_length, errorll))
+ in
+ (match s with
+ | (statuses,text)::tl ->
+ (statuses,parsed_text ^ text)::tl,parsed_text_length + len
+ | [] -> [], 0)
+ | GrafiteParser.LSome (GrafiteAst.Executable (loc, ex)) ->
+ let parsed_text, parsed_text_length = text_of_loc loc in
+ eval_executable include_paths buffer guistuff lexicon_status
+ grafite_status user_goal unparsed_text parsed_text script loc ex
+
+let fresh_script_id =
+ let i = ref 0 in
+ fun () -> incr i; !i
+
+class script ~(source_view: GSourceView.source_view)
+ ~(mathviewer: MatitaTypes.mathViewer)
+ ~set_star
+ ~ask_confirmation
+ ~urichooser
+ ~develcreator
+ () =
+let buffer = source_view#buffer in
+let source_buffer = source_view#source_buffer in
+let initial_statuses =
+ (* these include_paths are used only to load the initial notation *)
+ let include_paths =
+ Helm_registry.get_list Helm_registry.string "matita.includes" in
+ let lexicon_status =
+ CicNotation2.load_notation ~include_paths
+ BuildTimeConf.core_notation_script in
+ let grafite_status = GrafiteSync.init () in
+ grafite_status,lexicon_status
+in
+object (self)
+ val mutable include_paths =
+ Helm_registry.get_list Helm_registry.string "matita.includes"
+
+ val scriptId = fresh_script_id ()
+
+ val guistuff = {
+ mathviewer = mathviewer;
+ urichooser = urichooser;
+ ask_confirmation = ask_confirmation;
+ develcreator = develcreator;
+ filenamedata = (None, None)}
+
+ method private getFilename =
+ match guistuff.filenamedata with Some f,_ -> f | _ -> assert false
+
+ method filename = self#getFilename
+
+ method private ppFilename =
+ match guistuff.filenamedata with
+ | Some f,_ -> f
+ | None,_ -> sprintf ".unnamed%d.ma" scriptId
+
+ initializer
+ ignore (GMain.Timeout.add ~ms:300000
+ ~callback:(fun _ -> self#_saveToBackupFile ();true));
+ ignore (buffer#connect#modified_changed
+ (fun _ -> set_star (Filename.basename self#ppFilename) buffer#modified))
+
+ val mutable statements = [] (** executed statements *)
+
+ val mutable history = [ initial_statuses ]
+ (** list of states before having executed statements. Head element of this
+ * list is the current state, last element is the state at the beginning of
+ * the script.
+ * Invariant: this list length is 1 + length of statements *)
+
+ (** goal as seen by the user (i.e. metano corresponding to current tab) *)
+ val mutable userGoal = None
+
+ (** text mark and tag representing locked part of a script *)
+ val locked_mark =
+ buffer#create_mark ~name:"locked" ~left_gravity:true buffer#start_iter
+ val locked_tag = buffer#create_tag [`BACKGROUND "lightblue"; `EDITABLE false]
+ val error_tag = buffer#create_tag [`UNDERLINE `SINGLE; `FOREGROUND "red"]
+
+ method locked_mark = locked_mark
+ method locked_tag = locked_tag
+ method error_tag = error_tag
+
+ (* history can't be empty, the invariant above grant that it contains at
+ * least the init grafite_status *)
+ method grafite_status = match history with (s,_)::_ -> s | _ -> assert false
+ method lexicon_status = match history with (_,ss)::_ -> ss | _ -> assert false
+
+ method private _advance ?statement () =
+ let s = match statement with Some s -> s | None -> self#getFuture in
+ HLog.debug ("evaluating: " ^ first_line s ^ " ...");
+ let (entries, parsed_len) =
+ try
+ eval_statement include_paths buffer guistuff self#lexicon_status
+ self#grafite_status userGoal self (`Raw s)
+ with End_of_file -> raise Margin
+ in
+ let new_statuses, new_statements =
+ let statuses, texts = List.split entries in
+ statuses, texts
+ in
+ history <- new_statuses @ history;
+ statements <- new_statements @ statements;
+ let start = buffer#get_iter_at_mark (`MARK locked_mark) in
+ let new_text = String.concat "" (List.rev new_statements) in
+ if statement <> None then
+ buffer#insert ~iter:start new_text
+ else begin
+ if new_text <> String.sub s 0 parsed_len then begin
+ buffer#delete ~start ~stop:(start#copy#forward_chars parsed_len);
+ buffer#insert ~iter:start new_text;
+ end;
+ end;
+ self#moveMark (String.length new_text);
+ (* here we need to set the Goal in case we are going to cursor (or to
+ bottom) and we will face a macro *)
+ match self#grafite_status.proof_status with
+ Incomplete_proof p ->
+ userGoal <-
+ (try Some (Continuationals.Stack.find_goal p.stack)
+ with Failure _ -> None)
+ | _ -> userGoal <- None
+
+ method private _retract offset lexicon_status grafite_status new_statements
+ new_history
+ =
+ let cur_grafite_status,cur_lexicon_status =
+ match history with s::_ -> s | [] -> assert false
+ in
+ LexiconSync.time_travel ~present:cur_lexicon_status ~past:lexicon_status;
+ GrafiteSync.time_travel ~present:cur_grafite_status ~past:grafite_status;
+ statements <- new_statements;
+ history <- new_history;
+ self#moveMark (- offset)
+
+ method advance ?statement () =
+ try
+ self#_advance ?statement ();
+ self#notify
+ with
+ | Margin -> self#notify
+ | exc -> self#notify; raise exc
+
+ method retract () =
+ try
+ let cmp,new_statements,new_history,(grafite_status,lexicon_status) =
+ match statements,history with
+ stat::statements, _::(status::_ as history) ->
+ String.length stat, statements, history, status
+ | [],[_] -> raise Margin
+ | _,_ -> assert false
+ in
+ self#_retract cmp lexicon_status grafite_status new_statements
+ new_history;
+ self#notify
+ with
+ | Margin -> self#notify
+ | exc -> self#notify; raise exc
+
+ method private getFuture =
+ buffer#get_text ~start:(buffer#get_iter_at_mark (`MARK locked_mark))
+ ~stop:buffer#end_iter ()
+
+
+ (** @param rel_offset relative offset from current position of locked_mark *)
+ method private moveMark rel_offset =
+ let mark = `MARK locked_mark in
+ let old_insert = buffer#get_iter_at_mark `INSERT in
+ buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter;
+ let current_mark_pos = buffer#get_iter_at_mark mark in
+ let new_mark_pos =
+ match rel_offset with
+ | 0 -> current_mark_pos
+ | n when n > 0 -> current_mark_pos#forward_chars n
+ | n (* when n < 0 *) -> current_mark_pos#backward_chars (abs n)
+ in
+ buffer#move_mark mark ~where:new_mark_pos;
+ buffer#apply_tag locked_tag ~start:buffer#start_iter ~stop:new_mark_pos;
+ buffer#move_mark `INSERT old_insert;
+ let mark_position = buffer#get_iter_at_mark mark in
+ if source_view#move_mark_onscreen mark then
+ begin
+ buffer#move_mark mark mark_position;
+ source_view#scroll_to_mark ~use_align:true ~xalign:1.0 ~yalign:0.1 mark;
+ end;
+ while Glib.Main.pending () do ignore(Glib.Main.iteration false); done
+
+ method clean_dirty_lock =
+ let lock_mark_iter = buffer#get_iter_at_mark (`MARK locked_mark) in
+ buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter;
+ buffer#apply_tag locked_tag ~start:buffer#start_iter ~stop:lock_mark_iter
+
+ val mutable observers = []
+
+ method addObserver (o: LexiconEngine.status -> GrafiteTypes.status -> unit) =
+ observers <- o :: observers
+
+ method private notify =
+ let lexicon_status = self#lexicon_status in
+ let grafite_status = self#grafite_status in
+ List.iter (fun o -> o lexicon_status grafite_status) observers
+
+ method loadFromFile f =
+ buffer#set_text (HExtlib.input_file f);
+ self#reset_buffer;
+ buffer#set_modified false
+
+ method assignFileName file =
+ let abspath = MatitaMisc.absolute_path file in
+ let dirname = Filename.dirname abspath in
+ let devel = MatitamakeLib.development_for_dir dirname in
+ guistuff.filenamedata <- Some abspath, devel;
+ let include_ =
+ match MatitamakeLib.development_for_dir dirname with
+ None -> []
+ | Some devel -> [MatitamakeLib.root_for_development devel] in
+ let include_ =
+ include_ @ (Helm_registry.get_list Helm_registry.string "matita.includes")
+ in
+ include_paths <- include_
+
+ method saveToFile () =
+ let oc = open_out self#getFilename in
+ output_string oc (buffer#get_text ~start:buffer#start_iter
+ ~stop:buffer#end_iter ());
+ close_out oc;
+ buffer#set_modified false
+
+ method private _saveToBackupFile () =
+ if buffer#modified then
+ begin
+ let f = self#ppFilename ^ "~" in
+ let oc = open_out f in
+ output_string oc (buffer#get_text ~start:buffer#start_iter
+ ~stop:buffer#end_iter ());
+ close_out oc;
+ HLog.debug ("backup " ^ f ^ " saved")
+ end
+
+ method private goto_top =
+ let grafite_status,lexicon_status =
+ let rec last x = function
+ | [] -> x
+ | hd::tl -> last hd tl
+ in
+ last (self#grafite_status,self#lexicon_status) history
+ in
+ (* FIXME: this is not correct since there is no undo for
+ * library_objects.set_default... *)
+ GrafiteSync.time_travel ~present:self#grafite_status ~past:grafite_status;
+ LexiconSync.time_travel ~present:self#lexicon_status ~past:lexicon_status
+
+ method private reset_buffer =
+ statements <- [];
+ history <- [ initial_statuses ];
+ userGoal <- None;
+ self#notify;
+ buffer#remove_tag locked_tag ~start:buffer#start_iter ~stop:buffer#end_iter;
+ buffer#move_mark (`MARK locked_mark) ~where:buffer#start_iter
+
+ method reset () =
+ self#reset_buffer;
+ source_buffer#begin_not_undoable_action ();
+ buffer#delete ~start:buffer#start_iter ~stop:buffer#end_iter;
+ source_buffer#end_not_undoable_action ();
+ buffer#set_modified false;
+
+ method template () =
+ let template = HExtlib.input_file BuildTimeConf.script_template in
+ buffer#insert ~iter:(buffer#get_iter `START) template;
+ let development = MatitamakeLib.development_for_dir (Unix.getcwd ()) in
+ guistuff.filenamedata <- (None,development);
+ let include_ =
+ match development with
+ None -> []
+ | Some devel -> [MatitamakeLib.root_for_development devel ]
+ in
+ let include_ =
+ include_ @ (Helm_registry.get_list Helm_registry.string "matita.includes")
+ in
+ include_paths <- include_ ;
+ buffer#set_modified false;
+ set_star (Filename.basename self#ppFilename) false
+
+ method goto (pos: [`Top | `Bottom | `Cursor]) () =
+ let old_locked_mark =
+ `MARK
+ (buffer#create_mark ~name:"old_locked_mark"
+ ~left_gravity:true (buffer#get_iter_at_mark (`MARK locked_mark))) in
+ let getpos _ = buffer#get_iter_at_mark (`MARK locked_mark) in
+ let getoldpos _ = buffer#get_iter_at_mark old_locked_mark in
+ let dispose_old_locked_mark () = buffer#delete_mark old_locked_mark in
+ match pos with
+ | `Top ->
+ dispose_old_locked_mark ();
+ self#goto_top;
+ self#reset_buffer;
+ self#notify
+ | `Bottom ->
+ (try
+ let rec dowhile () =
+ self#_advance ();
+ let newpos = getpos () in
+ if (getoldpos ())#compare newpos < 0 then
+ begin
+ buffer#move_mark old_locked_mark newpos;
+ dowhile ()
+ end
+ in
+ dowhile ();
+ dispose_old_locked_mark ();
+ self#notify
+ with
+ | Margin -> dispose_old_locked_mark (); self#notify
+ | exc -> dispose_old_locked_mark (); self#notify; raise exc)
+ | `Cursor ->
+ let locked_iter () = buffer#get_iter_at_mark (`NAME "locked") in
+ let cursor_iter () = buffer#get_iter_at_mark `INSERT in
+ let remember =
+ `MARK
+ (buffer#create_mark ~name:"initial_insert"
+ ~left_gravity:true (cursor_iter ())) in
+ let dispose_remember () = buffer#delete_mark remember in
+ let remember_iter () =
+ buffer#get_iter_at_mark (`NAME "initial_insert") in
+ let cmp () = (locked_iter ())#offset - (remember_iter ())#offset in
+ let icmp = cmp () in
+ let forward_until_cursor () = (* go forward until locked > cursor *)
+ let rec aux () =
+ self#_advance ();
+ if cmp () < 0 && (getoldpos ())#compare (getpos ()) < 0
+ then
+ begin
+ buffer#move_mark old_locked_mark (getpos ());
+ aux ()
+ end
+ in
+ aux ()
+ in
+ let rec back_until_cursor len = (* go backward until locked < cursor *)
+ function
+ statements, ((grafite_status,lexicon_status)::_ as history)
+ when len <= 0 ->
+ self#_retract (icmp - len) lexicon_status grafite_status statements
+ history
+ | statement::tl1, _::tl2 ->
+ back_until_cursor (len - String.length statement) (tl1,tl2)
+ | _,_ -> assert false
+ in
+ (try
+ begin
+ if icmp < 0 then (* locked < cursor *)
+ (forward_until_cursor (); self#notify)
+ else if icmp > 0 then (* locked > cursor *)
+ (back_until_cursor icmp (statements,history); self#notify)
+ else (* cursor = locked *)
+ ()
+ end ;
+ dispose_remember ();
+ dispose_old_locked_mark ();
+ with
+ | Margin -> dispose_remember (); dispose_old_locked_mark (); self#notify
+ | exc -> dispose_remember (); dispose_old_locked_mark ();
+ self#notify; raise exc)
+
+ method onGoingProof () =
+ match self#grafite_status.proof_status with
+ | No_proof | Proof _ -> false
+ | Incomplete_proof _ -> true
+ | Intermediate _ -> assert false
+
+(* method proofStatus = MatitaTypes.get_proof_status self#status *)
+ method proofMetasenv = GrafiteTypes.get_proof_metasenv self#grafite_status
+
+ method proofContext =
+ match userGoal with
+ None -> []
+ | Some n -> GrafiteTypes.get_proof_context self#grafite_status n
+
+ method proofConclusion =
+ match userGoal with
+ None -> assert false
+ | Some n ->
+ GrafiteTypes.get_proof_conclusion self#grafite_status n
+
+ method stack = GrafiteTypes.get_stack self#grafite_status
+ method setGoal n = userGoal <- n
+ method goal = userGoal
+
+ method eos =
+ let s = self#getFuture in
+ let rec is_there_only_comments lexicon_status s =
+ if Pcre.pmatch ~rex:only_dust_RE s then raise Margin;
+ let lexicon_status,st =
+ GrafiteParser.parse_statement (Ulexing.from_utf8_string s)
+ ~include_paths lexicon_status
+ in
+ match st with
+ | GrafiteParser.LSome (GrafiteAst.Comment (loc,_)) ->
+ let parsed_text_length = snd (HExtlib.loc_of_floc loc) in
+ let remain_len = String.length s - parsed_text_length in
+ let next = String.sub s parsed_text_length remain_len in
+ is_there_only_comments lexicon_status next
+ | GrafiteParser.LNone _
+ | GrafiteParser.LSome (GrafiteAst.Executable _) -> false
+ in
+ try
+ is_there_only_comments self#lexicon_status s
+ with
+ | CicNotationParser.Parse_error _ -> false
+ | Margin | End_of_file -> true
+
+ (* debug *)
+ method dump () =
+ HLog.debug "script status:";
+ HLog.debug ("history size: " ^ string_of_int (List.length history));
+ HLog.debug (sprintf "%d statements:" (List.length statements));
+ List.iter HLog.debug statements;
+ HLog.debug ("Current file name: " ^
+ (match guistuff.filenamedata with
+ |None,_ -> "[ no name ]"
+ | Some f,_ -> f));
+
+end
+
+let _script = ref None
+
+let script ~source_view ~mathviewer ~urichooser ~develcreator ~ask_confirmation ~set_star ()
+=
+ let s = new script
+ ~source_view ~mathviewer ~ask_confirmation ~urichooser ~develcreator ~set_star ()
+ in
+ _script := Some s;
+ s
+
+let current () = match !_script with None -> assert false | Some s -> s
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+exception NoUnfinishedProof
+exception ActionCancelled
+
+class type script =
+object
+
+ method locked_mark : Gtk.text_mark
+ method locked_tag : GText.tag
+ method error_tag : GText.tag
+
+ (** @return current status *)
+ method lexicon_status: LexiconEngine.status
+ method grafite_status: GrafiteTypes.status
+
+ (** {2 Observers} *)
+
+ method addObserver :
+ (LexiconEngine.status -> GrafiteTypes.status -> unit) -> unit
+
+ (** {2 History} *)
+
+ method advance : ?statement:string -> unit -> unit
+ method retract : unit -> unit
+ method goto: [`Top | `Bottom | `Cursor] -> unit -> unit
+ method reset: unit -> unit
+ method template: unit -> unit
+
+ (** {2 Load/save} *)
+
+ method assignFileName : string -> unit (* to the current active file *)
+ method loadFromFile : string -> unit
+ method saveToFile : unit -> unit
+ method filename : string
+
+ (** {2 Current proof} (if any) *)
+
+ (** @return true if there is an ongoing proof, false otherise *)
+ method onGoingProof: unit -> bool
+
+(* method proofStatus: ProofEngineTypes.status |+* @raise Statement_error +| *)
+ method proofMetasenv: Cic.metasenv (** @raise Statement_error *)
+ method proofContext: Cic.context (** @raise Statement_error *)
+ method proofConclusion: Cic.term (** @raise Statement_error *)
+ method stack: Continuationals.Stack.t (** @raise Statement_error *)
+
+ method setGoal: int option -> unit
+ method goal: int option
+
+ (** end of script, true if the whole script has been executed *)
+ method eos: bool
+
+ (** misc *)
+ method clean_dirty_lock: unit
+
+ (* debug *)
+ method dump : unit -> unit
+
+end
+
+ (** @param set_star callback used to set the modified symbol (usually a star
+ * "*") on the side of a script name *)
+val script:
+ source_view:GSourceView.source_view ->
+ mathviewer: MatitaTypes.mathViewer->
+ urichooser: (UriManager.uri list -> UriManager.uri list) ->
+ develcreator: (containing:string option -> unit) ->
+ ask_confirmation:
+ (title:string -> message:string -> [`YES | `NO | `CANCEL]) ->
+ set_star: (string -> bool -> unit) ->
+ unit ->
+ script
+
+(* each time script above is called an internal ref is set, instance will return
+ * the value of this ref *)
+(* TODO Zack: orrible solution until we found a better one for having a single
+ * access point for the script *)
+val current: unit -> script
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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 ()
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+open GrafiteTypes
+
+exception AttemptToInsertAnAlias
+
+let pp_ast_statement =
+ GrafiteAstPp.pp_statement ~term_pp:CicNotationPp.pp_term
+ ~lazy_term_pp:CicNotationPp.pp_term ~obj_pp:CicNotationPp.pp_obj
+
+(** {2 Initialization} *)
+
+let grafite_status = (ref None : GrafiteTypes.status option ref)
+let lexicon_status = (ref None : LexiconEngine.status option ref)
+
+let run_script is eval_function =
+ let lexicon_status',grafite_status' =
+ match !lexicon_status,!grafite_status with
+ | Some ss, Some s -> ss,s
+ | _,_ -> assert false
+ in
+ let slash_n_RE = Pcre.regexp "\\n" in
+ let cb =
+ if Helm_registry.get_bool "matita.quiet" then
+ (fun _ _ -> ())
+ else
+ (fun grafite_status stm ->
+ (* dump_status grafite_status; *)
+ let stm = pp_ast_statement stm in
+ let stm = Pcre.replace ~rex:slash_n_RE stm in
+ let stm =
+ if String.length stm > 50 then
+ String.sub stm 0 50 ^ " ..."
+ else
+ stm
+ in
+ HLog.debug ("Executing: ``" ^ stm ^ "''"))
+ in
+ try
+ let grafite_status'', lexicon_status'' =
+ match eval_function lexicon_status' grafite_status' is cb with
+ [] -> assert false
+ | (s,None)::_ -> s
+ | (s,Some _)::_ -> raise AttemptToInsertAnAlias
+ in
+ lexicon_status := Some lexicon_status'';
+ grafite_status := Some grafite_status''
+ with
+ | GrafiteEngine.Drop
+ | End_of_file
+ | CicNotationParser.Parse_error _ as exn -> raise exn
+ | exn ->
+ HLog.error (snd (MatitaExcPp.to_string exn));
+ raise exn
+
+let fname () =
+ match Helm_registry.get_list Helm_registry.string "matita.args" with
+ | [x] -> x
+ | _ -> MatitaInit.die_usage ()
+
+let pp_ocaml_mode () =
+ HLog.message "";
+ HLog.message " ** Entering Ocaml mode ** ";
+ HLog.message "";
+ HLog.message "Type 'go ();;' to enter an interactive matitac";
+ HLog.message ""
+
+let clean_exit n =
+ let opt_exit =
+ function
+ None -> ()
+ | Some n -> exit n
+ in
+ match !grafite_status with
+ None -> opt_exit n
+ | Some grafite_status ->
+ try
+ let baseuri = GrafiteTypes.get_string_option grafite_status "baseuri" in
+ let basedir = Helm_registry.get "matita.basedir" in
+ LibraryClean.clean_baseuris ~basedir ~verbose:false [baseuri];
+ opt_exit n
+ with GrafiteTypes.Option_error("baseuri", "not found") ->
+ (* no baseuri ==> nothing to clean yet *)
+ opt_exit n
+
+let rec interactive_loop () =
+ let str = Ulexing.from_utf8_channel stdin in
+ try
+ run_script str
+ (MatitaEngine.eval_from_stream ~first_statement_only:false ~prompt:true
+ ~include_paths:(Helm_registry.get_list Helm_registry.string
+ "matita.includes"))
+ with
+ | GrafiteEngine.Drop -> pp_ocaml_mode ()
+ | GrafiteEngine.Macro (floc,_) ->
+ let x, y = HExtlib.loc_of_floc floc in
+ HLog.error
+ (sprintf "A macro has been found in a script at %d-%d" x y);
+ interactive_loop ()
+ | Sys.Break -> HLog.error "user break!"; interactive_loop ()
+ | GrafiteTypes.Command_error _ -> interactive_loop ()
+ | End_of_file ->
+ print_newline ();
+ clean_exit (Some 0)
+ | HExtlib.Localized (floc,CicNotationParser.Parse_error err) ->
+ let x, y = HExtlib.loc_of_floc floc in
+ HLog.error (sprintf "Parse error at %d-%d: %s" x y err);
+ interactive_loop ()
+ | exn -> HLog.error (Printexc.to_string exn); interactive_loop ()
+
+let go () =
+ Helm_registry.load_from BuildTimeConf.matita_conf;
+ Http_getter.init ();
+ MetadataTypes.ownerize_tables (Helm_registry.get "matita.owner");
+ LibraryDb.create_owner_environment ();
+ CicEnvironment.set_trust (* environment trust *)
+ (let trust =
+ Helm_registry.get_opt_default Helm_registry.get_bool
+ ~default:true "matita.environment_trust" in
+ fun _ -> trust);
+ let include_paths =
+ Helm_registry.get_list Helm_registry.string "matita.includes" in
+ grafite_status := Some (GrafiteSync.init ());
+ lexicon_status :=
+ Some (CicNotation2.load_notation ~include_paths
+ BuildTimeConf.core_notation_script);
+ Sys.catch_break true;
+ interactive_loop ()
+
+let main ~mode =
+ MatitaInit.initialize_all ();
+ (* must be called after init since args are set by cmdline parsing *)
+ let fname = fname () in
+ let include_paths =
+ Helm_registry.get_list Helm_registry.string "matita.includes" in
+ grafite_status := Some (GrafiteSync.init ());
+ lexicon_status :=
+ Some (CicNotation2.load_notation ~include_paths
+ BuildTimeConf.core_notation_script);
+ Sys.catch_break true;
+ let origcb = HLog.get_log_callback () in
+ let newcb tag s =
+ match tag with
+ | `Debug | `Message -> ()
+ | `Warning | `Error -> origcb tag s
+ in
+ if Helm_registry.get_bool "matita.quiet" then
+ HLog.set_log_callback newcb;
+ let matita_debug = Helm_registry.get_bool "matita.debug" in
+ try
+ let time = Unix.time () in
+ if Helm_registry.get_bool "matita.quiet" then
+ origcb `Message ("compiling " ^ Filename.basename fname ^ "...")
+ else
+ HLog.message (sprintf "execution of %s started:" fname);
+ let is =
+ Ulexing.from_utf8_channel
+ (match fname with
+ | "stdin" -> stdin
+ | fname -> open_in fname) in
+ let include_paths =
+ Helm_registry.get_list Helm_registry.string "matita.includes" in
+ (try
+ run_script is
+ (MatitaEngine.eval_from_stream ~first_statement_only:false ~include_paths
+ ~clean_baseuri:(not (Helm_registry.get_bool "matita.preserve")))
+ with End_of_file -> ());
+ let elapsed = Unix.time () -. time in
+ let tm = Unix.gmtime elapsed in
+ let sec = string_of_int tm.Unix.tm_sec ^ "''" in
+ let min =
+ if tm.Unix.tm_min > 0 then (string_of_int tm.Unix.tm_min ^ "' ") else ""
+ in
+ let hou =
+ if tm.Unix.tm_hour > 0 then (string_of_int tm.Unix.tm_hour ^ "h ") else ""
+ in
+ let proof_status,moo_content_rev,metadata,lexicon_content_rev =
+ match !lexicon_status,!grafite_status with
+ | Some ss, Some s ->
+ s.proof_status, s.moo_content_rev, ss.LexiconEngine.metadata,
+ ss.LexiconEngine.lexicon_content_rev
+ | _,_ -> assert false
+ in
+ if proof_status <> GrafiteTypes.No_proof then
+ begin
+ HLog.error
+ "there are still incomplete proofs at the end of the script";
+ clean_exit (Some 2)
+ end
+ else
+ begin
+ let basedir = Helm_registry.get "matita.basedir" in
+ let baseuri =
+ DependenciesParser.baseuri_of_script ~include_paths fname in
+ let moo_fname = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in
+ let lexicon_fname= LibraryMisc.lexicon_file_of_baseuri ~basedir ~baseuri in
+ let metadata_fname =
+ LibraryMisc.metadata_file_of_baseuri ~basedir ~baseuri
+ in
+ GrafiteMarshal.save_moo moo_fname moo_content_rev;
+ LibraryNoDb.save_metadata metadata_fname metadata;
+ LexiconMarshal.save_lexicon lexicon_fname lexicon_content_rev;
+ HLog.message
+ (sprintf "execution of %s completed in %s." fname (hou^min^sec));
+ exit 0
+ end
+ with
+ | Sys.Break ->
+ HLog.error "user break!";
+ if mode = `COMPILER then
+ clean_exit (Some ~-1)
+ else
+ pp_ocaml_mode ()
+ | GrafiteEngine.Drop ->
+ if mode = `COMPILER then
+ clean_exit (Some 1)
+ else
+ pp_ocaml_mode ()
+ | GrafiteEngine.Macro (floc,_) ->
+ let x, y = HExtlib.loc_of_floc floc in
+ HLog.error
+ (sprintf "A macro has been found in a script at %d-%d" x y);
+ if mode = `COMPILER then
+ clean_exit (Some 1)
+ else
+ pp_ocaml_mode ()
+ | HExtlib.Localized (floc,CicNotationParser.Parse_error err) ->
+ let (x, y) = HExtlib.loc_of_floc floc in
+ HLog.error (sprintf "Parse error at %d-%d: %s" x y err);
+ if mode = `COMPILER then
+ clean_exit (Some 1)
+ else
+ pp_ocaml_mode ()
+ | exn ->
+ if matita_debug then raise exn;
+ if mode = `COMPILER then
+ clean_exit (Some 3)
+ else
+ pp_ocaml_mode ()
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+module GA = GrafiteAst
+module U = UriManager
+
+let main () =
+ (* all are maps from "file" to "something" *)
+ let include_deps = Hashtbl.create (Array.length Sys.argv) in
+ let baseuri_of = Hashtbl.create (Array.length Sys.argv) in
+ let uri_deps = Hashtbl.create (Array.length Sys.argv) in
+ let buri alias = U.buri_of_uri (U.uri_of_string alias) in
+ let resolve alias current_buri =
+ let buri = buri alias in
+ if buri <> current_buri then Some buri else None in
+ MatitaInit.fill_registry ();
+ MatitaInit.parse_cmdline ();
+ MatitaInit.load_configuration_file ();
+ let include_paths =
+ Helm_registry.get_list Helm_registry.string "matita.includes" in
+ let basedir = Helm_registry.get "matita.basedir" in
+ List.iter
+ (fun ma_file ->
+ let ic = open_in ma_file in
+ let istream = Ulexing.from_utf8_channel ic in
+ let dependencies = DependenciesParser.parse_dependencies istream in
+ close_in ic;
+ List.iter
+ (function
+ | DependenciesParser.UriDep uri ->
+ let uri = UriManager.string_of_uri uri in
+ if not (Http_getter_storage.is_legacy uri) then
+ Hashtbl.add uri_deps ma_file uri
+ | DependenciesParser.BaseuriDep uri ->
+ let uri = Http_getter_misc.strip_trailing_slash uri in
+ Hashtbl.add baseuri_of ma_file uri
+ | DependenciesParser.IncludeDep path ->
+ try
+ let baseuri =
+ DependenciesParser.baseuri_of_script ~include_paths path in
+ if not (Http_getter_storage.is_legacy baseuri) then
+ let moo_file =
+ LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in
+ Hashtbl.add include_deps ma_file moo_file
+ with Sys_error _ ->
+ HLog.warn
+ ("Unable to find " ^ path ^ " that is included in " ^ ma_file)
+ ) dependencies
+ ) (Helm_registry.get_list Helm_registry.string "matita.args");
+ Hashtbl.iter
+ (fun file alias ->
+ let dep = resolve alias (Hashtbl.find baseuri_of file) in
+ match dep with
+ | None -> ()
+ | Some u ->
+ Hashtbl.add include_deps file
+ (LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri:u))
+ uri_deps;
+ List.iter
+ (fun ma_file ->
+ let deps = Hashtbl.find_all include_deps ma_file in
+ let deps = List.fast_sort Pervasives.compare deps in
+ let deps = HExtlib.list_uniq deps in
+ let deps = ma_file :: deps in
+ let baseuri = Hashtbl.find baseuri_of ma_file in
+ let moo = LibraryMisc.obj_file_of_baseuri ~basedir ~baseuri in
+ Printf.printf "%s: %s\n" moo (String.concat " " deps);
+ Printf.printf "%s: %s\n" (Pcre.replace ~pat:"ma$" ~templ:"mo" ma_file) moo)
+ (Helm_registry.get_list Helm_registry.string "matita.args")
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+module MK = MatitamakeLib ;;
+
+let main () =
+ MatitaInit.fill_registry ();
+ MatitaInit.load_configuration_file ();
+ MK.initialize ();
+ let usage = ref (fun () -> ()) in
+ let dev_of_name name =
+ match MK.development_for_name name with
+ | None ->
+ prerr_endline ("Unable to find a development called " ^ name);
+ exit 1
+ | Some d -> d
+ in
+ let dev_for_dir dir =
+ match MK.development_for_dir dir with
+ | None ->
+ prerr_endline ("Unable to find a development holding directory: "^ dir);
+ exit 1
+ | Some d -> d
+ in
+ let init_dev_doc = "
+\tParameters: name (the name of the development, required)
+\tDescription: tells matitamake that a new development radicated
+\t\tin the current working directory should be handled."
+ in
+ let init_dev args =
+ if List.length args <> 1 then !usage ();
+ match MK.initialize_development (List.hd args) (Unix.getcwd ()) with
+ | None -> exit 2
+ | Some _ -> exit 0
+ in
+ let list_dev_doc = "
+\tParameters:
+\tDescription: lists the known developments and their roots."
+ in
+ let list_dev args =
+ if List.length args <> 0 then !usage ();
+ match MK.list_known_developments () with
+ | [] -> print_string "No developments found.\n"; exit 0
+ | l ->
+ List.iter
+ (fun (name, root) ->
+ print_string (Printf.sprintf "%-10s\trooted in %s\n" name root))
+ l;
+ exit 0
+ in
+ let destroy_dev_doc = "
+\tParameters: name (the name of the development to destroy, required)
+\tDescription: deletes a development (only from matitamake metadat, no
+\t\t.ma files will be deleted)."
+ in
+ let destroy_dev args =
+ if List.length args <> 1 then !usage ();
+ let name = (List.hd args) in
+ let dev = dev_of_name name in
+ MK.destroy_development dev;
+ exit 0
+ in
+ let clean_dev_doc = "
+\tParameters: name (the name of the development to destroy, optional)
+\t\tIf omitted the development that holds the current working
+\t\tdirectory is used (if any).
+\tDescription: clean the develpoment."
+ in
+ let clean_dev args =
+ let dev =
+ match args with
+ | [] -> dev_for_dir (Unix.getcwd ())
+ | [name] -> dev_of_name name
+ | _ -> !usage (); exit 1
+ in
+ match MK.clean_development dev with
+ | true -> exit 0
+ | false -> exit 1
+ in
+ let build_dev_doc = "
+\tParameters: name (the name of the development to build, required)
+\tDescription: completely builds the develpoment."
+ in
+ let build_dev args =
+ if List.length args <> 1 then !usage ();
+ let name = (List.hd args) in
+ let dev = dev_of_name name in
+ match MK.build_development dev with
+ | true -> exit 0
+ | false -> exit 1
+ in
+ let nodb_doc = "
+\tParameters:
+\tDescription: avoid using external database connection."
+ in
+ let nodb _ = Helm_registry.set_bool "db.nodb" true in
+ let target args =
+ if List.length args < 1 then !usage ();
+ let dev = dev_for_dir (Unix.getcwd ()) in
+ List.iter
+ (fun t ->
+ ignore(MK.build_development ~target:t dev))
+ args
+ in
+ let params = [
+ "-init", init_dev, init_dev_doc;
+ "-clean", clean_dev, clean_dev_doc;
+ "-list", list_dev, list_dev_doc;
+ "-destroy", destroy_dev, destroy_dev_doc;
+ "-build", build_dev, build_dev_doc;
+ "-nodb", nodb, nodb_doc;
+ "-h", (fun _ -> !usage()), "print this help screen";
+ "-help", (fun _ -> !usage()), "print this help screen";
+ ]
+ in
+ usage := (fun () ->
+ let p = prerr_endline in
+ p "\nusage:";
+ p "\tmatitamake(.opt) [command [options]]\n";
+ p "\tmatitamake(.opt) [target]\n";
+ p "commands:";
+ List.iter (fun (n,_,d) -> p (Printf.sprintf " %-10s%s" n d)) params;
+ p "\nIf target is omitted a 'all' will be used as the default.";
+ p "With -build you can build a development wherever it is.";
+ p "If you specify a target it implicitly refers to the development that";
+ p "holds the current working directory (if any).\n";
+ exit 1);
+ let rec parse args =
+ match args with
+ | [] -> target ["all"]
+ | s::tl ->
+ try
+ let _,f,_ = List.find (fun (n,_,_) -> n = s) params in
+ f tl;
+ parse tl
+ with Not_found -> if s.[0] = '-' then !usage () else target args
+ in
+ parse (List.tl (Array.to_list Sys.argv))
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+(* $Id$ *)
+
+open Printf
+
+let logger = fun mark ->
+ match mark with
+ | `Error -> HLog.error
+ | `Warning -> HLog.warn
+ | `Debug -> HLog.debug
+ | `Message -> HLog.message
+;;
+
+type development =
+ { root: string ; name: string }
+
+let developments = ref []
+
+let pool () = Helm_registry.get "matita.basedir" ^ "/matitamake/" ;;
+let rootfile = "/root" ;;
+
+let ls_dir dir =
+ try
+ let d = Unix.opendir dir in
+ let content = ref [] in
+ try
+ while true do
+ let name = Unix.readdir d in
+ if name <> "." && name <> ".." then
+ content := name :: !content
+ done;
+ Some []
+ with End_of_file -> Unix.closedir d; Some !content
+ with Unix.Unix_error _ -> None
+
+let initialize () =
+ (* create a base env if none *)
+ HExtlib.mkdir (pool ());
+ (* load developments *)
+ match ls_dir (pool ()) with
+ | None -> logger `Error ("Unable to list directory " ^ pool ())
+ | Some l ->
+ List.iter
+ (fun name ->
+ let root =
+ try
+ Some (HExtlib.input_file (pool () ^ name ^ rootfile))
+ with Unix.Unix_error _ ->
+ logger `Warning ("Malformed development " ^ name);
+ None
+ in
+ match root with
+ | None -> ()
+ | Some root ->
+ developments := {root = root ; name = name} :: !developments)
+ l
+
+(* finds the makefile path for development devel *)
+let makefile_for_development devel =
+ let develdir = pool () ^ devel.name in
+ develdir ^ "/makefile"
+;;
+
+(* given a dir finds a development that is radicated in it or below *)
+let development_for_dir dir =
+ let is_prefix_of d1 d2 =
+ let len1 = String.length d1 in
+ let len2 = String.length d2 in
+ if len2 < len1 then
+ false
+ else
+ let pref = String.sub d2 0 len1 in
+ pref = d1
+ in
+ (* it must be unique *)
+ try
+ Some (List.find (fun d -> is_prefix_of d.root dir) !developments)
+ with Not_found -> None
+;;
+
+let development_for_name name =
+ try
+ Some (List.find (fun d -> d.name = name) !developments)
+ with Not_found -> None
+
+(* dumps the deveopment to disk *)
+let dump_development devel =
+ let devel_dir = pool () ^ devel.name in
+ HExtlib.mkdir devel_dir;
+ HExtlib.output_file ~filename:(devel_dir ^ rootfile) ~text:devel.root
+;;
+
+let list_known_developments () =
+ List.map (fun r -> r.name,r.root) !developments
+
+let am_i_opt () =
+ if Pcre.pmatch ~pat:"\\.opt$" Sys.argv.(0) then ".opt" else ""
+
+let rebuild_makefile development =
+ let makefilepath = makefile_for_development development in
+ let template =
+ HExtlib.input_file BuildTimeConf.matitamake_makefile_template
+ in
+ let cc = BuildTimeConf.runtime_base_dir ^ "/matitac" ^ am_i_opt () in
+ let rm = BuildTimeConf.runtime_base_dir ^ "/matitaclean" ^ am_i_opt () in
+ let mm = BuildTimeConf.runtime_base_dir ^ "/matitadep" ^ am_i_opt () in
+ let df = pool () ^ development.name ^ "/depend" in
+ let template = Pcre.replace ~pat:"@ROOT@" ~templ:development.root template in
+ let template = Pcre.replace ~pat:"@CC@" ~templ:cc template in
+ let template = Pcre.replace ~pat:"@DEP@" ~templ:mm template in
+ let template = Pcre.replace ~pat:"@DEPFILE@" ~templ:df template in
+ let template = Pcre.replace ~pat:"@CLEAN@" ~templ:rm template in
+ HExtlib.output_file ~filename:makefilepath ~text:template
+
+(* creates a new development if possible *)
+let initialize_development name dir =
+ let name = Pcre.replace ~pat:" " ~templ:"_" name in
+ let dev = {name = name ; root = dir} in
+ match development_for_dir dir with
+ | Some d ->
+ logger `Error
+ ("Directory " ^ dir ^ " is already handled by development " ^ d.name);
+ logger `Error
+ ("Development " ^ d.name ^ " is rooted in " ^ d.root);
+ logger `Error
+ (dir ^ " is a subdir of " ^ d.root);
+ None
+ | None ->
+ dump_development dev;
+ rebuild_makefile dev;
+ developments := dev :: !developments;
+ Some dev
+
+let make chdir args =
+ let old = Unix.getcwd () in
+ try
+ Unix.chdir chdir;
+ let rc =
+ Unix.system
+ (String.concat " " ("make"::(List.map Filename.quote args)))
+ in
+ Unix.chdir old;
+ match rc with
+ | Unix.WEXITED 0 -> true
+ | Unix.WEXITED i -> logger `Error ("make returned " ^ string_of_int i);false
+ | _ -> logger `Error "make STOPPED or SIGNALED!";false
+ with Unix.Unix_error (_,cmd,err) ->
+ logger `Warning ("Unix Error: " ^ cmd ^ ": " ^ err);
+ false
+
+let call_make development target make =
+ rebuild_makefile development;
+ let makefile = makefile_for_development development in
+ let nodb =
+ Helm_registry.get_opt_default Helm_registry.bool ~default:false "db.nodb"
+ in
+ let flags = [] in
+ let flags = flags @ if nodb then ["NODB=true"] else [] in
+ let flags =
+ try
+ flags @ [ sprintf "MATITA_FLAGS=\"%s\"" (Sys.getenv "MATITA_FLAGS") ]
+ with Not_found -> flags in
+ make development.root
+ (["--no-print-directory"; "-s"; "-k"; "-f"; makefile; target]
+ @ flags)
+
+let build_development ?(target="all") development =
+ call_make development target make
+
+(* not really good vt100 *)
+let vt100 s =
+ let rex = Pcre.regexp "\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
+
--- /dev/null
+(* Copyright (C) 2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 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
+
--- /dev/null
+(* Copyright (C) 2004-2005, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 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
--- /dev/null
+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
+
--- /dev/null
+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;
--- /dev/null
+MAILTO=helm@cs.unibo.it
+HOME=/home/tassi/
+#SVNOPTIONS='-r {2006-01-09}'
+10 5 * * * sh /home/tassi/helm/matita/scripts/crontab.sh
--- /dev/null
+#!/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
+
--- /dev/null
+#!/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
--- /dev/null
+ {
+ 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;
+ }
--- /dev/null
+#!/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
--- /dev/null
+<?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 : ";
+ 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> ";
+ }
+ $q1 = str_replace(urlencode("***"), " ", $q);
+ echo "<a href=\"showquery.php?query=$q1;\">" .
+ minus1_to_all("-1") . "</a> ";
+ }
+ 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>
--- /dev/null
+<?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>";
+}
+
+?>
--- /dev/null
+<?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;
+?>
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+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;
+}
+
+
--- /dev/null
+<?php
+ require($argv[1]);
+ $rc = query($argv[2]);
+ $a = array_values($rc[0]);
+ print($a[0]);
+?>
--- /dev/null
+<?php
+ require($argv[1]);
+ print(time_2_cents($argv[2]));
+?>
--- /dev/null
+SRC=$(shell find @ROOT@ -name "*.ma" -a -type f)
+TODO=$(SRC:%.ma=%.mo)
+
+MATITA_FLAGS=
+MATITA_FLAGS+=-noprofile
+NODB=false
+ifeq ($(NODB),true)
+ MATITA_FLAGS += -nodb
+endif
+
+MATITAC=@CC@
+MATITACLEAN=@CLEAN@
+MATITADEP=@DEP@
+
+all: $(TODO)
+
+clean:
+ $(MATITACLEAN) $(MATITA_FLAGS) $(SRC)
+ rm -f $(TODO)
+
+%.moo:
+ ($(MATITAC) $(MATITA_FLAGS) -q -I @ROOT@ $< | (grep -v "^make" || true))
+
+@DEPFILE@ : $(SRC)
+ $(MATITADEP) $(MATITA_FLAGS) -I '@ROOT@' $^ 1> @DEPFILE@
+
+# this is the depend for full targets like:
+# dir/dir/name.moo: dir/dir/name.ma dir/dep.moo
+-include @DEPFILE@
--- /dev/null
+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
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||M|| *)
+(* ||A|| A project by Andrea Asperti *)
+(* ||T|| *)
+(* ||I|| Developers: *)
+(* ||T|| The HELM team. *)
+(* ||A|| http://helm.cs.unibo.it *)
+(* \ / *)
+(* \ / This file is distributed under the terms of the *)
+(* v GNU General Public License Version 2 *)
+(* *)
+(**************************************************************************)
+
+set "baseuri" "cic:/matita/SK/".
+
+include "legacy/coq.ma".
+alias symbol "eq" = "Coq's leibnitz's equality".
+
+theorem SKK:
+ \forall A:Set.
+ \forall app: A \to A \to A.
+ \forall K:A.
+ \forall S:A.
+ \forall H1: (\forall x,y:A.(app (app K x) y) = x).
+ \forall H2: (\forall x,y,z:A.
+ (app (app (app S x) y) z) = (app (app x z) (app y z))).
+ \forall x:A.
+ (app (app (app S K) K) x) = x.
+intros.auto paramodulation.
+qed.
+
+theorem bool1:
+ \forall A:Set.
+ \forall one:A.
+ \forall zero:A.
+ \forall add: A \to A \to A.
+ \forall mult: A \to A \to A.
+ \forall inv: A \to A.
+ \forall c1:(\forall x,y:A.(add x y) = (add y x)).
+ \forall c2:(\forall x,y:A.(mult x y) = (mult y x)).
+ \forall d1: (\forall x,y,z:A.
+ (add x (mult y z)) = (mult (add x y) (add x z))).
+ \forall d2: (\forall x,y,z:A.
+ (mult x (add y z)) = (add (mult x y) (mult x z))).
+ \forall i1: (\forall x:A. (add x zero) = x).
+ \forall i2: (\forall x:A. (mult x one) = x).
+ \forall inv1: (\forall x:A. (add x (inv x)) = one).
+ \forall inv2: (\forall x:A. (mult x (inv x)) = zero).
+ (inv zero) = one.
+intros.auto paramodulation.
+qed.
+
+theorem bool2:
+ \forall A:Set.
+ \forall one:A.
+ \forall zero:A.
+ \forall add: A \to A \to A.
+ \forall mult: A \to A \to A.
+ \forall inv: A \to A.
+ \forall c1:(\forall x,y:A.(add x y) = (add y x)).
+ \forall c2:(\forall x,y:A.(mult x y) = (mult y x)).
+ \forall d1: (\forall x,y,z:A.
+ (add x (mult y z)) = (mult (add x y) (add x z))).
+ \forall d2: (\forall x,y,z:A.
+ (mult x (add y z)) = (add (mult x y) (mult x z))).
+ \forall i1: (\forall x:A. (add x zero) = x).
+ \forall i2: (\forall x:A. (mult x one) = x).
+ \forall inv1: (\forall x:A. (add x (inv x)) = one).
+ \forall inv2: (\forall x:A. (mult x (inv x)) = zero).
+ \forall x:A. (mult x zero) = zero.
+intros.auto paramodulation.
+qed.
+
+theorem bool3:
+ \forall A:Set.
+ \forall one:A.
+ \forall zero:A.
+ \forall add: A \to A \to A.
+ \forall mult: A \to A \to A.
+ \forall inv: A \to A.
+ \forall c1:(\forall x,y:A.(add x y) = (add y x)).
+ \forall c2:(\forall x,y:A.(mult x y) = (mult y x)).
+ \forall d1: (\forall x,y,z:A.
+ (add x (mult y z)) = (mult (add x y) (add x z))).
+ \forall d2: (\forall x,y,z:A.
+ (mult x (add y z)) = (add (mult x y) (mult x z))).
+ \forall i1: (\forall x:A. (add x zero) = x).
+ \forall i2: (\forall x:A. (mult x one) = x).
+ \forall inv1: (\forall x:A. (add x (inv x)) = one).
+ \forall inv2: (\forall x:A. (mult x (inv x)) = zero).
+ \forall x:A. (inv (inv x)) = x.
+intros.auto paramodulation.
+qed.
+
+theorem bool2:
+ \forall A:Set.
+ \forall one:A.
+ \forall zero:A.
+ \forall add: A \to A \to A.
+ \forall mult: A \to A \to A.
+ \forall inv: A \to A.
+ \forall c1:(\forall x,y:A.(add x y) = (add y x)).
+ \forall c2:(\forall x,y:A.(mult x y) = (mult y x)).
+ \forall d1: (\forall x,y,z:A.
+ (add x (mult y z)) = (mult (add x y) (add x z))).
+ \forall d2: (\forall x,y,z:A.
+ (mult x (add y z)) = (add (mult x y) (mult x z))).
+ \forall i1: (\forall x:A. (add x zero) = x).
+ \forall i2: (\forall x:A. (mult x one) = x).
+ \forall inv1: (\forall x:A. (add x (inv x)) = one).
+ \forall inv2: (\forall x:A. (mult x (inv x)) = zero).
+ \forall x,y:A.
+ (inv (mult x y)) = (add (inv x) (inv y)).
+intros.auto paramodulation.
+qed.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+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
--- /dev/null
+\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:/matita/legacy/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
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+\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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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/".
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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)).
+
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
+
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||M|| *)
+(* ||A|| A project by Andrea Asperti *)
+(* ||T|| *)
+(* ||I|| Developers: *)
+(* ||T|| The HELM team. *)
+(* ||A|| http://helm.cs.unibo.it *)
+(* \ / *)
+(* \ / This file is distributed under the terms of the *)
+(* v GNU General Public License Version 2 *)
+(* *)
+(**************************************************************************)
+
+set "baseuri" "cic:/matita/demodulation/".
+
+include "legacy/coq.ma".
+
+alias num = "natural number".
+alias symbol "times" = "Coq's natural times".
+alias symbol "plus" = "Coq's natural plus".
+alias symbol "eq" = "Coq's leibnitz's equality".
+alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)".
+alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)".
+
+
+theorem p0 : \forall m:nat. m+O = m.
+intro. demodulate.
+
+theorem p: \forall m.1*m = m.
+intros.demodulate.reflexivity.
+qed.
+
+theorem p2: \forall x,y:nat.(S x)*y = (y+x*y).
+intros.demodulate.reflexivity.
+qed.
+
+theorem p1: \forall x,y:nat.(S ((S x)*y+x))=(S x)+(y*x+y).
+intros.demodulate.reflexivity.
+qed.
+
+theorem p3: \forall x,y:nat. (x+y)*(x+y) = x*x + 2*(x*y) + (y*y).
+intros.demodulate.reflexivity.
+qed.
+
+theorem p4: \forall x:nat. (x+1)*(x-1)=x*x - 1.
+intro.
+apply (nat_case x)
+[simplify.reflexivity
+|intro.demodulate.reflexivity]
+qed.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||M|| *)
+(* ||A|| A project by Andrea Asperti *)
+(* ||T|| *)
+(* ||I|| Developers: *)
+(* ||T|| The HELM team. *)
+(* ||A|| http://helm.cs.unibo.it *)
+(* \ / *)
+(* \ / This file is distributed under the terms of the *)
+(* v GNU General Public License Version 2 *)
+(* *)
+(**************************************************************************)
+
+set "baseuri" "cic:/matita/demodulation_matita/".
+
+include "nat/minus.ma".
+
+theorem p2: \forall x,y:nat. x+x = (S(S O))*x.
+intros.demodulate.reflexivity.
+qed.
+
+theorem p4: \forall x:nat. (x+(S O))*(x-(S O))=x*x - (S O).
+intro.
+apply (nat_case x)
+[simplify.reflexivity
+|intro.demodulate.reflexivity]
+qed.
+
+theorem p5: \forall x,y:nat. (x+y)*(x+y) = x*x + (S(S O))*(x*y) + (y*y).
+intros.demodulate.reflexivity.
+qed.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+*)
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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
--- /dev/null
+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.
--- /dev/null
+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".
--- /dev/null
+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.
--- /dev/null
+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.
--- /dev/null
+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.
--- /dev/null
+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).
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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) ].
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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].
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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
+}.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||M|| *)
+(* ||A|| A project by Andrea Asperti *)
+(* ||T|| *)
+(* ||I|| Developers: *)
+(* ||T|| The HELM team. *)
+(* ||A|| http://helm.cs.unibo.it *)
+(* \ / *)
+(* \ / This file is distributed under the terms of the *)
+(* v GNU General Public License Version 2 *)
+(* *)
+(**************************************************************************)
+
+set "baseuri" "cic:/matita/tests/simpl/".
+include "legacy/coq.ma".
+
+alias symbol "eq" (instance 0) = "Coq's leibnitz's equality".
+alias id "plus" = "cic:/Coq/Init/Peano/plus.con".
+alias id "S" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)".
+alias id "O" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)".
+alias id "not" = "cic:/Coq/Init/Logic/not.con".
+alias id "nat" = "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)".
+alias id "plus_comm" = "cic:/Coq/Arith/Plus/plus_comm.con".
+
+theorem t: let f \def \lambda x,y. x y in f (\lambda x.S x) O = S O.
+ intros. simplify. change in \vdash (? ? (? ? %) ?) with O.
+ reflexivity. qed.
+
+theorem X: \forall x:nat. let myplus \def plus x in myplus (S O) = S x.
+ intros. simplify. change in \vdash (? ? (% ?) ?) with (plus x).
+
+rewrite > plus_comm. reflexivity. qed.
+
+theorem R: \forall x:nat. let uno \def x + O in S O + uno = 1 + x.
+ intros. simplify.
+ change in \vdash (? ? (? %) ?) with (x + O).
+ rewrite > plus_comm. reflexivity. qed.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
+
--- /dev/null
+(**************************************************************************)
+(* ___ *)
+(* ||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.
projects / helm.git / commitdiff
