From 0fde70bd19b8fdfa72b807b9713a02ad1bd91b5b Mon Sep 17 00:00:00 2001 From: Andrea Asperti Date: Thu, 7 Oct 2010 09:37:01 +0000 Subject: [PATCH] acic_procedural and tactics removed --- .../METAS/meta.helm-acic_procedural.src | 4 - .../METAS/meta.helm-cic_disambiguation.src | 4 - .../METAS/meta.helm-grafite_engine.src | 2 +- .../components/METAS/meta.helm-ng_tactics.src | 2 +- matita/components/METAS/meta.helm-tactics.src | 4 - .../METAS/meta.helm-tptp_grafite.src | 5 - matita/components/Makefile | 4 +- matita/components/acic_procedural/.depend | 38 - matita/components/acic_procedural/.depend.opt | 38 - matita/components/acic_procedural/Makefile | 20 - .../acic_procedural/acic2Procedural.ml | 149 -- .../acic_procedural/acic2Procedural.mli | 44 - .../components/acic_procedural/procedural1.ml | 51 - .../acic_procedural/procedural1.mli | 34 - .../components/acic_procedural/procedural2.ml | 586 ----- .../acic_procedural/procedural2.mli | 36 - .../acic_procedural/proceduralClassify.ml | 139 -- .../acic_procedural/proceduralClassify.mli | 36 - .../acic_procedural/proceduralConversion.ml | 292 --- .../acic_procedural/proceduralConversion.mli | 47 - .../acic_procedural/proceduralHelpers.ml | 387 --- .../acic_procedural/proceduralHelpers.mli | 103 - .../acic_procedural/proceduralMode.ml | 57 - .../acic_procedural/proceduralMode.mli | 29 - .../acic_procedural/proceduralOptimizer.ml | 301 --- .../acic_procedural/proceduralOptimizer.mli | 32 - .../acic_procedural/proceduralTeX.ml | 253 -- .../acic_procedural/proceduralTeX.mli | 35 - .../acic_procedural/proceduralTypes.ml | 385 --- .../acic_procedural/proceduralTypes.mli | 85 - .../grafite_engine/grafiteEngine.ml | 518 +--- .../grafite_engine/grafiteEngine.mli | 8 - .../components/grafite_engine/grafiteSync.ml | 64 - .../components/grafite_engine/grafiteSync.mli | 5 - .../components/grafite_engine/grafiteTypes.ml | 82 - .../grafite_engine/grafiteTypes.mli | 24 - .../grafite_parser/grafiteDisambiguate.ml | 8 +- .../grafite_parser/grafiteDisambiguate.mli | 3 +- matita/components/ng_disambiguation/.depend | 4 +- matita/components/ng_tactics/.depend | 44 +- matita/components/ng_tactics/.depend.opt | 44 +- matita/components/ng_tactics/Makefile | 1 + .../continuationals.ml | 2 +- .../continuationals.mli | 2 +- matita/components/tactics/.depend | 229 -- matita/components/tactics/.depend.opt | 229 -- matita/components/tactics/Makefile | 62 - matita/components/tactics/auto.ml | 2186 ----------------- matita/components/tactics/auto.mli | 73 - matita/components/tactics/autoCache.ml | 158 -- matita/components/tactics/autoCache.mli | 46 - matita/components/tactics/autoTypes.ml | 65 - matita/components/tactics/autoTypes.mli | 51 - matita/components/tactics/automationCache.ml | 119 - matita/components/tactics/automationCache.mli | 44 - .../components/tactics/closeCoercionGraph.ml | 546 ---- .../components/tactics/closeCoercionGraph.mli | 40 - matita/components/tactics/compose.ml | 195 -- matita/components/tactics/compose.mli | 30 - matita/components/tactics/declarative.ml | 311 --- matita/components/tactics/declarative.mli | 66 - matita/components/tactics/destructTactic.ml | 592 ----- matita/components/tactics/destructTactic.mli | 30 - matita/components/tactics/doc/Makefile | 124 - matita/components/tactics/doc/body.tex | 474 ---- matita/components/tactics/doc/infernce.sty | 217 -- matita/components/tactics/doc/ligature.sty | 169 -- matita/components/tactics/doc/main.tex | 70 - matita/components/tactics/doc/reserved.sty | 80 - matita/components/tactics/doc/semantic.sty | 137 -- matita/components/tactics/doc/shrthand.sty | 96 - matita/components/tactics/doc/tdiagram.sty | 166 -- .../components/tactics/eliminationTactics.ml | 170 -- .../components/tactics/eliminationTactics.mli | 33 - matita/components/tactics/equalityTactics.ml | 376 --- matita/components/tactics/equalityTactics.mli | 42 - matita/components/tactics/fourier.ml | 244 -- matita/components/tactics/fourier.mli | 27 - matita/components/tactics/fourierR.ml | 1199 --------- matita/components/tactics/fourierR.mli | 5 - matita/components/tactics/fwdSimplTactic.ml | 175 -- matita/components/tactics/fwdSimplTactic.mli | 33 - matita/components/tactics/hashtbl_equiv.ml | 190 -- matita/components/tactics/hashtbl_equiv.mli | 38 - matita/components/tactics/history.ml | 86 - matita/components/tactics/history.mli | 35 - .../components/tactics/introductionTactics.ml | 49 - .../tactics/introductionTactics.mli | 31 - matita/components/tactics/inversion.ml | 382 --- matita/components/tactics/inversion.mli | 29 - .../components/tactics/inversion_principle.ml | 253 -- .../tactics/inversion_principle.mli | 30 - matita/components/tactics/metadataQuery.ml | 530 ---- matita/components/tactics/metadataQuery.mli | 82 - matita/components/tactics/negationTactics.ml | 97 - matita/components/tactics/negationTactics.mli | 28 - .../components/tactics/paramodulation/.depend | 0 .../tactics/paramodulation/Makefile | 6 - .../components/tactics/paramodulation/README | 45 - .../tactics/paramodulation/equality.ml | 1379 ----------- .../tactics/paramodulation/equality.mli | 170 -- .../paramodulation/equality_indexing.ml | 130 - .../paramodulation/equality_indexing.mli | 42 - .../tactics/paramodulation/founif.ml | 242 -- .../tactics/paramodulation/founif.mli | 45 - .../tactics/paramodulation/indexing.ml | 1440 ----------- .../tactics/paramodulation/indexing.mli | 122 - .../tactics/paramodulation/saturation.ml | 1738 ------------- .../tactics/paramodulation/saturation.mli | 86 - .../tactics/paramodulation/subst.ml | 217 -- .../tactics/paramodulation/subst.mli | 43 - .../tactics/paramodulation/test_indexing.ml | 253 -- .../tactics/paramodulation/utils.ml | 783 ------ .../tactics/paramodulation/utils.mli | 89 - matita/components/tactics/primitiveTactics.ml | 1072 -------- .../components/tactics/primitiveTactics.mli | 103 - .../components/tactics/proofEngineHelpers.ml | 735 ------ .../components/tactics/proofEngineHelpers.mli | 138 -- .../tactics/proofEngineReduction.ml | 926 ------- .../tactics/proofEngineReduction.mli | 73 - .../tactics/proofEngineStructuralRules.ml | 200 -- .../tactics/proofEngineStructuralRules.mli | 31 - matita/components/tactics/proofEngineTypes.ml | 113 - .../components/tactics/proofEngineTypes.mli | 78 - matita/components/tactics/reductionTactics.ml | 233 -- .../components/tactics/reductionTactics.mli | 48 - matita/components/tactics/ring.ml | 595 ----- matita/components/tactics/ring.mli | 12 - matita/components/tactics/setoids.ml | 1916 --------------- matita/components/tactics/setoids.mli | 70 - .../components/tactics/statefulProofEngine.ml | 216 -- .../tactics/statefulProofEngine.mli | 123 - matita/components/tactics/tacticChaser.ml | 259 -- matita/components/tactics/tacticals.ml | 307 --- matita/components/tactics/tacticals.mli | 48 - matita/components/tactics/tactics.ml | 76 - matita/components/tactics/tactics.mli | 111 - matita/components/tactics/universe.ml | 187 -- matita/components/tactics/universe.mli | 66 - matita/components/tactics/variousTactics.ml | 58 - matita/components/tactics/variousTactics.mli | 27 - matita/configure.ac | 3 - matita/matita/applyTransformation.ml | 33 +- matita/matita/applyTransformation.mli | 6 - matita/matita/gtkmathview.matita.conf.xml.in | 31 - matita/matita/matita.ml | 64 +- matita/matita/matitaEngine.ml | 7 +- matita/matita/matitaExcPp.ml | 3 - matita/matita/matitaGui.ml | 9 +- matita/matita/matitaGuiTypes.mli | 2 - matita/matita/matitaInit.ml | 1 - matita/matita/matitaMathView.ml | 113 +- matita/matita/matitaScript.ml | 360 +-- matita/matita/matitaScript.mli | 6 - matita/matita/matitaTypes.ml | 2 - matita/matita/matitaTypes.mli | 1 - matita/matita/matitacLib.ml | 22 +- 157 files changed, 84 insertions(+), 30010 deletions(-) delete mode 100644 matita/components/METAS/meta.helm-acic_procedural.src delete mode 100644 matita/components/METAS/meta.helm-cic_disambiguation.src delete mode 100644 matita/components/METAS/meta.helm-tactics.src delete mode 100644 matita/components/METAS/meta.helm-tptp_grafite.src delete mode 100644 matita/components/acic_procedural/.depend delete mode 100644 matita/components/acic_procedural/.depend.opt delete mode 100644 matita/components/acic_procedural/Makefile delete mode 100644 matita/components/acic_procedural/acic2Procedural.ml delete mode 100644 matita/components/acic_procedural/acic2Procedural.mli delete mode 100644 matita/components/acic_procedural/procedural1.ml delete mode 100644 matita/components/acic_procedural/procedural1.mli delete mode 100644 matita/components/acic_procedural/procedural2.ml delete mode 100644 matita/components/acic_procedural/procedural2.mli delete mode 100644 matita/components/acic_procedural/proceduralClassify.ml delete mode 100644 matita/components/acic_procedural/proceduralClassify.mli delete mode 100644 matita/components/acic_procedural/proceduralConversion.ml delete mode 100644 matita/components/acic_procedural/proceduralConversion.mli delete mode 100644 matita/components/acic_procedural/proceduralHelpers.ml delete mode 100644 matita/components/acic_procedural/proceduralHelpers.mli delete mode 100644 matita/components/acic_procedural/proceduralMode.ml delete mode 100644 matita/components/acic_procedural/proceduralMode.mli delete mode 100644 matita/components/acic_procedural/proceduralOptimizer.ml delete mode 100644 matita/components/acic_procedural/proceduralOptimizer.mli delete mode 100644 matita/components/acic_procedural/proceduralTeX.ml delete mode 100644 matita/components/acic_procedural/proceduralTeX.mli delete mode 100644 matita/components/acic_procedural/proceduralTypes.ml delete mode 100644 matita/components/acic_procedural/proceduralTypes.mli rename matita/components/{tactics => ng_tactics}/continuationals.ml (99%) rename matita/components/{tactics => ng_tactics}/continuationals.mli (99%) delete mode 100644 matita/components/tactics/.depend delete mode 100644 matita/components/tactics/.depend.opt delete mode 100644 matita/components/tactics/Makefile delete mode 100644 matita/components/tactics/auto.ml delete mode 100644 matita/components/tactics/auto.mli delete mode 100644 matita/components/tactics/autoCache.ml delete mode 100644 matita/components/tactics/autoCache.mli delete mode 100644 matita/components/tactics/autoTypes.ml delete mode 100644 matita/components/tactics/autoTypes.mli delete mode 100644 matita/components/tactics/automationCache.ml delete mode 100644 matita/components/tactics/automationCache.mli delete mode 100644 matita/components/tactics/closeCoercionGraph.ml delete mode 100644 matita/components/tactics/closeCoercionGraph.mli delete mode 100644 matita/components/tactics/compose.ml delete mode 100644 matita/components/tactics/compose.mli delete mode 100644 matita/components/tactics/declarative.ml delete mode 100644 matita/components/tactics/declarative.mli delete mode 100644 matita/components/tactics/destructTactic.ml delete mode 100644 matita/components/tactics/destructTactic.mli delete mode 100644 matita/components/tactics/doc/Makefile delete mode 100644 matita/components/tactics/doc/body.tex delete mode 100644 matita/components/tactics/doc/infernce.sty delete mode 100644 matita/components/tactics/doc/ligature.sty delete mode 100644 matita/components/tactics/doc/main.tex delete mode 100644 matita/components/tactics/doc/reserved.sty delete mode 100644 matita/components/tactics/doc/semantic.sty delete mode 100644 matita/components/tactics/doc/shrthand.sty delete mode 100644 matita/components/tactics/doc/tdiagram.sty delete mode 100644 matita/components/tactics/eliminationTactics.ml delete mode 100644 matita/components/tactics/eliminationTactics.mli delete mode 100644 matita/components/tactics/equalityTactics.ml delete mode 100644 matita/components/tactics/equalityTactics.mli delete mode 100644 matita/components/tactics/fourier.ml delete mode 100644 matita/components/tactics/fourier.mli delete mode 100644 matita/components/tactics/fourierR.ml delete mode 100644 matita/components/tactics/fourierR.mli delete mode 100644 matita/components/tactics/fwdSimplTactic.ml delete mode 100644 matita/components/tactics/fwdSimplTactic.mli delete mode 100644 matita/components/tactics/hashtbl_equiv.ml delete mode 100644 matita/components/tactics/hashtbl_equiv.mli delete mode 100644 matita/components/tactics/history.ml delete mode 100644 matita/components/tactics/history.mli delete mode 100644 matita/components/tactics/introductionTactics.ml delete mode 100644 matita/components/tactics/introductionTactics.mli delete mode 100644 matita/components/tactics/inversion.ml delete mode 100644 matita/components/tactics/inversion.mli delete mode 100644 matita/components/tactics/inversion_principle.ml delete mode 100644 matita/components/tactics/inversion_principle.mli delete mode 100644 matita/components/tactics/metadataQuery.ml delete mode 100644 matita/components/tactics/metadataQuery.mli delete mode 100644 matita/components/tactics/negationTactics.ml delete mode 100644 matita/components/tactics/negationTactics.mli delete mode 100644 matita/components/tactics/paramodulation/.depend delete mode 100644 matita/components/tactics/paramodulation/Makefile delete mode 100644 matita/components/tactics/paramodulation/README delete mode 100644 matita/components/tactics/paramodulation/equality.ml delete mode 100644 matita/components/tactics/paramodulation/equality.mli delete mode 100644 matita/components/tactics/paramodulation/equality_indexing.ml delete mode 100644 matita/components/tactics/paramodulation/equality_indexing.mli delete mode 100644 matita/components/tactics/paramodulation/founif.ml delete mode 100644 matita/components/tactics/paramodulation/founif.mli delete mode 100644 matita/components/tactics/paramodulation/indexing.ml delete mode 100644 matita/components/tactics/paramodulation/indexing.mli delete mode 100644 matita/components/tactics/paramodulation/saturation.ml delete mode 100644 matita/components/tactics/paramodulation/saturation.mli delete mode 100644 matita/components/tactics/paramodulation/subst.ml delete mode 100644 matita/components/tactics/paramodulation/subst.mli delete mode 100644 matita/components/tactics/paramodulation/test_indexing.ml delete mode 100644 matita/components/tactics/paramodulation/utils.ml delete mode 100644 matita/components/tactics/paramodulation/utils.mli delete mode 100644 matita/components/tactics/primitiveTactics.ml delete mode 100644 matita/components/tactics/primitiveTactics.mli delete mode 100644 matita/components/tactics/proofEngineHelpers.ml delete mode 100644 matita/components/tactics/proofEngineHelpers.mli delete mode 100644 matita/components/tactics/proofEngineReduction.ml delete mode 100644 matita/components/tactics/proofEngineReduction.mli delete mode 100644 matita/components/tactics/proofEngineStructuralRules.ml delete mode 100644 matita/components/tactics/proofEngineStructuralRules.mli delete mode 100644 matita/components/tactics/proofEngineTypes.ml delete mode 100644 matita/components/tactics/proofEngineTypes.mli delete mode 100644 matita/components/tactics/reductionTactics.ml delete mode 100644 matita/components/tactics/reductionTactics.mli delete mode 100644 matita/components/tactics/ring.ml delete mode 100644 matita/components/tactics/ring.mli delete mode 100644 matita/components/tactics/setoids.ml delete mode 100644 matita/components/tactics/setoids.mli delete mode 100644 matita/components/tactics/statefulProofEngine.ml delete mode 100644 matita/components/tactics/statefulProofEngine.mli delete mode 100644 matita/components/tactics/tacticChaser.ml delete mode 100644 matita/components/tactics/tacticals.ml delete mode 100644 matita/components/tactics/tacticals.mli delete mode 100644 matita/components/tactics/tactics.ml delete mode 100644 matita/components/tactics/tactics.mli delete mode 100644 matita/components/tactics/universe.ml delete mode 100644 matita/components/tactics/universe.mli delete mode 100644 matita/components/tactics/variousTactics.ml delete mode 100644 matita/components/tactics/variousTactics.mli delete mode 100644 matita/matita/gtkmathview.matita.conf.xml.in diff --git a/matita/components/METAS/meta.helm-acic_procedural.src b/matita/components/METAS/meta.helm-acic_procedural.src deleted file mode 100644 index f696baea6..000000000 --- a/matita/components/METAS/meta.helm-acic_procedural.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-acic_content helm-grafite helm-tactics" -version="0.0.1" -archive(byte)="acic_procedural.cma" -archive(native)="acic_procedural.cmxa" diff --git a/matita/components/METAS/meta.helm-cic_disambiguation.src b/matita/components/METAS/meta.helm-cic_disambiguation.src deleted file mode 100644 index 6a5d3a38d..000000000 --- a/matita/components/METAS/meta.helm-cic_disambiguation.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-whelp helm-acic_content helm-cic_unification helm-disambiguation" -version="0.0.1" -archive(byte)="cic_disambiguation.cma" -archive(native)="cic_disambiguation.cmxa" diff --git a/matita/components/METAS/meta.helm-grafite_engine.src b/matita/components/METAS/meta.helm-grafite_engine.src index e23e0d0a7..a8f4e2f12 100644 --- a/matita/components/METAS/meta.helm-grafite_engine.src +++ b/matita/components/METAS/meta.helm-grafite_engine.src @@ -1,4 +1,4 @@ -requires="helm-library helm-grafite helm-tactics helm-ng_tactics helm-ng_library" +requires="helm-library helm-grafite helm-cic_unification helm-ng_tactics helm-ng_library" version="0.0.1" archive(byte)="grafite_engine.cma" archive(native)="grafite_engine.cmxa" diff --git a/matita/components/METAS/meta.helm-ng_tactics.src b/matita/components/METAS/meta.helm-ng_tactics.src index 73770ac9b..4a8eca4b1 100644 --- a/matita/components/METAS/meta.helm-ng_tactics.src +++ b/matita/components/METAS/meta.helm-ng_tactics.src @@ -1,4 +1,4 @@ -requires="helm-ng_disambiguation helm-lexicon helm-grafite_parser helm-tactics helm-ng_paramodulation" +requires="helm-ng_disambiguation helm-lexicon helm-grafite_parser helm-ng_paramodulation" version="0.0.1" archive(byte)="ng_tactics.cma" archive(native)="ng_tactics.cmxa" diff --git a/matita/components/METAS/meta.helm-tactics.src b/matita/components/METAS/meta.helm-tactics.src deleted file mode 100644 index 1eee28f6a..000000000 --- a/matita/components/METAS/meta.helm-tactics.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-extlib helm-cic_proof_checking helm-cic_unification" -version="0.0.1" -archive(byte)="tactics.cma" -archive(native)="tactics.cmxa" diff --git a/matita/components/METAS/meta.helm-tptp_grafite.src b/matita/components/METAS/meta.helm-tptp_grafite.src deleted file mode 100644 index 4c1675626..000000000 --- a/matita/components/METAS/meta.helm-tptp_grafite.src +++ /dev/null @@ -1,5 +0,0 @@ -requires="helm-acic_content helm-grafite helm-lexicon" -version="0.0.1" -archive(byte)="tptp_grafite.cma" -archive(native)="tptp_grafite.cmxa" -linkopts="" diff --git a/matita/components/Makefile b/matita/components/Makefile index 707990615..361d79610 100644 --- a/matita/components/Makefile +++ b/matita/components/Makefile @@ -10,7 +10,7 @@ MODULES = \ xml \ hgdome \ registry \ - hmysql \ + hmysql \ syntax_extensions \ thread \ xmldiff \ @@ -27,8 +27,6 @@ MODULES = \ acic_content \ grafite \ cic_unification \ - tactics \ - acic_procedural \ disambiguation \ ng_kernel \ ng_refiner \ diff --git a/matita/components/acic_procedural/.depend b/matita/components/acic_procedural/.depend deleted file mode 100644 index 97238c4d8..000000000 --- a/matita/components/acic_procedural/.depend +++ /dev/null @@ -1,38 +0,0 @@ -proceduralHelpers.cmi: -proceduralClassify.cmi: -proceduralOptimizer.cmi: -proceduralTypes.cmi: -proceduralMode.cmi: -proceduralConversion.cmi: -procedural1.cmi: proceduralTypes.cmi -procedural2.cmi: proceduralTypes.cmi -proceduralTeX.cmi: proceduralTypes.cmi -acic2Procedural.cmi: -proceduralHelpers.cmo: proceduralHelpers.cmi -proceduralHelpers.cmx: proceduralHelpers.cmi -proceduralClassify.cmo: proceduralHelpers.cmi proceduralClassify.cmi -proceduralClassify.cmx: proceduralHelpers.cmx proceduralClassify.cmi -proceduralOptimizer.cmo: proceduralHelpers.cmi proceduralClassify.cmi \ - proceduralOptimizer.cmi -proceduralOptimizer.cmx: proceduralHelpers.cmx proceduralClassify.cmx \ - proceduralOptimizer.cmi -proceduralTypes.cmo: proceduralHelpers.cmi proceduralTypes.cmi -proceduralTypes.cmx: proceduralHelpers.cmx proceduralTypes.cmi -proceduralMode.cmo: proceduralClassify.cmi proceduralMode.cmi -proceduralMode.cmx: proceduralClassify.cmx proceduralMode.cmi -proceduralConversion.cmo: proceduralHelpers.cmi proceduralConversion.cmi -proceduralConversion.cmx: proceduralHelpers.cmx proceduralConversion.cmi -procedural1.cmo: proceduralTypes.cmi procedural1.cmi -procedural1.cmx: proceduralTypes.cmx procedural1.cmi -procedural2.cmo: proceduralTypes.cmi proceduralHelpers.cmi \ - proceduralConversion.cmi proceduralClassify.cmi procedural2.cmi -procedural2.cmx: proceduralTypes.cmx proceduralHelpers.cmx \ - proceduralConversion.cmx proceduralClassify.cmx procedural2.cmi -proceduralTeX.cmo: proceduralTypes.cmi proceduralHelpers.cmi \ - proceduralTeX.cmi -proceduralTeX.cmx: proceduralTypes.cmx proceduralHelpers.cmx \ - proceduralTeX.cmi -acic2Procedural.cmo: proceduralTypes.cmi proceduralTeX.cmi \ - proceduralHelpers.cmi procedural2.cmi procedural1.cmi acic2Procedural.cmi -acic2Procedural.cmx: proceduralTypes.cmx proceduralTeX.cmx \ - proceduralHelpers.cmx procedural2.cmx procedural1.cmx acic2Procedural.cmi diff --git a/matita/components/acic_procedural/.depend.opt b/matita/components/acic_procedural/.depend.opt deleted file mode 100644 index 97238c4d8..000000000 --- a/matita/components/acic_procedural/.depend.opt +++ /dev/null @@ -1,38 +0,0 @@ -proceduralHelpers.cmi: -proceduralClassify.cmi: -proceduralOptimizer.cmi: -proceduralTypes.cmi: -proceduralMode.cmi: -proceduralConversion.cmi: -procedural1.cmi: proceduralTypes.cmi -procedural2.cmi: proceduralTypes.cmi -proceduralTeX.cmi: proceduralTypes.cmi -acic2Procedural.cmi: -proceduralHelpers.cmo: proceduralHelpers.cmi -proceduralHelpers.cmx: proceduralHelpers.cmi -proceduralClassify.cmo: proceduralHelpers.cmi proceduralClassify.cmi -proceduralClassify.cmx: proceduralHelpers.cmx proceduralClassify.cmi -proceduralOptimizer.cmo: proceduralHelpers.cmi proceduralClassify.cmi \ - proceduralOptimizer.cmi -proceduralOptimizer.cmx: proceduralHelpers.cmx proceduralClassify.cmx \ - proceduralOptimizer.cmi -proceduralTypes.cmo: proceduralHelpers.cmi proceduralTypes.cmi -proceduralTypes.cmx: proceduralHelpers.cmx proceduralTypes.cmi -proceduralMode.cmo: proceduralClassify.cmi proceduralMode.cmi -proceduralMode.cmx: proceduralClassify.cmx proceduralMode.cmi -proceduralConversion.cmo: proceduralHelpers.cmi proceduralConversion.cmi -proceduralConversion.cmx: proceduralHelpers.cmx proceduralConversion.cmi -procedural1.cmo: proceduralTypes.cmi procedural1.cmi -procedural1.cmx: proceduralTypes.cmx procedural1.cmi -procedural2.cmo: proceduralTypes.cmi proceduralHelpers.cmi \ - proceduralConversion.cmi proceduralClassify.cmi procedural2.cmi -procedural2.cmx: proceduralTypes.cmx proceduralHelpers.cmx \ - proceduralConversion.cmx proceduralClassify.cmx procedural2.cmi -proceduralTeX.cmo: proceduralTypes.cmi proceduralHelpers.cmi \ - proceduralTeX.cmi -proceduralTeX.cmx: proceduralTypes.cmx proceduralHelpers.cmx \ - proceduralTeX.cmi -acic2Procedural.cmo: proceduralTypes.cmi proceduralTeX.cmi \ - proceduralHelpers.cmi procedural2.cmi procedural1.cmi acic2Procedural.cmi -acic2Procedural.cmx: proceduralTypes.cmx proceduralTeX.cmx \ - proceduralHelpers.cmx procedural2.cmx procedural1.cmx acic2Procedural.cmi diff --git a/matita/components/acic_procedural/Makefile b/matita/components/acic_procedural/Makefile deleted file mode 100644 index ce878a21b..000000000 --- a/matita/components/acic_procedural/Makefile +++ /dev/null @@ -1,20 +0,0 @@ -PACKAGE = acic_procedural -PREDICATES = - -INTERFACE_FILES = \ - proceduralHelpers.mli \ - proceduralClassify.mli \ - proceduralOptimizer.mli \ - proceduralTypes.mli \ - proceduralMode.mli \ - proceduralConversion.mli \ - procedural1.mli \ - procedural2.mli \ - proceduralTeX.mli \ - acic2Procedural.mli \ - $(NULL) -IMPLEMENTATION_FILES = \ - $(INTERFACE_FILES:%.mli=%.ml) - -include ../../Makefile.defs -include ../Makefile.common diff --git a/matita/components/acic_procedural/acic2Procedural.ml b/matita/components/acic_procedural/acic2Procedural.ml deleted file mode 100644 index 63b4d4972..000000000 --- a/matita/components/acic_procedural/acic2Procedural.ml +++ /dev/null @@ -1,149 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -module C = Cic -module L = Librarian -module G = GrafiteAst - -module H = ProceduralHelpers -module T = ProceduralTypes -module P1 = Procedural1 -module P2 = Procedural2 -module X = ProceduralTeX - -let tex_formatter = ref None - -(* object costruction *******************************************************) - -let th_flavours = [`Theorem; `Lemma; `Remark; `Fact] - -let def_flavours = [`Definition; `Variant] - -let get_flavour sorts params context v attrs = - let rec aux = function - | [] -> - if H.is_acic_proof sorts context v then List.hd th_flavours - else List.hd def_flavours - | `Flavour fl :: _ -> fl - | _ :: tl -> aux tl - in - let flavour_map x y = match x, y with - | None, G.IPAs flavour -> Some flavour - | _ -> x - in - match List.fold_left flavour_map None params with - | Some fl -> fl - | None -> aux attrs - -let rec is_record = function - | [] -> None - | `Class (`Record fields) :: _ -> Some fields - | _ :: tl -> is_record tl - -let proc_obj ?(info="") proc_proof sorts params context = function - | C.AConstant (_, _, s, Some v, t, [], attrs) -> - begin match get_flavour sorts params context v attrs with - | flavour when List.mem flavour th_flavours -> - let ast = proc_proof v in - let steps, nodes = T.count_steps 0 ast, T.count_nodes 0 ast in - let text = - if List.mem G.IPComments params then - Printf.sprintf "%s\n%s%s: %u\n%s: %u\n%s" - "COMMENTS" info "Tactics" steps "Final nodes" nodes "END" - else - "" - in - T.Statement (flavour, Some s, t, None, "") :: ast @ [T.Qed text] - | flavour when List.mem flavour def_flavours -> - [T.Statement (flavour, Some s, t, Some v, "")] - | _ -> - failwith "not a theorem, definition, axiom or inductive type" - end - | C.AConstant (_, _, s, None, t, [], attrs) -> - [T.Statement (`Axiom, Some s, t, None, "")] - | C.AInductiveDefinition (_, types, [], lpsno, attrs) -> - begin match is_record attrs with - | None -> [T.Inductive (types, lpsno, "")] - | Some fs -> [T.Record (types, lpsno, fs, "")] - end - | _ -> - failwith "not a theorem, definition, axiom or inductive type" - -(* interface functions ******************************************************) - -let get_proc_proof ~ids_to_inner_sorts ~ids_to_inner_types params context = - let level_map x y = match x, y with - | None, G.IPLevel level -> Some level - | _ -> x - in - match List.fold_left level_map None params with - | None - | Some 2 -> - P2.proc_proof - (P2.init ~ids_to_inner_sorts ~ids_to_inner_types params context) - | Some 1 -> - P1.proc_proof - (P1.init ~ids_to_inner_sorts ~ids_to_inner_types params context) - | Some n -> - failwith ( - "Procedural reconstruction level not supported: " ^ - string_of_int n - ) - -let procedural_of_acic_object ~ids_to_inner_sorts ~ids_to_inner_types - ?info params anobj = - let proc_proof = - get_proc_proof ~ids_to_inner_sorts ~ids_to_inner_types params [] - in - L.time_stamp "P : LEVEL 2 "; - HLog.debug "Procedural: level 2 transformation"; - let steps = proc_obj ?info proc_proof ids_to_inner_sorts params [] anobj in - let _ = match !tex_formatter with - | None -> () - | Some frm -> X.tex_of_steps frm ids_to_inner_sorts steps - in - L.time_stamp "P : RENDERING"; - HLog.debug "Procedural: grafite rendering"; - let r = List.rev (T.render_steps [] steps) in - L.time_stamp "P : DONE "; r - -let procedural_of_acic_term ~ids_to_inner_sorts ~ids_to_inner_types params - context annterm = - let proc_proof = - get_proc_proof ~ids_to_inner_sorts ~ids_to_inner_types params context - in - HLog.debug "Procedural: level 2 transformation"; - let steps = proc_proof annterm in - let _ = match !tex_formatter with - | None -> () - | Some frm -> X.tex_of_steps frm ids_to_inner_sorts steps - in - HLog.debug "Procedural: grafite rendering"; - List.rev (T.render_steps [] steps) - -let rec is_debug n = function - | [] -> false - | G.IPDebug debug :: _ -> n <= debug - | _ :: tl -> is_debug n tl diff --git a/matita/components/acic_procedural/acic2Procedural.mli b/matita/components/acic_procedural/acic2Procedural.mli deleted file mode 100644 index 786f60073..000000000 --- a/matita/components/acic_procedural/acic2Procedural.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val procedural_of_acic_object: - ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> - ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t -> ?info:string -> - GrafiteAst.inline_param list -> Cic.annobj -> - (Cic.annterm, Cic.annterm, - Cic.annterm GrafiteAst.reduction, Cic.annterm CicNotationPt.obj, string) - GrafiteAst.statement list - -val procedural_of_acic_term: - ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> - ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t -> - GrafiteAst.inline_param list -> Cic.context -> Cic.annterm -> - (Cic.annterm, Cic.annterm, - Cic.annterm GrafiteAst.reduction, Cic.annterm CicNotationPt.obj, string) - GrafiteAst.statement list - -val tex_formatter: Format.formatter option ref - -val is_debug: int -> GrafiteAst.inline_param list -> bool diff --git a/matita/components/acic_procedural/procedural1.ml b/matita/components/acic_procedural/procedural1.ml deleted file mode 100644 index 550dd07e6..000000000 --- a/matita/components/acic_procedural/procedural1.ml +++ /dev/null @@ -1,51 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -module C = Cic -module A = Cic2acic -module G = GrafiteAst - -module T = ProceduralTypes - -type status = { - sorts : (C.id, A.sort_kind) Hashtbl.t; - types : (C.id, A.anntypes) Hashtbl.t; - params : G.inline_param list; - context : C.context -} - -(* interface functions ******************************************************) - -let proc_proof st what = - let dtext = "" in - [T.Exact (what, dtext)] - -let init ~ids_to_inner_sorts ~ids_to_inner_types params context = - { - sorts = ids_to_inner_sorts; - types = ids_to_inner_types; - params = params; - context = context - } diff --git a/matita/components/acic_procedural/procedural1.mli b/matita/components/acic_procedural/procedural1.mli deleted file mode 100644 index 83de9d420..000000000 --- a/matita/components/acic_procedural/procedural1.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type status - -val init: - ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> - ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t -> - GrafiteAst.inline_param list-> Cic.context -> status - -val proc_proof: - status -> Cic.annterm -> ProceduralTypes.step list diff --git a/matita/components/acic_procedural/procedural2.ml b/matita/components/acic_procedural/procedural2.ml deleted file mode 100644 index ff8f864ea..000000000 --- a/matita/components/acic_procedural/procedural2.ml +++ /dev/null @@ -1,586 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -module C = Cic -module I = CicInspect -module S = CicSubstitution -module R = CicReduction -module TC = CicTypeChecker -module Un = CicUniv -module UM = UriManager -module Obj = LibraryObjects -module A = Cic2acic -module Ut = CicUtil -module E = CicEnvironment -module Pp = CicPp -module PEH = ProofEngineHelpers -module HEL = HExtlib -module DTI = DoubleTypeInference -module NU = CicNotationUtil -module L = Librarian -module G = GrafiteAst - -module Cl = ProceduralClassify -module T = ProceduralTypes -module Cn = ProceduralConversion -module H = ProceduralHelpers - -type status = { - sorts : (C.id, A.sort_kind) Hashtbl.t; - types : (C.id, A.anntypes) Hashtbl.t; - params : G.inline_param list; - max_depth: int option; - depth : int; - defaults : bool; - cr : bool; - context : C.context; - case : int list -} - -let debug = ref false - -(* helpers ******************************************************************) - -let split2_last l1 l2 = -try - let n = pred (List.length l1) in - let before1, after1 = HEL.split_nth n l1 in - let before2, after2 = HEL.split_nth n l2 in - before1, before2, List.hd after1, List.hd after2 -with Invalid_argument _ -> failwith "A2P.split2_last" - -let string_of_head = function - | C.ASort _ -> "sort" - | C.AConst _ -> "const" - | C.AMutInd _ -> "mutind" - | C.AMutConstruct _ -> "mutconstruct" - | C.AVar _ -> "var" - | C.ARel _ -> "rel" - | C.AProd _ -> "prod" - | C.ALambda _ -> "lambda" - | C.ALetIn _ -> "letin" - | C.AFix _ -> "fix" - | C.ACoFix _ -> "cofix" - | C.AAppl _ -> "appl" - | C.ACast _ -> "cast" - | C.AMutCase _ -> "mutcase" - | C.AMeta _ -> "meta" - | C.AImplicit _ -> "implict" - -let next st = {st with depth = succ st.depth} - -let add st entry = {st with context = entry :: st.context} - -let push st = {st with case = 1 :: st.case} - -let inc st = - {st with case = match st.case with - | [] -> [] - | hd :: tl -> succ hd :: tl - } - -let case st str = - let case = String.concat "." (List.rev_map string_of_int st.case) in - Printf.sprintf "case %s: %s" case str - -let test_depth st = -try - let msg = Printf.sprintf "Depth %u: " st.depth in - match st.max_depth with - | None -> true, "" - | Some d -> if st.depth < d then true, msg else false, "DEPTH EXCEDED: " -with Invalid_argument _ -> failwith "A2P.test_depth" - -let is_rewrite_right st = function - | C.AConst (_, uri, []) -> st.defaults && Obj.is_eq_ind_r_URI uri - | _ -> false - -let is_rewrite_left st = function - | C.AConst (_, uri, []) -> st.defaults && Obj.is_eq_ind_URI uri - | _ -> false - -let is_fwd_rewrite_right st hd tl = - if is_rewrite_right st hd then match List.nth tl 3 with - | C.ARel _ -> true - | _ -> false - else false - -let is_fwd_rewrite_left st hd tl = - if is_rewrite_left st hd then match List.nth tl 3 with - | C.ARel _ -> true - | _ -> false - else false - -let get_inner_types st v = -try - let id = Ut.id_of_annterm v in - try match Hashtbl.find st.types id with - | {A.annsynthesized = ity; A.annexpected = Some ety} -> Some (ity, ety) - | {A.annsynthesized = ity; A.annexpected = None} -> Some (ity, ity) - with Not_found -> None -with Invalid_argument _ -> failwith "P2.get_inner_types" - -let get_entry st id = - let rec aux = function - | [] -> assert false - | Some (C.Name name, e) :: _ when name = id -> e - | _ :: tl -> aux tl - in - aux st.context - -let string_of_atomic = function - | C.ARel (_, _, _, s) -> s - | C.AVar (_, uri, _) -> H.name_of_uri uri None None - | C.AConst (_, uri, _) -> H.name_of_uri uri None None - | C.AMutInd (_, uri, i, _) -> H.name_of_uri uri (Some i) None - | C.AMutConstruct (_, uri, i, j, _) -> H.name_of_uri uri (Some i) (Some j) - | _ -> "" - -let get_sub_names head l = - let s = string_of_atomic head in - if s = "" then [] else - let map (names, i) _ = - let name = Printf.sprintf "%s_%u" s i in name :: names, succ i - in - let names, _ = List.fold_left map ([], 1) l in - List.rev names - -let get_type msg st t = H.get_type msg st.context (H.cic t) - -let get_uri_of_head = function - | C.AConst (_, u, _) -> - Some (u, 0, 0, 0) - | C.AAppl (_, C.AConst (_, u, _) :: vs) -> - Some (u, 0, 0, List.length vs) - | C.AMutInd (_, u, i, _) -> - Some (u, succ i, 0, 0) - | C.AAppl (_, C.AMutInd (_, u, i, _) :: vs) -> - Some (u, succ i, 0, List.length vs) - | C.AMutConstruct (_, u, i, j, _) -> - Some (u, succ i, j, 0) - | C.AAppl (_, C.AMutConstruct (_, u, i, j, _) :: vs) -> - Some (u, succ i, j, List.length vs) - | _ -> - None - -let get_uri_of_apply = function - | T.Exact (t, _) - | T.Apply (t, _) -> get_uri_of_head t - | _ -> None - -let is_reflexivity st step = - match get_uri_of_apply step with - | None -> false - | Some (uri, i, j, n) -> - st.defaults && Obj.is_eq_URI uri && i = 1 && j = 1 && n = 0 - -let is_ho_reflexivity st step = - match get_uri_of_apply step with - | None -> false - | Some (uri, i, j, n) -> - st.defaults && Obj.is_eq_URI uri && i = 1 && j = 1 && n > 0 - -let are_convertible st pred sx dx = - let pred, sx, dx = H.cic pred, H.cic sx, H.cic dx in - let sx, dx = C.Appl [pred; sx], C.Appl [pred; dx] in - fst (R.are_convertible st.context sx dx Un.default_ugraph) - -(* proof construction *******************************************************) - -let anonymous_premise = C.Name "UNNAMED" - -let mk_lapply_args hd tl classes = - let map _ = Cn.meta "" in - let args = List.rev_map map tl in - if args = [] then hd else C.AAppl ("", hd :: args) - -let mk_apply_args hd tl classes synth qs = - let exp = ref 0 in - let map v (cl, b) = - if I.overlaps synth cl - then if b then v, v else Cn.meta "", v - else Cn.meta "", Cn.meta "" - in - let rec rev a = function - | [] -> a - | hd :: tl -> - if snd hd <> Cn.meta "" then incr exp; - rev (snd hd :: a) tl - in - let rec aux = function - | [] -> [] - | hd :: tl -> - if fst hd = Cn.meta "" then aux tl else rev [] (hd :: tl) - in - let args = T.list_rev_map2 map tl classes in - let args = aux args in - let part = !exp < List.length tl in - if args = [] then part, hd, qs else part, C.AAppl ("", hd :: args), qs - -let mk_convert st ?name sty ety note = - let ppterm t = - let a = ref "" in Ut.pp_term (fun s -> a := !a ^ s) [] st.context t; !a - in - let e = Cn.hole "" in - let csty, cety = H.cic sty, H.cic ety in - let note = - if !debug then - let sname = match name with None -> "" | Some (id, _) -> id in - Printf.sprintf "%s: %s\nSINTH: %s\nEXP: %s" - note sname (ppterm csty) (ppterm cety) - else "" - in - if H.alpha ~flatten:true st.context csty cety then [T.Note note] else - let sty, ety = H.acic_bc st.context sty, H.acic_bc st.context ety in - match name with - | None -> [T.Change (sty, ety, None, e, note)] - | Some (id, i) -> - begin match get_entry st id with - | C.Def _ -> - [T.Change (ety, sty, Some (id, Some id), e, note); - T.ClearBody (id, "") - ] - | C.Decl _ -> - [T.Change (ety, sty, Some (id, Some id), e, note)] - end - -let convert st ?name v = - match get_inner_types st v with - | None -> - if !debug then [T.Note "NORMAL: NO INNER TYPES"] else [] - | Some (sty, ety) -> mk_convert st ?name sty ety "NORMAL" - -let get_intro = function - | C.Anonymous -> None - | C.Name s -> Some s - -let mk_preamble st what script = match script with - | step :: script when is_reflexivity st step -> - T.Reflexivity (T.note_of_step step) :: script - | step :: script when is_ho_reflexivity st step -> - convert st what @ T.Reflexivity (T.note_of_step step) :: script - | T.Exact _ :: _ -> script - | _ -> convert st what @ script - -let mk_arg st = function - | C.ARel (_, _, i, name) as what -> convert st ~name:(name, i) what - | _ -> [] - -let mk_fwd_rewrite st dtext name tl direction v t ity ety = - let compare premise = function - | None -> true - | Some s -> s = premise - in - assert (List.length tl = 6); - let what, where, predicate = List.nth tl 5, List.nth tl 3, List.nth tl 2 in - let e = Cn.mk_pattern 1 ety predicate in - if (Cn.does_not_occur e) then st, [] else - match where with - | C.ARel (_, _, i, premise) as w -> - let script name = - let where = Some (premise, name) in - let script = mk_arg st what @ mk_arg st w in - T.Rewrite (direction, what, where, e, dtext) :: script - in - if DTI.does_not_occur (succ i) (H.cic t) || compare premise name then - {st with context = Cn.clear st.context premise}, script name - else begin - assert (Ut.is_sober st.context (H.cic ity)); - let ity = H.acic_bc st.context ity in - let br1 = [T.Id ""] in - let br2 = List.rev (T.Exact (w, "assumption") :: script None) in - let text = "non-linear rewrite" in - st, [T.Branch ([br2; br1], ""); T.Cut (name, ity, text)] - end - | _ -> assert false - -let mk_rewrite st dtext where qs tl direction t ity = - let ppterm t = - let a = ref "" in Ut.pp_term (fun s -> a := !a ^ s) [] st.context t; !a - in - assert (List.length tl = 5); - let pred, sx, dx = List.nth tl 2, List.nth tl 1, List.nth tl 4 in - let dtext = if !debug then dtext ^ ppterm (H.cic pred) else dtext in - let e = Cn.mk_pattern 1 ity pred in - let script = [T.Branch (qs, "")] in - if Cn.does_not_occur e then script else - if st.cr && are_convertible st pred sx dx then - let dtext = "convertible rewrite" ^ dtext in - let ity, ety, e = Cn.beta sx pred, Cn.beta dx pred, Cn.hole "" in - let city, cety = H.cic ity, H.cic ety in - if H.alpha ~flatten:true st.context city cety then script else - T.Change (ity, ety, None, e, dtext) :: script - else - T.Rewrite (direction, where, None, e, dtext) :: script - -let rec proc_lambda st what name v t = - let dtext = if !debug then CicPp.ppcontext st.context else "" in - let name = match name with - | C.Anonymous -> H.mk_fresh_name true st.context anonymous_premise - | name -> name - in - let entry = Some (name, C.Decl (H.cic v)) in - let intro = get_intro name in - let script = proc_proof (add st entry) t in - let script = T.Intros (Some 1, [intro], dtext) :: script in - mk_preamble st what script - -and proc_letin st what name v w t = - let intro = get_intro name in - let proceed, dtext = test_depth st in - let script = if proceed then - let st, hyp, rqv = match get_inner_types st what, get_inner_types st v with - | Some (C.ALetIn (_, _, iv, iw, _), _), _ when - H.alpha ~flatten:true st.context (H.cic v) (H.cic iv) && - H.alpha ~flatten:true st.context (H.cic w) (H.cic iw) - -> - st, C.Def (H.cic v, H.cic w), [T.Intros (Some 1, [intro], dtext)] - | _, Some (ity, ety) -> - let st, rqv = match v with - | C.AAppl (_, hd :: tl) when is_fwd_rewrite_right st hd tl -> - mk_fwd_rewrite st dtext intro tl true v t ity ety - | C.AAppl (_, hd :: tl) when is_fwd_rewrite_left st hd tl -> - mk_fwd_rewrite st dtext intro tl false v t ity ety - | C.AAppl (_, hd :: tl) -> - let ty = match get_inner_types st hd with - | Some (ity, _) -> H.cic ity - | None -> get_type "TC3" st hd - in - let classes, _ = Cl.classify st.context ty in - let parsno, argsno = List.length classes, List.length tl in - let decurry = parsno - argsno in - if decurry <> 0 then begin -(* FG: we fall back in the cut case *) - assert (Ut.is_sober st.context (H.cic ety)); - let ety = H.acic_bc st.context ety in - let qs = [proc_proof (next st) v; [T.Id ""]] in - st, [T.Branch (qs, ""); T.Cut (intro, ety, dtext)] - end else - let names, synth = get_sub_names hd tl, I.S.empty in - let qs = proc_bkd_proofs (next st) synth names classes tl in - let hd = mk_lapply_args hd tl classes in - let qs = [T.Id ""] :: qs in - st, [T.Branch (qs, ""); T.LApply (intro, hd, dtext)] - | v -> - assert (Ut.is_sober st.context (H.cic ety)); - let ety = H.acic_bc st.context ety in - let qs = [proc_proof (next st) v; [T.Id ""]] in - st, [T.Branch (qs, ""); T.Cut (intro, ety, dtext)] - in - st, C.Decl (H.cic ity), rqv - | _, None -> - st, C.Def (H.cic v, H.cic w), [T.LetIn (intro, v, dtext)] - in - let entry = Some (name, hyp) in - let qt = proc_proof (next (add st entry)) t in - List.rev_append rqv qt - else - [T.Exact (what, dtext)] - in - mk_preamble st what script - -and proc_rel st what = - let _, dtext = test_depth st in - let text = "assumption" in - let script = [T.Exact (what, dtext ^ text)] in - mk_preamble st what script - -and proc_mutconstruct st what = - let _, dtext = test_depth st in - let script = [T.Exact (what, dtext)] in - mk_preamble st what script - -and proc_const st what = - let _, dtext = test_depth st in - let script = [T.Exact (what, dtext)] in - mk_preamble st what script - -and proc_appl st what hd tl = - let proceed, dtext = test_depth st in - let script = if proceed then - let ty = match get_inner_types st hd with - | Some (ity, _) -> H.cic ity - | None -> get_type "TC2" st hd - in - let classes, rc = Cl.classify st.context ty in - let goal_arity, goal = match get_inner_types st what with - | None -> 0, None - | Some (ity, _) -> - snd (PEH.split_with_whd (st.context, H.cic ity)), Some (H.cic ity) - in - let parsno, argsno = List.length classes, List.length tl in - let decurry = parsno - argsno in - let diff = goal_arity - decurry in - if diff < 0 then - let text = Printf.sprintf "partial application: %i" diff in - prerr_endline ("Procedural 2: " ^ text); - [T.Exact (what, dtext ^ text)] - else - let classes = Cl.adjust st.context tl ?goal classes in - let rec mk_synth a n = - if n < 0 then a else mk_synth (I.S.add n a) (pred n) - in - let synth = mk_synth I.S.empty decurry in - let text = if !debug - then Printf.sprintf "%u %s" parsno (Cl.to_string synth (classes, rc)) - else "" - in - let script = List.rev (mk_arg st hd) in - let tactic b t n = if b then T.Apply (t, n) else T.Exact (t, n) in - match rc with - | Some (i, j, uri, tyno) when decurry = 0 -> - let classes2, tl2, _, where = split2_last classes tl in - let script2 = List.rev (mk_arg st where) @ script in - let synth2 = I.S.add 1 synth in - let names = H.get_ind_names uri tyno in - let qs = proc_bkd_proofs (next st) synth2 names classes2 tl2 in - let ity = match get_inner_types st what with - | Some (ity, _) -> ity - | None -> - Cn.fake_annotate "" st.context (get_type "TC3" st what) - in - if List.length qs <> List.length names then - let qs = proc_bkd_proofs (next st) synth [] classes tl in - let b, hd, qs = mk_apply_args hd tl classes synth qs in - script @ [tactic b hd (dtext ^ text); T.Branch (qs, "")] - else if is_rewrite_right st hd then - script2 @ mk_rewrite st dtext where qs tl2 false what ity - else if is_rewrite_left st hd then - script2 @ mk_rewrite st dtext where qs tl2 true what ity - else - let predicate = List.nth tl2 (parsno - i) in - let e = Cn.mk_pattern j ity predicate in - let using = Some hd in - script2 @ - [T.Elim (where, using, e, dtext ^ text); T.Branch (qs, "")] - | _ -> - let names = get_sub_names hd tl in - let qs = proc_bkd_proofs (next st) synth names classes tl in - let b, hd, qs = mk_apply_args hd tl classes synth qs in - script @ [tactic b hd (dtext ^ text); T.Branch (qs, "")] - else - [T.Exact (what, dtext)] - in - mk_preamble st what script - -and proc_case st what uri tyno u v ts = - let proceed, dtext = test_depth st in - let script = if proceed then - let synth, classes = I.S.empty, Cl.make ts in - let names = H.get_ind_names uri tyno in - let qs = proc_bkd_proofs (next st) synth names classes ts in - let lpsno, _ = H.get_ind_type uri tyno in - let ps, _ = H.get_ind_parameters st.context (H.cic v) in - let _, rps = HEL.split_nth lpsno ps in - let rpsno = List.length rps in - let ity = match get_inner_types st what with - | Some (ity, _) -> ity - | None -> - Cn.fake_annotate "" st.context (get_type "TC4" st what) - in - let e = Cn.mk_pattern rpsno ity u in - let text = "" in - let script = List.rev (mk_arg st v) in - script @ [T.Cases (v, e, dtext ^ text); T.Branch (qs, "")] - else - [T.Exact (what, dtext)] - in - mk_preamble st what script - -and proc_other st what = - let _, dtext = test_depth st in - let text = Printf.sprintf "%s: %s" "UNEXPANDED" (string_of_head what) in - let script = [T.Exact (what, dtext ^ text)] in - mk_preamble st what script - -and proc_proof st t = - let f st = -(* - let xtypes, note = match get_inner_types st t with - | Some (it, et) -> Some (H.cic it, H.cic et), - (Printf.sprintf "\nInferred: %s\nExpected: %s" - (Pp.ppterm (H.cic it)) (Pp.ppterm (H.cic et))) - | None -> None, "\nNo types" - in - let context, clears = Cn.get_clears st.context (H.cic t) xtypes in - {st with context = context} -*) - st - in - match t with - | C.ALambda (_, name, w, t) as what -> proc_lambda (f st) what name w t - | C.ALetIn (_, name, v, w, t) as what -> proc_letin (f st) what name v w t - | C.ARel _ as what -> proc_rel (f st) what - | C.AMutConstruct _ as what -> proc_mutconstruct (f st) what - | C.AConst _ as what -> proc_const (f st) what - | C.AAppl (_, hd :: tl) as what -> proc_appl (f st) what hd tl -(* FG: we deactivate the tactic "cases" because it does not work properly - | C.AMutCase (_, uri, i, u, v, ts) as what -> proc_case (f st) what uri i u v ts -*) - | what -> proc_other (f st) what - -and proc_bkd_proofs st synth names classes ts = -try - let get_names b = ref (names, if b then push st else st) in - let get_note f b names = - match !names with - | [], st -> f st - | "" :: tl, st -> names := tl, st; f st - | hd :: tl, st -> - let note = case st hd in - names := tl, inc st; - if b then T.Note note :: f st else f st - in - let _, dtext = test_depth st in - let aux (inv, _) v = - if I.overlaps synth inv then None else - if I.S.is_empty inv then Some (get_note (fun st -> proc_proof st v)) else - Some (get_note (fun _ -> [T.Exact (v, dtext ^ "dependent")])) - in - let ps = T.list_map2_filter aux classes ts in - let b = List.length ps > 1 in - let names = get_names b in - List.rev_map (fun f -> f b names) ps - -with Invalid_argument s -> failwith ("A2P.proc_bkd_proofs: " ^ s) - -(* initialization ***********************************************************) - -let init ~ids_to_inner_sorts ~ids_to_inner_types params context = - let depth_map x y = match x, y with - | None, G.IPDepth depth -> Some depth - | _ -> x - in - { - sorts = ids_to_inner_sorts; - types = ids_to_inner_types; - params = params; - max_depth = List.fold_left depth_map None params; - depth = 0; - defaults = not (List.mem G.IPNoDefaults params); - cr = List.mem G.IPCR params; - context = context; - case = [] - } diff --git a/matita/components/acic_procedural/procedural2.mli b/matita/components/acic_procedural/procedural2.mli deleted file mode 100644 index 7abfb6f1c..000000000 --- a/matita/components/acic_procedural/procedural2.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type status - -val init: - ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> - ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t -> - GrafiteAst.inline_param list-> Cic.context -> status - -val proc_proof: - status -> Cic.annterm -> ProceduralTypes.step list - -val debug: bool ref diff --git a/matita/components/acic_procedural/proceduralClassify.ml b/matita/components/acic_procedural/proceduralClassify.ml deleted file mode 100644 index 6da59eed1..000000000 --- a/matita/components/acic_procedural/proceduralClassify.ml +++ /dev/null @@ -1,139 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -module UM = UriManager -module C = Cic -module D = Deannotate -module I = CicInspect -module PEH = ProofEngineHelpers - -module H = ProceduralHelpers - -type dependences = (I.S.t * bool) list - -type conclusion = (int * int * UM.uri * int) option - -(* debugging ****************************************************************) - -let string_of_entry synth (inverse, b) = - if I.overlaps synth inverse then begin if b then "CF" else "C" end else - if I.S.is_empty inverse then "I" else "P" - -let to_string synth (classes, rc) = - let linearize = - String.concat " " (List.map (string_of_entry synth) classes) - in - match rc with - | None -> linearize - | Some (i, j, _, _) -> Printf.sprintf "%s %u %u" linearize i j - -let out_table b = - let map i (_, inverse) = - let map i tl = Printf.sprintf "%2u" i :: tl in - let iset = String.concat " " (I.S.fold map inverse []) in - Printf.eprintf "%2u|%s\n" i iset - in - Array.iteri map b; - prerr_newline () - -(* dummy dependences ********************************************************) - -let make l = - let map _ = I.S.empty, false in - List.rev_map map l - -(* classification ***********************************************************) - -let classify_conclusion vs = - let rec get_argsno = function - | c, C.Appl (t :: vs) -> - let hd, argsno = get_argsno (c, t) in - hd, argsno + List.length vs - | _, t -> t, 0 - in - let inside i = i > 1 && i <= List.length vs in - match vs with - | v0 :: v1 :: _ -> - let hd0, a0 = get_argsno v0 in - let hd1, a1 = get_argsno v1 in - begin match hd0, hd1 with - | C.Rel i, C.MutInd (u, n, _) when inside i -> Some (i, a0, u, n) - | _ -> None - end - | _ -> None - -let classify c t = -try - let vs, h = PEH.split_with_whd (c, t) in - let rc = classify_conclusion vs in - let map (b, h) (c, v) = - let _, argsno = PEH.split_with_whd (c, v) in - let isf = argsno > 0 (* || H.is_sort v *) in - let iu = H.is_unsafe h (List.hd vs) in - (I.get_rels_from_premise h v, I.S.empty, isf && iu) :: b, succ h - in - let l, h = List.fold_left map ([], 0) vs in - let b = Array.of_list (List.rev l) in - let mk_closure b h = - let map j = if j < h then I.S.union (H.fst3 b.(j)) else H.identity in - for i = pred h downto 0 do - let direct, unused, fa = b.(i) in - b.(i) <- I.S.fold map direct direct, unused, fa - done; b - in - let b = mk_closure b h in - let rec mk_inverse i direct = - if I.S.is_empty direct then () else - let j = I.S.choose direct in - if j < h then - let unused, inverse, fa = b.(j) in - b.(j) <- unused, I.S.add i inverse, fa - else (); - mk_inverse i (I.S.remove j direct) - in - let map i (direct, _, _) = mk_inverse i direct in - Array.iteri map b; -(* out_table b; *) - let extract (x, y, z) = y, z in - List.rev_map extract (List.tl (Array.to_list b)), rc -with Invalid_argument _ -> failwith "Classify.classify" - -(* adjusting the inferrable arguments that do not occur in the goal *********) - -let adjust c vs ?goal classes = - let list_xmap2 map l1 l2 = - let rec aux a = function - | hd1 :: tl1, hd2 :: tl2 -> aux (map hd1 hd2 :: a) (tl1,tl2) - | _, l2 -> List.rev_append l2 a - in - List.rev (aux [] (l1, l2)) - in - let map where what (i, b) = - let what = H.cic what in - (i, b || not (H.occurs c ~what ~where)) - in - match goal with - | None -> classes - | Some goal -> list_xmap2 (map goal) vs classes diff --git a/matita/components/acic_procedural/proceduralClassify.mli b/matita/components/acic_procedural/proceduralClassify.mli deleted file mode 100644 index fed7d9db7..000000000 --- a/matita/components/acic_procedural/proceduralClassify.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type dependences = (CicInspect.S.t * bool) list - -type conclusion = (int * int * UriManager.uri * int) option - -val make: 'a list -> dependences - -val classify: Cic.context -> Cic.term -> dependences * conclusion - -val adjust: Cic.context -> Cic.annterm list -> ?goal:Cic.term -> dependences -> dependences - -val to_string: CicInspect.S.t -> dependences * conclusion -> string diff --git a/matita/components/acic_procedural/proceduralConversion.ml b/matita/components/acic_procedural/proceduralConversion.ml deleted file mode 100644 index e73ccfe59..000000000 --- a/matita/components/acic_procedural/proceduralConversion.ml +++ /dev/null @@ -1,292 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -module C = Cic -module E = CicEnvironment -module Un = CicUniv -module TC = CicTypeChecker -module UM = UriManager -module Rd = CicReduction -module PEH = ProofEngineHelpers -module PT = PrimitiveTactics -module DTI = DoubleTypeInference - -module H = ProceduralHelpers - -(* helpers ******************************************************************) - -let rec list_sub start length = function - | _ :: tl when start > 0 -> list_sub (pred start) length tl - | hd :: tl when length > 0 -> hd :: list_sub start (pred length) tl - | _ -> [] - -(* proof construction *******************************************************) - -let iter f k = - let rec iter_xns k (uri, t) = uri, iter_term k t - and iter_ms k = function - | None -> None - | Some t -> Some (iter_term k t) - and iter_fix len k (id, name, i, ty, bo) = - id, name, i, iter_term k ty, iter_term (k + len) bo - and iter_cofix len k (id, name, ty, bo) = - id, name, iter_term k ty, iter_term (k + len) bo - and iter_term k = function - | C.ASort _ as t -> t - | C.AImplicit _ as t -> t - | C.ARel (id, rid, m, b) as t -> - if m < k then t else f k id rid m b - | C.AConst (id, uri, xnss) -> C.AConst (id, uri, List.map (iter_xns k) xnss) - | C.AVar (id, uri, xnss) -> C.AVar (id, uri, List.map (iter_xns k) xnss) - | C.AMutInd (id, uri, tyno, xnss) -> C.AMutInd (id, uri, tyno, List.map (iter_xns k) xnss) - | C.AMutConstruct (id, uri, tyno, consno, xnss) -> C.AMutConstruct (id, uri,tyno,consno, List.map (iter_xns k) xnss) - | C.AMeta (id, i, mss) -> C.AMeta(id, i, List.map (iter_ms k) mss) - | C.AAppl (id, ts) -> C.AAppl (id, List.map (iter_term k) ts) - | C.ACast (id, te, ty) -> C.ACast (id, iter_term k te, iter_term k ty) - | C.AMutCase (id, sp, i, outty, t, pl) -> C.AMutCase (id, sp, i, iter_term k outty, iter_term k t, List.map (iter_term k) pl) - | C.AProd (id, n, s, t) -> C.AProd (id, n, iter_term k s, iter_term (succ k) t) - | C.ALambda (id, n, s, t) -> C.ALambda (id, n, iter_term k s, iter_term (succ k) t) - | C.ALetIn (id, n, ty, s, t) -> C.ALetIn (id, n, iter_term k ty, iter_term k s, iter_term (succ k) t) - | C.AFix (id, i, fl) -> C.AFix (id, i, List.map (iter_fix (List.length fl) k) fl) - | C.ACoFix (id, i, fl) -> C.ACoFix (id, i, List.map (iter_cofix (List.length fl) k) fl) - in - iter_term k - -let lift k n = - let f _ id rid m b = - if m + n > 0 then C.ARel (id, rid, m + n, b) else - begin - HLog.error (Printf.sprintf "ProceduralConversion.lift: %i %i" m n); - assert false - end - in - iter f k - -let subst k v = - let f k id rid m b = - if m = k then lift 1 (pred k) v else C.ARel (id, rid, pred m, b) - in - iter f k - -let fake_annotate id c = - let get_binder c m = - try match List.nth c (pred m) with - | Some (C.Name s, _) -> s - | _ -> assert false - with - | Invalid_argument _ -> assert false - in - let mk_decl n v = Some (n, C.Decl v) in - let mk_def n v ty = Some (n, C.Def (v, ty)) in - let mk_fix (name, _, ty, bo) = mk_def (C.Name name) bo ty in - let mk_cofix (name, ty, bo) = mk_def (C.Name name) bo ty in - let rec ann_xns c (uri, t) = uri, ann_term c t - and ann_ms c = function - | None -> None - | Some t -> Some (ann_term c t) - and ann_fix newc c (name, i, ty, bo) = - id, name, i, ann_term c ty, ann_term (List.rev_append newc c) bo - and ann_cofix newc c (name, ty, bo) = - id, name, ann_term c ty, ann_term (List.rev_append newc c) bo - and ann_term c = function - | C.Sort sort -> C.ASort (id, sort) - | C.Implicit ann -> C.AImplicit (id, ann) - | C.Rel m -> C.ARel (id, id, m, get_binder c m) - | C.Const (uri, xnss) -> C.AConst (id, uri, List.map (ann_xns c) xnss) - | C.Var (uri, xnss) -> C.AVar (id, uri, List.map (ann_xns c) xnss) - | C.MutInd (uri, tyno, xnss) -> C.AMutInd (id, uri, tyno, List.map (ann_xns c) xnss) - | C.MutConstruct (uri, tyno, consno, xnss) -> C.AMutConstruct (id, uri,tyno,consno, List.map (ann_xns c) xnss) - | C.Meta (i, mss) -> C.AMeta(id, i, List.map (ann_ms c) mss) - | C.Appl ts -> C.AAppl (id, List.map (ann_term c) ts) - | C.Cast (te, ty) -> C.ACast (id, ann_term c te, ann_term c ty) - | C.MutCase (sp, i, outty, t, pl) -> C.AMutCase (id, sp, i, ann_term c outty, ann_term c t, List.map (ann_term c) pl) - | C.Prod (n, s, t) -> C.AProd (id, n, ann_term c s, ann_term (mk_decl n s :: c) t) - | C.Lambda (n, s, t) -> C.ALambda (id, n, ann_term c s, ann_term (mk_decl n s :: c) t) - | C.LetIn (n, s, ty, t) -> C.ALetIn (id, n, ann_term c s, ann_term c ty, ann_term (mk_def n s ty :: c) t) - | C.Fix (i, fl) -> C.AFix (id, i, List.map (ann_fix (List.rev_map mk_fix fl) c) fl) - | C.CoFix (i, fl) -> C.ACoFix (id, i, List.map (ann_cofix (List.rev_map mk_cofix fl) c) fl) - in - ann_term c - -let mk_arel k = C.ARel ("", "", k, "") - -let mk_aappl ts = C.AAppl ("", ts) - -let rec clear_absts f n k = function - | t when n = 0 -> f k t - | C.ALambda (_, _, _, t) -> clear_absts f (pred n) (succ k) t - | t -> - let u = match mk_aappl [lift (succ k) 1 t; mk_arel (succ k)] with - | C.AAppl (_, [ C.AAppl (id, ts); t]) -> C.AAppl (id, ts @ [t]) - | t -> t - in - clear_absts f (pred n) (succ k) u - -let hole id = C.AImplicit (id, Some `Hole) - -let meta id = C.AImplicit (id, None) - -let anon = C.Anonymous - -let generalize n = - let is_meta = - let map b = function - | C.AImplicit (_, None) when b -> b - | _ -> false - in - List.fold_left map true - in - let rec gen_fix len k (id, name, i, ty, bo) = - id, name, i, gen_term k ty, gen_term (k + len) bo - and gen_cofix len k (id, name, ty, bo) = - id, name, gen_term k ty, gen_term (k + len) bo - and gen_term k = function - | C.ASort (id, _) - | C.AImplicit (id, _) - | C.AConst (id, _, _) - | C.AVar (id, _, _) - | C.AMutInd (id, _, _, _) - | C.AMutConstruct (id, _, _, _, _) - | C.AMeta (id, _, _) -> meta id - | C.ARel (id, _, m, _) -> - if succ (k - n) <= m && m <= k then hole id else meta id - | C.AAppl (id, ts) -> - let ts = List.map (gen_term k) ts in - if is_meta ts then meta id else C.AAppl (id, ts) - | C.ACast (id, te, ty) -> - let te, ty = gen_term k te, gen_term k ty in - if is_meta [te; ty] then meta id else C.ACast (id, te, ty) - | C.AMutCase (id, sp, i, outty, t, pl) -> - let outty, t, pl = gen_term k outty, gen_term k t, List.map (gen_term k) pl in - if is_meta (outty :: t :: pl) then meta id else hole id (* C.AMutCase (id, sp, i, outty, t, pl) *) - | C.AProd (id, _, s, t) -> - let s, t = gen_term k s, gen_term (succ k) t in - if is_meta [s; t] then meta id else C.AProd (id, anon, s, t) - | C.ALambda (id, _, s, t) -> - let s, t = gen_term k s, gen_term (succ k) t in - if is_meta [s; t] then meta id else C.ALambda (id, anon, s, t) - | C.ALetIn (id, _, s, ty, t) -> - let s, ty, t = gen_term k s, gen_term k ty, gen_term (succ k) t in - if is_meta [s; t] then meta id else C.ALetIn (id, anon, s, ty, t) - | C.AFix (id, i, fl) -> C.AFix (id, i, List.map (gen_fix (List.length fl) k) fl) - | C.ACoFix (id, i, fl) -> C.ACoFix (id, i, List.map (gen_cofix (List.length fl) k) fl) - in - gen_term - -let convert g ity k predicate = - let rec aux = function - | C.ALambda (_, _, b, ity), C.ALambda (id, n, u, pred) -> - C.ALambda (id, n, aux (b, u), aux (ity, pred)) - | C.AProd (_, _, b, ity), C.AProd (id, n, u, pred) -> - C.AProd (id, n, aux (b, u), aux (ity, pred)) - | C.ALetIn (_, _, a, b, ity), C.ALetIn (id, n, v, u, pred) -> - C.ALetIn (id, n, aux (a, v), aux (b, u), aux (ity, pred)) - | C.AAppl (_, bs), C.AAppl (id, us) when List.length bs = List.length us -> - let map b u = aux (b,u) in - C.AAppl (id, List.map2 map bs us) - | C.ACast (_, ity, b), C.ACast (id, pred, u) -> - C.ACast (id, aux (ity, pred), aux (b, u)) - | ity, C.AAppl (_, C.ALambda (_, _, _, pred) :: v :: []) -> - aux (ity, subst 1 v pred) - | ity, C.AAppl (id, C.ALambda (_, _, _, pred) :: v :: vs) -> - aux (ity, C.AAppl (id, subst 1 v pred :: vs)) - | _, pred -> pred - in - g k (aux (ity, predicate)) - -let mk_pattern psno ity predicate = - clear_absts (convert (generalize psno) ity) psno 0 predicate - -let beta v = function - | C.ALambda (_, _, _, t) -> subst 1 v t - | _ -> assert false - -let get_clears c p xtypes = - let meta = C.Implicit None in - let rec aux c names p it et = function - | [] -> - List.rev c, List.rev names - | Some (C.Name name as n, C.Decl v) as hd :: tl -> - let hd, names, v = - if DTI.does_not_occur 1 p && DTI.does_not_occur 1 it && DTI.does_not_occur 1 et then - Some (C.Anonymous, C.Decl v), name :: names, meta - else - hd, names, v - in - let p = C.Lambda (n, v, p) in - let it = C.Prod (n, v, it) in - let et = C.Prod (n, v, et) in - aux (hd :: c) names p it et tl - | Some (C.Name name as n, C.Def (v, x)) as hd :: tl -> - let hd, names, v = - if DTI.does_not_occur 1 p && DTI.does_not_occur 1 it && DTI.does_not_occur 1 et then - Some (C.Anonymous, C.Def (v, x)), name :: names, meta - else - hd, names, v - in - let p = C.LetIn (n, v, x, p) in - let it = C.LetIn (n, v, x, it) in - let et = C.LetIn (n, v, x, et) in - aux (hd :: c) names p it et tl - | Some (C.Anonymous as n, C.Decl v) as hd :: tl -> - let p = C.Lambda (n, meta, p) in - let it = C.Lambda (n, meta, it) in - let et = C.Lambda (n, meta, et) in - aux (hd :: c) names p it et tl - | Some (C.Anonymous as n, C.Def (v, _)) as hd :: tl -> - let p = C.LetIn (n, meta, meta, p) in - let it = C.LetIn (n, meta, meta, it) in - let et = C.LetIn (n, meta, meta, et) in - aux (hd :: c) names p it et tl - | None :: tl -> assert false - in - match xtypes with - | Some (it, et) -> aux [] [] p it et c - | None -> c, [] - -let clear c hyp = - let rec aux c = function - | [] -> List.rev c - | Some (C.Name name, entry) :: tail when name = hyp -> - aux (Some (C.Anonymous, entry) :: c) tail - | entry :: tail -> aux (entry :: c) tail - in - aux [] c -(* -let elim_inferred_type context goal arg using cpattern = - let metasenv, ugraph = [], Un.default_ugraph in - let ety = H.get_type "elim_inferred_type" context using in - let _splits, args_no = PEH.split_with_whd (context, ety) in - let _metasenv, _subst, predicate, _arg, actual_args = - PT.mk_predicate_for_elim - ~context ~metasenv ~subst:[] ~ugraph ~goal ~arg ~using ~cpattern ~args_no - in - let ty = C.Appl (predicate :: actual_args) in - let upto = List.length actual_args in - Rd.head_beta_reduce ~delta:false ~upto ty -*) -let does_not_occur = function - | C.AImplicit (_, None) -> true - | _ -> false diff --git a/matita/components/acic_procedural/proceduralConversion.mli b/matita/components/acic_procedural/proceduralConversion.mli deleted file mode 100644 index 418d911a9..000000000 --- a/matita/components/acic_procedural/proceduralConversion.mli +++ /dev/null @@ -1,47 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val meta: Cic.id -> Cic.annterm - -val hole: Cic.id -> Cic.annterm - -val lift: int -> int -> Cic.annterm -> Cic.annterm - -val fake_annotate: Cic.id -> Cic.context -> Cic.term -> Cic.annterm - -val mk_pattern: int -> Cic.annterm -> Cic.annterm -> Cic.annterm - -val beta: Cic.annterm -> Cic.annterm -> Cic.annterm - -val get_clears: - Cic.context -> Cic.term -> (Cic.term * Cic.term) option -> - Cic.context * string list - -val clear: Cic.context -> string -> Cic.context -(* -val elim_inferred_type: - Cic.context -> Cic.term -> Cic.term -> Cic.term -> Cic.term -> Cic.term -*) -val does_not_occur: Cic.annterm -> bool diff --git a/matita/components/acic_procedural/proceduralHelpers.ml b/matita/components/acic_procedural/proceduralHelpers.ml deleted file mode 100644 index 4305f9153..000000000 --- a/matita/components/acic_procedural/proceduralHelpers.ml +++ /dev/null @@ -1,387 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -module C = Cic -module Rf = CicRefine -module Un = CicUniv -module Pp = CicPp -module TC = CicTypeChecker -module PEH = ProofEngineHelpers -module E = CicEnvironment -module UM = UriManager -module D = Deannotate -module PER = ProofEngineReduction -module Ut = CicUtil -module DTI = DoubleTypeInference - -(* fresh name generator *****************************************************) - -let split name = - let rec aux i = - if i <= 0 then assert false else - let c = name.[pred i] in - if c >= '0' && c <= '9' then aux (pred i) - else Str.string_before name i, Str.string_after name i - in - let before, after = aux (String.length name) in - let i = if after = "" then -1 else int_of_string after in - before, i - -let join (s, i) = - C.Name (if i < 0 then s else s ^ string_of_int i) - -let mk_fresh_name context (name, k) = - let rec aux i = function - | [] -> name, i - | Some (C.Name s, _) :: entries -> - let m, j = split s in - if m = name && j >= i then aux (succ j) entries else aux i entries - | _ :: entries -> aux i entries - in - join (aux k context) - -let mk_fresh_name does_not_occur context = function - | C.Name s -> mk_fresh_name context (split s) - | C.Anonymous -> - if does_not_occur then C.Anonymous - else mk_fresh_name context (split "LOCAL") - -(* helper functions *********************************************************) - -let rec list_fold_right_cps g map l a = - match l with - | [] -> g a - | hd :: tl -> - let h a = map g hd a in - list_fold_right_cps h map tl a - -let rec list_fold_left_cps g map a = function - | [] -> g a - | hd :: tl -> - let h a = list_fold_left_cps g map a tl in - map h a hd - -let rec list_map_cps g map = function - | [] -> g [] - | hd :: tl -> - let h hd = - let g tl = g (hd :: tl) in - list_map_cps g map tl - in - map h hd - -let identity x = x - -let compose f g x = f (g x) - -let fst3 (x, _, _) = x - -let refine c t = - let error e = - Printf.eprintf "Ref: context: %s\n" (Pp.ppcontext c); - Printf.eprintf "Ref: term : %s\n" (Pp.ppterm t); - raise e - in - try let t, _, _, _ = Rf.type_of_aux' [] c t Un.default_ugraph in t with - | Rf.RefineFailure s as e -> - Printf.eprintf "REFINE FAILURE: %s\n" (Lazy.force s); - error e - | e -> - Printf.eprintf "REFINE ERROR: %s\n" (Printexc.to_string e); - error e - -let get_type msg c t = - let log s = - prerr_endline ("TC: " ^ s); - prerr_endline ("TC: context: " ^ Pp.ppcontext c); - prerr_string "TC: term : "; Ut.pp_term prerr_string [] c t; - prerr_newline (); prerr_endline ("TC: location: " ^ msg) - in - try let ty, _ = TC.type_of_aux' [] c t Un.default_ugraph in ty with - | TC.TypeCheckerFailure s as e -> - log ("failure: " ^ Lazy.force s); raise e - | TC.AssertFailure s as e -> - log ("assert : " ^ Lazy.force s); raise e - -let get_tail c t = - match PEH.split_with_whd (c, t) with - | (_, hd) :: _, _ -> hd - | _ -> assert false - -let is_prop c t = - match get_tail c (get_type "is_prop" c t) with - | C.Sort C.Prop -> true - | C.Sort _ -> false - | _ -> assert false - -let is_proof c t = - is_prop c (get_type "is_prop" c t) - -let is_sort = function - | C.Sort _ -> true - | _ -> false - -let is_unsafe h (c, t) = true - -let is_not_atomic = function - | C.Sort _ - | C.Rel _ - | C.Const _ - | C.Var _ - | C.MutInd _ - | C.MutConstruct _ -> false - | _ -> true - -let is_atomic t = not (is_not_atomic t) - -let get_ind_type uri tyno = - match E.get_obj Un.default_ugraph uri with - | C.InductiveDefinition (tys, _, lpsno, _), _ -> lpsno, List.nth tys tyno - | _ -> assert false - -let get_ind_names uri tno = -try - let ts = match E.get_obj Un.default_ugraph uri with - | C.InductiveDefinition (ts, _, _, _), _ -> ts - | _ -> assert false - in - match List.nth ts tno with - | (_, _, _, cs) -> List.map fst cs -with Invalid_argument _ -> failwith "get_ind_names" - -let get_default_eliminator context uri tyno ty = - let _, (name, _, _, _) = get_ind_type uri tyno in - let ext = match get_tail context (get_type "get_def_elim" context ty) with - | C.Sort C.Prop -> "_ind" - | C.Sort C.Set -> "_rec" - | C.Sort (C.CProp _) -> "_rect" - | C.Sort (C.Type _) -> "_rect" - | t -> - Printf.eprintf "CicPPP get_default_eliminator: %s\n" (Pp.ppterm t); - assert false - in - let buri = UM.buri_of_uri uri in - let uri = UM.uri_of_string (buri ^ "/" ^ name ^ ext ^ ".con") in - C.Const (uri, []) - -let get_ind_parameters c t = - let ty = get_type "get_ind_pars 1" c t in - let ps = match get_tail c ty with - | C.MutInd _ -> [] - | C.Appl (C.MutInd _ :: args) -> args - | _ -> assert false - in - let disp = match get_tail c (get_type "get_ind_pars 2" c ty) with - | C.Sort C.Prop -> 0 - | C.Sort _ -> 1 - | _ -> assert false - in - ps, disp - -let cic = D.deannotate_term - -let flatten_appls = - let rec flatten_xns (uri, t) = uri, flatten_term t - and flatten_ms = function - | None -> None - | Some t -> Some (flatten_term t) - and flatten_fix (name, i, ty, bo) = - name, i, flatten_term ty, flatten_term bo - and flatten_cofix (name, ty, bo) = - name, flatten_term ty, flatten_term bo - and flatten_term = function - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Rel _ as t -> t - | C.Const (uri, xnss) -> C.Const (uri, List.map flatten_xns xnss) - | C.Var (uri, xnss) -> C.Var (uri, List.map flatten_xns xnss) - | C.MutInd (uri, tyno, xnss) -> C.MutInd (uri, tyno, List.map flatten_xns xnss) - | C.MutConstruct (uri, tyno, consno, xnss) -> C.MutConstruct (uri, tyno, consno, List.map flatten_xns xnss) - | C.Meta (i, mss) -> C.Meta(i, List.map flatten_ms mss) -(* begin flattening *) - | C.Appl [t] -> flatten_term t - | C.Appl (C.Appl ts1 :: ts2) -> flatten_term (C.Appl (ts1 @ ts2)) - | C.Appl [] -> assert false -(* end flattening *) - | C.Appl ts -> C.Appl (List.map flatten_term ts) - | C.Cast (te, ty) -> C.Cast (flatten_term te, flatten_term ty) - | C.MutCase (sp, i, outty, t, pl) -> C.MutCase (sp, i, flatten_term outty, flatten_term t, List.map flatten_term pl) - | C.Prod (n, s, t) -> C.Prod (n, flatten_term s, flatten_term t) - | C.Lambda (n, s, t) -> C.Lambda (n, flatten_term s, flatten_term t) - | C.LetIn (n, ty, s, t) -> C.LetIn (n, flatten_term ty, flatten_term s, flatten_term t) - | C.Fix (i, fl) -> C.Fix (i, List.map flatten_fix fl) - | C.CoFix (i, fl) -> C.CoFix (i, List.map flatten_cofix fl) - in - flatten_term - -let sober ?(flatten=false) c t = - if flatten then flatten_appls t else (assert (Ut.is_sober c t); t) - -let alpha ?flatten c t1 t2 = - let t1 = sober ?flatten c t1 in - let t2 = sober ?flatten c t2 in - Ut.alpha_equivalence t1 t2 - -let occurs c ~what ~where = - let result = ref false in - let equality c t1 t2 = - let r = alpha ~flatten:true c t1 t2 in - result := !result || r; r - in - let context, what, with_what = c, [what], [C.Rel 0] in - let _ = PER.replace_lifting ~equality ~context ~what ~with_what ~where in - !result - -let name_of_uri uri tyno cno = - let get_ind_type tys tyno = - let s, _, _, cs = List.nth tys tyno in s, cs - in - match (fst (E.get_obj Un.default_ugraph uri)), tyno, cno with - | C.Variable (s, _, _, _, _), _, _ -> s - | C.Constant (s, _, _, _, _), _, _ -> s - | C.InductiveDefinition (tys, _, _, _), Some i, None -> - let s, _ = get_ind_type tys i in s - | C.InductiveDefinition (tys, _, _, _), Some i, Some j -> - let _, cs = get_ind_type tys i in - let s, _ = List.nth cs (pred j) in s - | _ -> assert false - -(* Ensuring Barendregt convenction ******************************************) - -let rec add_entries map c = function - | [] -> c - | hd :: tl -> - let sname, w = map hd in - let entry = Some (C.Name sname, C.Decl w) in - add_entries map (entry :: c) tl - -let get_sname c i = - try match List.nth c (pred i) with - | Some (C.Name sname, _) -> sname - | _ -> assert false - with - | Failure _ -> assert false - | Invalid_argument _ -> assert false - -let cic_bc c t = - let get_fix_decl (sname, i, w, v) = sname, w in - let get_cofix_decl (sname, w, v) = sname, w in - let rec bc c = function - | C.LetIn (name, v, ty, t) -> - let dno = DTI.does_not_occur 1 t in - let name = mk_fresh_name dno c name in - let entry = Some (name, C.Def (v, ty)) in - let v, ty, t = bc c v, bc c ty, bc (entry :: c) t in - C.LetIn (name, v, ty, t) - | C.Lambda (name, w, t) -> - let dno = DTI.does_not_occur 1 t in - let name = mk_fresh_name dno c name in - let entry = Some (name, C.Decl w) in - let w, t = bc c w, bc (entry :: c) t in - C.Lambda (name, w, t) - | C.Prod (name, w, t) -> - let dno = DTI.does_not_occur 1 t in - let name = mk_fresh_name dno c name in - let entry = Some (name, C.Decl w) in - let w, t = bc c w, bc (entry :: c) t in - C.Prod (name, w, t) - | C.Appl vs -> - let vs = List.map (bc c) vs in - C.Appl vs - | C.MutCase (uri, tyno, u, v, ts) -> - let u, v, ts = bc c u, bc c v, List.map (bc c) ts in - C.MutCase (uri, tyno, u, v, ts) - | C.Cast (t, u) -> - let t, u = bc c t, bc c u in - C.Cast (t, u) - | C.Fix (i, fixes) -> - let d = add_entries get_fix_decl c fixes in - let bc_fix (sname, i, w, v) = (sname, i, bc c w, bc d v) in - let fixes = List.map bc_fix fixes in - C.Fix (i, fixes) - | C.CoFix (i, cofixes) -> - let d = add_entries get_cofix_decl c cofixes in - let bc_cofix (sname, w, v) = (sname, bc c w, bc d v) in - let cofixes = List.map bc_cofix cofixes in - C.CoFix (i, cofixes) - | t -> t - in - bc c t - -let acic_bc c t = - let get_fix_decl (id, sname, i, w, v) = sname, cic w in - let get_cofix_decl (id, sname, w, v) = sname, cic w in - let rec bc c = function - | C.ALetIn (id, name, v, ty, t) -> - let dno = DTI.does_not_occur 1 (cic t) in - let name = mk_fresh_name dno c name in - let entry = Some (name, C.Def (cic v, cic ty)) in - let v, ty, t = bc c v, bc c ty, bc (entry :: c) t in - C.ALetIn (id, name, v, ty, t) - | C.ALambda (id, name, w, t) -> - let dno = DTI.does_not_occur 1 (cic t) in - let name = mk_fresh_name dno c name in - let entry = Some (name, C.Decl (cic w)) in - let w, t = bc c w, bc (entry :: c) t in - C.ALambda (id, name, w, t) - | C.AProd (id, name, w, t) -> - let dno = DTI.does_not_occur 1 (cic t) in - let name = mk_fresh_name dno c name in - let entry = Some (name, C.Decl (cic w)) in - let w, t = bc c w, bc (entry :: c) t in - C.AProd (id, name, w, t) - | C.AAppl (id, vs) -> - let vs = List.map (bc c) vs in - C.AAppl (id, vs) - | C.AMutCase (id, uri, tyno, u, v, ts) -> - let u, v, ts = bc c u, bc c v, List.map (bc c) ts in - C.AMutCase (id, uri, tyno, u, v, ts) - | C.ACast (id, t, u) -> - let t, u = bc c t, bc c u in - C.ACast (id, t, u) - | C.AFix (id, i, fixes) -> - let d = add_entries get_fix_decl c fixes in - let bc_fix (id, sname, i, w, v) = (id, sname, i, bc c w, bc d v) in - let fixes = List.map bc_fix fixes in - C.AFix (id, i, fixes) - | C.ACoFix (id, i, cofixes) -> - let d = add_entries get_cofix_decl c cofixes in - let bc_cofix (id, sname, w, v) = (id, sname, bc c w, bc d v) in - let cofixes = List.map bc_cofix cofixes in - C.ACoFix (id, i, cofixes) - | C.ARel (id1, id2, i, sname) -> - let sname = get_sname c i in - C.ARel (id1, id2, i, sname) - | t -> t - in - bc c t - -let is_acic_proof sorts context v = - let id = Ut.id_of_annterm v in - try match Hashtbl.find sorts id with - | `Prop -> true - | _ -> false - with Not_found -> is_proof context (cic v) - diff --git a/matita/components/acic_procedural/proceduralHelpers.mli b/matita/components/acic_procedural/proceduralHelpers.mli deleted file mode 100644 index c021c7c69..000000000 --- a/matita/components/acic_procedural/proceduralHelpers.mli +++ /dev/null @@ -1,103 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val mk_fresh_name: - bool -> Cic.context -> Cic.name -> Cic.name - -val list_fold_right_cps: - ('b -> 'c) -> (('b -> 'c) -> 'a -> 'b -> 'c) -> 'a list -> 'b -> 'c - -val list_fold_left_cps: - ('b -> 'c) -> (('b -> 'c) -> 'b -> 'a -> 'c) -> 'b -> 'a list -> 'c - -val list_map_cps: - ('b list -> 'c) -> (('b -> 'c) -> 'a -> 'c) -> 'a list -> 'c - -val identity: - 'a -> 'a - -val compose: - ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b - -val fst3: - 'a * 'b * 'c -> 'a - -val refine: - Cic.context -> Cic.term -> Cic.term - -val get_type: - string -> Cic.context -> Cic.term -> Cic.term - -val is_prop: - Cic.context -> Cic.term -> bool - -val is_proof: - Cic.context -> Cic.term -> bool - -val is_sort: - Cic.term -> bool - -val is_unsafe: - int -> Cic.context * Cic.term -> bool - -val is_not_atomic: - Cic.term -> bool - -val is_atomic: - Cic.term -> bool - -val get_ind_type: - UriManager.uri -> int -> int * Cic.inductiveType - -val get_ind_names: - UriManager.uri -> int -> string list - -val get_default_eliminator: - Cic.context -> UriManager.uri -> int -> Cic.term -> Cic.term - -val get_ind_parameters: - Cic.context -> Cic.term -> Cic.term list * int - -val cic: - Cic.annterm -> Cic.term - -val occurs: - Cic.context -> what:Cic.term -> where:Cic.term -> bool - -val name_of_uri: - UriManager.uri -> int option -> int option -> string - -val cic_bc: - Cic.context -> Cic.term -> Cic.term - -val acic_bc: - Cic.context -> Cic.annterm -> Cic.annterm - -val is_acic_proof: - (Cic.id, Cic2acic.sort_kind) Hashtbl.t -> Cic.context -> Cic.annterm -> - bool - -val alpha: - ?flatten:bool -> Cic.context -> Cic.term -> Cic.term -> bool diff --git a/matita/components/acic_procedural/proceduralMode.ml b/matita/components/acic_procedural/proceduralMode.ml deleted file mode 100644 index e13846fc8..000000000 --- a/matita/components/acic_procedural/proceduralMode.ml +++ /dev/null @@ -1,57 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -module C = Cic -module PEH = ProofEngineHelpers - -module Cl = ProceduralClassify - -let is_eliminator = function - | _ :: (_, C.MutInd _) :: _ -> true - | _ :: (_, C.Appl (C.MutInd _ :: _)) :: _ -> true - | _ -> false - -let is_const = function - | C.Sort _ - | C.Const _ - | C.Var _ - | C.MutInd _ - | C.MutConstruct _ -> true - | _ -> false - -let rec is_appl b = function - | C.Appl (hd :: tl) -> List.fold_left is_appl (is_const hd) tl - | t when is_const t -> b - | C.Rel _ -> b - | _ -> false - -let bkd c t = - let classes, rc = Cl.classify c t in - let premises, _ = PEH.split_with_whd (c, t) in - match rc with - | Some (i, j, _, _) when i > 1 && i <= List.length classes && is_eliminator premises -> true - | _ -> - let _, conclusion = List.hd premises in - is_appl true conclusion diff --git a/matita/components/acic_procedural/proceduralMode.mli b/matita/components/acic_procedural/proceduralMode.mli deleted file mode 100644 index 71356b6ff..000000000 --- a/matita/components/acic_procedural/proceduralMode.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) -(* -val is_eliminator: (Cic.context * Cic.term) list -> bool - -val bkd: Cic.context -> Cic.term -> bool -*) diff --git a/matita/components/acic_procedural/proceduralOptimizer.ml b/matita/components/acic_procedural/proceduralOptimizer.ml deleted file mode 100644 index c5a27efc4..000000000 --- a/matita/components/acic_procedural/proceduralOptimizer.ml +++ /dev/null @@ -1,301 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -module UM = UriManager -module C = Cic -module Pp = CicPp -module I = CicInspect -module E = CicEnvironment -module S = CicSubstitution -module DTI = DoubleTypeInference -module HEL = HExtlib -module PEH = ProofEngineHelpers -module TC = CicTypeChecker -module Un = CicUniv -module L = Librarian -module Ut = CicUtil - -module H = ProceduralHelpers -module Cl = ProceduralClassify - -(* debugging ****************************************************************) - -let debug = ref false - -(* term optimization ********************************************************) - -let critical = ref true - -type status = { - dummy: unit; - info: string -} - -let info st str = {st with info = st.info ^ str ^ "\n"} - -let defined_premise = "LOCAL" - -let define c v = - let name = C.Name defined_premise in - let ty = H.get_type "define" c v in - C.LetIn (name, v, ty, C.Rel 1) - -let clear_absts m = - let rec aux k n = function - | C.Lambda (s, v, t) when k > 0 -> - C.Lambda (s, v, aux (pred k) n t) - | C.Lambda (_, _, t) when n > 0 -> - aux 0 (pred n) (S.lift (-1) t) - | t when n > 0 -> - Printf.eprintf "PO.clear_absts: %u %s\n" n (Pp.ppterm t); - assert false - | t -> t - in - aux m - -let rec add_abst k = function - | C.Lambda (s, v, t) when k > 0 -> C.Lambda (s, v, add_abst (pred k) t) - | t when k > 0 -> assert false - | t -> C.Lambda (C.Anonymous, C.Implicit None, S.lift 1 t) - -let rec opt_letin g st es c name v w t = - let name = H.mk_fresh_name true c name in - let entry = Some (name, C.Def (v, w)) in - let g st t = - if DTI.does_not_occur 1 t then - let x = S.lift (-1) t in - opt_proof g (info st "Optimizer: remove 1") true c x - else - let g st = function - | C.LetIn (nname, vv, ww, tt) when H.is_proof c v -> - let eentry = Some (nname, C.Def (vv, ww)) in - let ttw = H.get_type "opt_letin 1" (eentry :: c) tt in - let x = C.LetIn (nname, vv, ww, - C.LetIn (name, tt, ttw, S.lift_from 2 1 t)) - in - opt_proof g (info st "Optimizer: swap 1") true c x - | v when H.is_proof c v && H.is_atomic v -> - let x = S.subst v t in - opt_proof g (info st "Optimizer: remove 5") true c x -(* | v when t = C.Rel 1 -> - g (info st "Optimizer: remove 6") v -*) | v -> - g st (C.LetIn (name, v, w, t)) - in - if es then opt_term g st es c v else g st v - in - if es then opt_proof g st es (entry :: c) t else g st t - -and opt_lambda g st es c name w t = - let name = H.mk_fresh_name true c name in - let entry = Some (name, C.Decl w) in - let g st t = g st (C.Lambda (name, w, t)) in - if es then opt_proof g st es (entry :: c) t else g st t - -and opt_appl g st es c t vs = - let g (st, vs) = - let g st = function - | C.LetIn (mame, vv, tyty, tt) -> - let vs = List.map (S.lift 1) vs in - let x = C.LetIn (mame, vv, tyty, C.Appl (tt :: vs)) in - opt_proof g (info st "Optimizer: swap 2") true c x - | C.Lambda (name, ww, tt) -> - let v, vs = List.hd vs, List.tl vs in - let w = H.get_type "opt_appl 1" c v in - let x = C.Appl (C.LetIn (name, v, w, tt) :: vs) in - opt_proof g (info st "Optimizer: remove 2") true c x - | C.Appl vvs -> - let x = C.Appl (vvs @ vs) in - opt_proof g (info st "Optimizer: nested application") true c x - | t -> -(* - let rec aux st d rvs = function - | [], _ -> - let x = C.Appl (t :: List.rev rvs) in - if d then opt_proof g st true c x else g st x - | v :: vs, (cc, bb) :: cs -> - if H.is_not_atomic v && I.S.mem 0 cc && bb then - aux (st info "Optimizer: anticipate 1") true - (define c v :: rvs) (vs, cs) - else - aux st d (v :: rvs) (vs, cs) - | _, [] -> assert false - in -*) - let h st = - let classes, conclusion = Cl.classify c (H.get_type "opt_appl 3" c t) in - let csno, vsno = List.length classes, List.length vs in - if csno < vsno then - let vvs, vs = HEL.split_nth csno vs in - let x = C.Appl (define c (C.Appl (t :: vvs)) :: vs) in - opt_proof g (info st "Optimizer: anticipate 2") true c x - else match conclusion, List.rev vs with - | Some _, rv :: rvs when csno = vsno && H.is_not_atomic rv -> - let x = C.Appl (t :: List.rev rvs @ [define c rv]) in - opt_proof g (info st "Optimizer: anticipate 3";) true c x - | _ (* Some _, _ *) -> - g st (C.Appl (t :: vs)) -(* | None, _ -> - aux false [] (vs, classes) -*) in - let rec aux h st prev = function - | C.LetIn (name, vv, tyty, tt) :: vs -> - let t = S.lift 1 t in - let prev = List.map (S.lift 1) prev in - let vs = List.map (S.lift 1) vs in - let y = C.Appl (t :: List.rev prev @ tt :: vs) in - let ww = H.get_type "opt_appl 2" c vv in - let x = C.LetIn (name, vv, ww, y) in - opt_proof g (info st "Optimizer: swap 3") true c x - | v :: vs -> aux h st (v :: prev) vs - | [] -> h st - in - aux h st [] vs - in - if es then opt_proof g st es c t else g st t - in - let map h v (st, vs) = - let h st vv = h (st, vv :: vs) in opt_term h st es c v - in - if es then H.list_fold_right_cps g map vs (st, []) else g (st, vs) - -and opt_mutcase_critical g st es c uri tyno outty arg cases = - let eliminator = H.get_default_eliminator c uri tyno outty in - let lpsno, (_, _, _, constructors) = H.get_ind_type uri tyno in - let ps, sort_disp = H.get_ind_parameters c arg in - let lps, rps = HEL.split_nth lpsno ps in - let rpsno = List.length rps in - if rpsno = 0 && sort_disp = 0 then -(* FG: the transformation is not possible, we fall back into the plain case *) - opt_mutcase_plain g st es c uri tyno outty arg cases - else - let predicate = clear_absts rpsno (1 - sort_disp) outty in - if H.occurs c ~what:(C.Rel 0) ~where:predicate then -(* FG: the transformation is not possible, we fall back into the plain case *) - opt_mutcase_plain g st es c uri tyno outty arg cases - else - let is_recursive t = - I.S.mem tyno (I.get_mutinds_of_uri uri t) - in - let map2 case (_, cty) = - let map (h, case, k) (_, premise) = - if h > 0 then pred h, case, k else - if is_recursive premise then - 0, add_abst k case, k + 2 - else - 0, case, succ k - in - let premises, _ = PEH.split_with_whd (c, cty) in - let _, lifted_case, _ = - List.fold_left map (lpsno, case, 1) (List.rev (List.tl premises)) - in - lifted_case - in - let lifted_cases = List.map2 map2 cases constructors in - let args = eliminator :: lps @ predicate :: lifted_cases @ rps @ [arg] in - try - let x = H.refine c (C.Appl args) in - opt_proof g (info st "Optimizer: remove 3") es c x - with e -> -(* FG: the transformation is not possible, we fall back into the plain case *) - let st = info st ("Optimizer: refine_error: " ^ Printexc.to_string e) in - opt_mutcase_plain g st es c uri tyno outty arg cases - -and opt_mutcase_plain g st es c uri tyno outty arg cases = - let g st v = - let g (st, ts) = g st (C.MutCase (uri, tyno, outty, v, ts)) in - let map h v (st, vs) = - let h st vv = h (st, vv :: vs) in opt_proof h st es c v - in - if es then H.list_fold_right_cps g map cases (st, []) else g (st, cases) - in - if es then opt_proof g st es c arg else g st arg - -and opt_mutcase g = - if !critical then opt_mutcase_critical g else opt_mutcase_plain g - -and opt_cast g st es c t w = - let g st t = g (info st "Optimizer: remove 4") t in - if es then opt_proof g st es c t else g st t - -and opt_other g st es c t = g st t - -and opt_proof g st es c = function - | C.LetIn (name, v, ty, t) -> opt_letin g st es c name v ty t - | C.Lambda (name, w, t) -> opt_lambda g st es c name w t - | C.Appl (t :: v :: vs) -> opt_appl g st es c t (v :: vs) - | C.Appl [t] -> opt_proof g st es c t - | C.MutCase (u, n, t, v, ws) -> opt_mutcase g st es c u n t v ws - | C.Cast (t, w) -> opt_cast g st es c t w - | t -> opt_other g st es c t - -and opt_term g st es c t = - if H.is_proof c t then opt_proof g st es c t else g st t - -(* object optimization ******************************************************) - -let wrap g st c bo = - try opt_term g st true c bo - with - | E.Object_not_found uri -> - let msg = "optimize_obj: object not found: " ^ UM.string_of_uri uri in - failwith msg - | e -> - let msg = "optimize_obj: " ^ Printexc.to_string e in - failwith msg - -let optimize_obj = function - | C.Constant (name, Some bo, ty, pars, attrs) -> - let count_nodes = I.count_nodes ~meta:false 0 in - let st, c = {info = ""; dummy = ()}, [] in - L.time_stamp ("PO: OPTIMIZING " ^ name); - let nodes = Printf.sprintf "Initial nodes: %u" (count_nodes bo) in - if !debug then begin - Printf.eprintf "BEGIN: %s\n" name; - Printf.eprintf "Initial : %s\n" (Pp.ppterm bo); - prerr_string "Ut.pp_term : "; - Ut.pp_term prerr_string [] c bo; prerr_newline () - end; - let bo, ty = H.cic_bc c bo, H.cic_bc c ty in - let g st bo = - if !debug then begin - Printf.eprintf "Optimized : %s\n" (Pp.ppterm bo); - prerr_string "Ut.pp_term : "; - Ut.pp_term prerr_string [] c bo; prerr_newline () - end; -(* let _ = H.get_type "opt" [] (C.Cast (bo, ty)) in *) - let nodes = Printf.sprintf "Optimized nodes: %u" (count_nodes bo) in - let st = info st nodes in - L.time_stamp ("PO: DONE " ^ name); - C.Constant (name, Some bo, ty, pars, attrs), st.info - in - wrap g (info st nodes) c bo - | obj -> obj, "" - -let optimize_term c bo = - let st = {info = ""; dummy = ()} in - let bo = H.cic_bc c bo in - let g st bo = bo, st.info in - wrap g st c bo diff --git a/matita/components/acic_procedural/proceduralOptimizer.mli b/matita/components/acic_procedural/proceduralOptimizer.mli deleted file mode 100644 index 522860df3..000000000 --- a/matita/components/acic_procedural/proceduralOptimizer.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val optimize_obj: Cic.obj -> Cic.obj * string - -val optimize_term: Cic.context -> Cic.term -> Cic.term * string - -val critical: bool ref - -val debug: bool ref diff --git a/matita/components/acic_procedural/proceduralTeX.ml b/matita/components/acic_procedural/proceduralTeX.ml deleted file mode 100644 index 294fefb04..000000000 --- a/matita/components/acic_procedural/proceduralTeX.ml +++ /dev/null @@ -1,253 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -module F = Format -module C = Cic -module DTI = DoubleTypeInference -module H = ProceduralHelpers -module T = ProceduralTypes - -type sorts = (Cic.id, Cic2acic.sort_kind) Hashtbl.t - -let num n = - if n < 2 then "" else - if n < 27 then String.make 1 (Char.chr (n - 2 + Char.code 'b')) else - assert false - -let quote str = - Pcre.replace ~pat:"_" ~templ:"\\_" str - -let xn frm = function - | C.Anonymous -> assert false - | C.Name r -> F.fprintf frm "%s" (quote r) - -let xr c frm j = - try match List.nth c (pred j) with - | Some (r, _) -> xn frm r - | None -> assert false - with Invalid_argument "nth" -> assert false - -let xs frm = function - | C.Set -> F.fprintf frm "\\Set" - | C.Prop -> F.fprintf frm "\\Prop" - | C.CProp _ -> F.fprintf frm "\\CProp" - | C.Type _ -> F.fprintf frm "\\Type" - -let rec xt c frm = function - | C.Sort s -> - xs frm s - | C.Const (i, []) -> - F.fprintf frm "\\GRef{%s}" (quote (H.name_of_uri i None None)) - | C.MutInd (i, n, []) -> - F.fprintf frm "\\GRef{%s}" (quote (H.name_of_uri i (Some n) None)) - | C.MutConstruct (i, n, m, []) -> - F.fprintf frm "\\GRef{%s}" (quote (H.name_of_uri i (Some n) (Some m))) - | C.Rel j -> - F.fprintf frm "\\LRef{%a}" (xr c) j - | C.Cast (t, u) -> - F.fprintf frm "\\Cast{%a}{%a}" (xt c) u (xt c) t - | C.Appl (t :: vs) -> - let z = num (List.length vs) in - F.fprintf frm "\\%sAppl%a{%a}" z (xts c) vs (xt c) t - | C.MutCase (_, _, u, v, ts) -> - let z = num (List.length ts) in - F.fprintf frm "\\%sCase{%a}{%a}%a" z (xt c) u (xt c) v (xts c) ts - | C.LetIn (r, v, w, t) -> - let d = Some (r, C.Def (v, w)) :: c in - F.fprintf frm "\\Abbr{%a}{%a}{%a}" xn r (xt c) v (xt d) t - | C.Lambda (r, w, t) -> - let d = Some (r, C.Decl w) :: c in - if DTI.does_not_occur 1 t then - F.fprintf frm "\\CFun{%a}{%a}" (xt c) w (xt d) t - else - F.fprintf frm "\\Abst{%a}{%a}{%a}" xn r (xt c) w (xt d) t - | C.Prod (r, w, t) -> - let d = Some (r, C.Decl w) :: c in - if DTI.does_not_occur 1 t then - F.fprintf frm "\\LImp{%a}{%a}" (xt c) w (xt d) t - else if H.is_prop d t then - F.fprintf frm "\\LAll{%a}{%a}{%a}" xn r (xt c) w (xt d) t - else - F.fprintf frm "\\Prod{%a}{%a}{%a}" xn r (xt c) w (xt d) t - | C.Const _ -> assert false - | C.MutInd _ -> assert false - | C.MutConstruct _ -> assert false - | C.Var _ -> assert false - | C.Fix _ -> assert false - | C.CoFix _ -> assert false - | C.Meta _ -> assert false - | C.Implicit _ -> assert false - | C.Appl [] -> assert false - -and xts c frm vs = - let map v = F.fprintf frm "{%a}" (xt c) v in - List.iter map vs - -let tex_of_term frm c t = xt c frm t - -let tex_of_obj frm = function - | C.InductiveDefinition (_, [], _, _) -> () - | C.Constant (_, None, _, [], _) -> () - | C.Constant (_, Some t, _, [], _) -> - F.fprintf frm "%a@\n" (xt []) t - | C.Constant _ -> assert false - | C.InductiveDefinition _ -> assert false - | C.Variable _ -> assert false - | C.CurrentProof _ -> assert false - -let is_prop sorts id = - try match Hashtbl.find sorts id with - | `Prop -> true - | _ -> false - with Not_found -> false - -let tex_of_annterm frm sorts t = - -let rec xat frm = function - | C.ASort (_, s) -> - xs frm s - | C.AConst (_ ,i, []) -> - F.fprintf frm "\\GRef{%s}" (quote (H.name_of_uri i None None)) - | C.AMutInd (_, i, n, []) -> - F.fprintf frm "\\GRef{%s}" (quote (H.name_of_uri i (Some n) None)) - | C.AMutConstruct (_, i, n, m, []) -> - F.fprintf frm "\\GRef{%s}" (quote (H.name_of_uri i (Some n) (Some m))) - | C.ARel (_,_, _, r) -> - F.fprintf frm "\\LRef{%s}" (quote r) - | C.ACast (_, t, u) -> - F.fprintf frm "\\Cast{%a}{%a}" xat u xat t - | C.AAppl (_, t :: vs) -> - let z = num (List.length vs) in - F.fprintf frm "\\%sAppl%a{%a}" z xats vs xat t - | C.AMutCase (_, _, _, u, v, ts) -> - let z = num (List.length ts) in - F.fprintf frm "\\%sCase{%a}{%a}%a" z xat u xat v xats ts - | C.ALetIn (_, r, v, w, t) -> - F.fprintf frm "\\Abbr{%a}{%a}{%a}" xn r xat v xat t - | C.ALambda (_, r, w, t) -> - if DTI.does_not_occur 1 (H.cic t) then - F.fprintf frm "\\CFun{%a}{%a}" xat w xat t - else - F.fprintf frm "\\Abst{%a}{%a}{%a}" xn r xat w xat t - | C.AProd (id, r, w, t) -> - if DTI.does_not_occur 1 (H.cic t) then - F.fprintf frm "\\LImp{%a}{%a}" xat w xat t - else if true then - F.fprintf frm "\\LAll{%a}{%a}{%a}" xn r xat w xat t - else - F.fprintf frm "\\Prod{%a}{%a}{%a}" xn r xat w xat t - | C.AConst _ -> assert false - | C.AMutInd _ -> assert false - | C.AMutConstruct _ -> assert false - | C.AVar _ -> assert false - | C.AFix _ -> assert false - | C.ACoFix _ -> assert false - | C.AMeta _ -> assert false - | C.AImplicit _ -> assert false - | C.AAppl (_, []) -> assert false - -and xats frm = function - | [] -> F.fprintf frm "{}" - | vs -> - let map v = F.fprintf frm "{%a}" xat v in - List.iter map vs - -in -xat frm t - -let xx frm = function - | None -> assert false - | Some r -> F.fprintf frm "%s" (quote r) - -let xh how = - if how then "\\dx" else "\\sx" - -let tex_of_steps frm sorts l = - -let xat frm t = tex_of_annterm frm sorts t in - -let rec xl frm = function - | [] -> () - | T.Note _ :: l - | T.Statement _ :: l - | T.Qed _ :: l -> - xl frm l - | T.Reflexivity _ :: l -> - F.fprintf frm "\\Reflexivity"; xl frm l - | T.Exact (t, _) :: l -> - F.fprintf frm "\\Exact{%a}" xat t; xl frm l - | T.Intros (_, [r], _) :: l -> - F.fprintf frm "\\Intro{%a}{%a}" xx r xl l - | T.LetIn (r, v, _) :: l -> - F.fprintf frm "\\Pose{%a}{%a}{%a}" xx r xat v xl l - | T.LApply (r, v, _) :: l -> - F.fprintf frm "\\LApply{%a}{%a}{%a}" xx r xat v xl l - | T.Change (u, _, None, _, _) :: l -> - F.fprintf frm "\\Change{%a}{}{%a}" xat u xl l - | T.Change (u, _, Some (s, _), _, _) :: l -> - F.fprintf frm "\\Change{%a}{%s}{%a}" xat u (quote s) xl l - | T.Rewrite (b, t, None, _, _) :: l -> - F.fprintf frm "\\Rewrite{%s}{%a}{}{}{%a}" (xh b) xat t xl l - | T.Rewrite (b, t, Some (s1, Some s2), _, _) :: l -> - F.fprintf frm "\\Rewrite{%s}{%a}{%s}{%s}{%a}" - (xh b) xat t (quote s1) (quote s2) xl l - | T.Rewrite (b, t, Some (s1, None), _, _) :: l -> - F.fprintf frm "\\Rewrite{%s}{%a}{%s}{%s}{%a}" - (xh b) xat t (quote s1) (quote s1) xl l - | T.Apply (t, _) :: T.Branch (ls, _) :: l -> - let z = num (List.length ls) in - F.fprintf frm "\\%sApply{%a}%a" z xat t xls ls; xl frm l - | T.Apply (t, _) :: l -> - F.fprintf frm "\\Apply{%a}{%a}" xat t xl l - | T.Cases (v, _, _) :: T.Branch (ls, _) :: l -> - let z = num (List.length ls) in - F.fprintf frm "\\%sCases{%a}%a" z xat v xls ls; xl frm l - | T.Cases (v, _, _) :: l -> - F.fprintf frm "\\Cases{%a}{%a}" xat v xl l - | T.Elim (v, Some t, _, _) :: T.Branch (ls, _) :: l -> - let z = num (List.length ls) in - F.fprintf frm "\\%sElim{%a}{%a}{}{}%a" z xat v xat t xls ls; xl frm l - | T.Elim (v, Some t, _, _) :: l -> - F.fprintf frm "\\Elim{%a}{%a}{}{}{%a}" xat v xat t xl l - | T.Cut (r, w, _) :: T.Branch ([l1; [T.Id _]], _) :: l2 -> - F.fprintf frm "\\Cut{%a}{%a}{%a}{%a}" xx r xat w xl l1 xl l2 - | T.Record _ :: _ -> assert false - | T.Inductive _ :: _ -> assert false - | T.Id _ :: _ -> assert false - | T.Clear _ :: _ -> assert false - | T.ClearBody _ :: _ -> assert false - | T.Branch _ :: _ -> assert false - | T.Intros _ :: _ -> assert false - | T.Elim _ :: _ -> assert false - | T.Cut _ :: _ -> assert false - -and xls frm = function - | [] -> F.fprintf frm "{}" - | ls -> - let map l = F.fprintf frm "{%a}" xl l in - List.iter map (List.rev ls) - -in -F.fprintf frm "%a@\n" xl l diff --git a/matita/components/acic_procedural/proceduralTeX.mli b/matita/components/acic_procedural/proceduralTeX.mli deleted file mode 100644 index 096a49f7f..000000000 --- a/matita/components/acic_procedural/proceduralTeX.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type sorts = (Cic.id, Cic2acic.sort_kind) Hashtbl.t - -val tex_of_term: Format.formatter -> Cic.context -> Cic.term -> unit - -val tex_of_obj: Format.formatter -> Cic.obj -> unit - -val tex_of_annterm: Format.formatter -> sorts -> Cic.annterm -> unit - -val tex_of_steps: - Format.formatter -> sorts -> ProceduralTypes.step list -> unit diff --git a/matita/components/acic_procedural/proceduralTypes.ml b/matita/components/acic_procedural/proceduralTypes.ml deleted file mode 100644 index 45fbe756a..000000000 --- a/matita/components/acic_procedural/proceduralTypes.ml +++ /dev/null @@ -1,385 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -module HEL = HExtlib -module C = Cic -module I = CicInspect -module G = GrafiteAst -module N = CicNotationPt - -module H = ProceduralHelpers - -(* functions to be moved ****************************************************) - -let list_rev_map2 map l1 l2 = - let rec aux res = function - | hd1 :: tl1, hd2 :: tl2 -> aux (map hd1 hd2 :: res) (tl1, tl2) - | _ -> res - in - aux [] (l1, l2) - -let list_map2_filter map l1 l2 = - let rec filter l = function - | [] -> l - | None :: tl -> filter l tl - | Some a :: tl -> filter (a :: l) tl - in - filter [] (list_rev_map2 map l1 l2) - -let list_init f i = - let rec aux a j = if j < 0 then a else aux (f j :: a) (pred j) in - aux [] i - -(****************************************************************************) - -type flavour = C.object_flavour -type name = string option -type hyp = string -type what = C.annterm -type how = bool -type using = C.annterm -type count = int -type note = string -type where = (hyp * name) option -type inferred = C.annterm -type pattern = C.annterm -type body = C.annterm option -type types = C.anninductiveType list -type lpsno = int -type fields = (string * bool * int) list - -type step = Note of note - | Record of types * lpsno * fields * note - | Inductive of types * lpsno * note - | Statement of flavour * name * what * body * note - | Qed of note - | Id of note - | Exact of what * note - | Intros of count option * name list * note - | Cut of name * what * note - | LetIn of name * what * note - | LApply of name * what * note - | Rewrite of how * what * where * pattern * note - | Elim of what * using option * pattern * note - | Cases of what * pattern * note - | Apply of what * note - | Change of inferred * what * where * pattern * note - | Clear of hyp list * note - | ClearBody of hyp * note - | Branch of step list list * note - | Reflexivity of note - -(* annterm constructors *****************************************************) - -let mk_arel i b = C.ARel ("", "", i, b) - -(* FG: this is really awful !! *) -let arel_of_name = function - | C.Name s -> mk_arel 0 s - | C.Anonymous -> mk_arel 0 "_" - -(* helper functions on left params for use with inductive types *************) - -let strip_lps lpsno arity = - let rec aux no lps = function - | C.AProd (_, name, w, t) when no > 0 -> - let lp = name, Some w in - aux (pred no) (lp :: lps) t - | t -> lps, t - in - aux lpsno [] arity - -let merge_lps lps1 lps2 = - let map (n1, w1) (n2, _) = - let n = match n1, n2 with - | C.Name _, _ -> n1 - | _ -> n2 - in - n, w1 - in - if lps1 = [] then lps2 else - List.map2 map lps1 lps2 - -(* grafite ast constructors *************************************************) - -let floc = HEL.dummy_floc - -let mk_note str = G.Comment (floc, G.Note (floc, str)) - -let mk_tacnote str a = - if str = "" then mk_note "" :: a else mk_note "" :: mk_note str :: a - -let mk_notenote str a = - if str = "" then a else mk_note str :: a - -let mk_thnote str a = - if str = "" then a else mk_note "" :: mk_note str :: a - -let mk_pre_inductive types lpsno = - let map1 (lps1, cons) (name, arity) = - let lps2, arity = strip_lps lpsno arity in - merge_lps lps1 lps2, (name, arity) :: cons - in - let map2 (lps1, types) (_, name, kind, arity, cons) = - let lps2, arity = strip_lps lpsno arity in - let lps1, rev_cons = List.fold_left map1 (lps1, []) cons in - merge_lps lps1 lps2, (name, kind, arity, List.rev rev_cons) :: types - in - let map3 (name, xw) = arel_of_name name, xw in - let rev_lps, rev_types = List.fold_left map2 ([], []) types in - List.rev_map map3 rev_lps, List.rev rev_types - -let mk_inductive types lpsno = - let lpars, types = mk_pre_inductive types lpsno in - let obj = N.Inductive (lpars, types) in - G.Executable (floc, G.Command (floc, G.Obj (floc, obj))) - -let mk_record types lpsno fields = - match mk_pre_inductive types lpsno with - | lpars, [name, _, ty, [_, cty]] -> - let map (fields, cty) (name, coercion, arity) = - match cty with - | C.AProd (_, _, w, t) -> - (name, w, coercion, arity) :: fields, t - | _ -> - assert false - in - let rev_fields, _ = List.fold_left map ([], cty) fields in - let fields = List.rev rev_fields in - let obj = N.Record (lpars, name, ty, fields) in - G.Executable (floc, G.Command (floc, G.Obj (floc, obj))) - | _ -> assert false - -let mk_statement flavour name t v = - let name = match name with Some name -> name | None -> assert false in - let obj = N.Theorem (flavour, name, t, v, `Regular) in - G.Executable (floc, G.Command (floc, G.Obj (floc, obj))) - -let mk_qed = - G.Executable (floc, G.Command (floc, G.Qed floc)) - -let mk_tactic tactic punctation = - G.Executable (floc, G.Tactic (floc, Some tactic, punctation)) - -let mk_punctation punctation = - G.Executable (floc, G.Tactic (floc, None, punctation)) - -let mk_id punctation = - let tactic = G.IdTac floc in - mk_tactic tactic punctation - -let mk_exact t punctation = - let tactic = G.Exact (floc, t) in - mk_tactic tactic punctation - -let mk_intros xi xids punctation = - let tactic = G.Intros (floc, (xi, xids)) in - mk_tactic tactic punctation - -let mk_cut name what punctation = - let name = match name with Some name -> name | None -> assert false in - let tactic = G.Cut (floc, Some name, what) in - mk_tactic tactic punctation - -let mk_letin name what punctation = - let name = match name with Some name -> name | None -> assert false in - let tactic = G.LetIn (floc, what, name) in - mk_tactic tactic punctation - -let mk_lapply name what punctation = - let tactic = G.LApply (floc, false, None, [], what, name) in - mk_tactic tactic punctation - -let mk_rewrite direction what where pattern punctation = - let direction = if direction then `RightToLeft else `LeftToRight in - let pattern, rename = match where with - | None -> (None, [], Some pattern), [] - | Some (premise, Some name) -> (None, [premise, pattern], None), [Some name] - | Some (premise, None) -> (None, [premise, pattern], None), [] - in - let tactic = G.Rewrite (floc, direction, what, pattern, rename) in - mk_tactic tactic punctation - -let mk_elim what using pattern punctation = - let pattern = None, [], Some pattern in - let tactic = G.Elim (floc, what, using, pattern, (Some 0, [])) in - mk_tactic tactic punctation - -let mk_cases what pattern punctation = - let pattern = None, [], Some pattern in - let tactic = G.Cases (floc, what, pattern, (Some 0, [])) in - mk_tactic tactic punctation - -let mk_apply t punctation = - let tactic = G.Apply (floc, t) in - mk_tactic tactic punctation - -let mk_change t where pattern punctation = - let pattern = match where with - | None -> None, [], Some pattern - | Some (premise, _) -> None, [premise, pattern], None - in - let tactic = G.Change (floc, pattern, t) in - mk_tactic tactic punctation - -let mk_clear ids punctation = - let tactic = G.Clear (floc, ids) in - mk_tactic tactic punctation - -let mk_clearbody id punctation = - let tactic = G.ClearBody (floc, id) in - mk_tactic tactic punctation - -let mk_reflexivity punctation = - let tactic = G.Reflexivity floc in - mk_tactic tactic punctation - -let mk_ob = - let punctation = G.Branch floc in - mk_punctation punctation - -let mk_dot = G.Dot floc - -let mk_sc = G.Semicolon floc - -let mk_cb = G.Merge floc - -let mk_vb = G.Shift floc - -(* rendering ****************************************************************) - -let rec render_step sep a = function - | Note s -> mk_notenote s a - | Statement (f, n, t, v, s) -> mk_statement f n t v :: mk_thnote s a - | Inductive (ts, lps, s) -> mk_inductive ts lps :: mk_thnote s a - | Record (ts, lps, fs, s) -> mk_record ts lps fs :: mk_thnote s a - | Qed s -> mk_qed :: mk_tacnote s a - | Exact (t, s) -> mk_exact t sep :: mk_tacnote s a - | Id s -> mk_id sep :: mk_tacnote s a - | Intros (c, ns, s) -> mk_intros c ns sep :: mk_tacnote s a - | Cut (n, t, s) -> mk_cut n t sep :: mk_tacnote s a - | LetIn (n, t, s) -> mk_letin n t sep :: mk_tacnote s a - | LApply (n, t, s) -> mk_lapply n t sep :: mk_tacnote s a - | Rewrite (b, t, w, e, s) -> mk_rewrite b t w e sep :: mk_tacnote s a - | Elim (t, xu, e, s) -> mk_elim t xu e sep :: mk_tacnote s a - | Cases (t, e, s) -> mk_cases t e sep :: mk_tacnote s a - | Apply (t, s) -> mk_apply t sep :: mk_tacnote s a - | Change (t, _, w, e, s) -> mk_change t w e sep :: mk_tacnote s a - | Clear (ns, s) -> mk_clear ns sep :: mk_tacnote s a - | ClearBody (n, s) -> mk_clearbody n sep :: mk_tacnote s a - | Branch ([], s) -> a - | Branch ([ps], s) -> render_steps sep a ps - | Branch (ps :: pss, s) -> - let a = mk_ob :: mk_tacnote s a in - let a = List.fold_left (render_steps mk_vb) a (List.rev pss) in - mk_punctation sep :: render_steps mk_cb a ps - | Reflexivity s -> mk_reflexivity sep :: mk_tacnote s a - -and render_steps sep a = function - | [] -> a - | [p] -> render_step sep a p - | p :: Branch ([], _) :: ps -> - render_steps sep a (p :: ps) - | p :: ((Branch (_ :: _ :: _, _) :: _) as ps) -> - render_steps sep (render_step mk_sc a p) ps - | p :: ps -> - render_steps sep (render_step mk_sc a p) ps - -let render_steps a = render_steps mk_dot a - -(* counting *****************************************************************) - -let rec count_step a = function - | Note _ - | Statement _ - | Inductive _ - | Qed _ -> a -(* level A0 *) - | Branch (pps, _) -> List.fold_left count_steps a pps - | Clear _ - | ClearBody _ - | Id _ - | Intros (Some 0, [], _) -(* leval A1 *) - | Exact _ -(* level B1 *) - | Cut _ - | LetIn _ -(* level B2 *) - | Change _ -> a -(* level C *) - | _ -> succ a - -and count_steps a = List.fold_left count_step a - -let count = I.count_nodes ~meta:false - -let rec count_node a = function - | Note _ - | Record _ - | Inductive _ - | Statement _ - | Qed _ - | Reflexivity _ - | Id _ - | Intros _ - | Clear _ - | ClearBody _ -> a - | Exact (t, _) - | Cut (_, t, _) - | LetIn (_, t, _) - | LApply (_, t, _) - | Apply (t, _) -> count a (H.cic t) - | Rewrite (_, t, _, p, _) - | Elim (t, _, p, _) - | Cases (t, p, _) - | Change (t, _, _, p, _) -> let a = count a (H.cic t) in count a (H.cic p) - | Branch (ss, _) -> List.fold_left count_nodes a ss - -and count_nodes a = List.fold_left count_node a - -(* helpers ******************************************************************) - -let rec note_of_step = function - | Note s - | Statement (_, _, _, _, s) - | Inductive (_, _, s) - | Record (_, _, _, s) - | Qed s - | Exact (_, s) - | Id s - | Intros (_, _, s) - | Cut (_, _, s) - | LetIn (_, _, s) - | LApply (_, _, s) - | Rewrite (_, _, _, _, s) - | Elim (_, _, _, s) - | Cases (_, _, s) - | Apply (_, s) - | Change (_, _, _, _, s) - | Clear (_, s) - | ClearBody (_, s) - | Reflexivity s - | Branch (_, s) -> s diff --git a/matita/components/acic_procedural/proceduralTypes.mli b/matita/components/acic_procedural/proceduralTypes.mli deleted file mode 100644 index 969492a62..000000000 --- a/matita/components/acic_procedural/proceduralTypes.mli +++ /dev/null @@ -1,85 +0,0 @@ -(* Copyright (C) 2003-2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* functions to be moved ****************************************************) - -val list_rev_map2: ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - -val list_map2_filter: ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list - -val mk_arel: int -> string -> Cic.annterm - -(****************************************************************************) - -type flavour = Cic.object_flavour -type name = string option -type hyp = string -type what = Cic.annterm -type how = bool -type using = Cic.annterm -type count = int -type note = string -type where = (hyp * name) option -type inferred = Cic.annterm -type pattern = Cic.annterm -type body = Cic.annterm option -type types = Cic.anninductiveType list -type lpsno = int -type fields = (string * bool * int) list - -type step = Note of note - | Record of types * lpsno * fields * note - | Inductive of types * lpsno * note - | Statement of flavour * name * what * body * note - | Qed of note - | Id of note - | Exact of what * note - | Intros of count option * name list * note - | Cut of name * what * note - | LetIn of name * what * note - | LApply of name * what * note - | Rewrite of how * what * where * pattern * note - | Elim of what * using option * pattern * note - | Cases of what * pattern * note - | Apply of what * note - | Change of inferred * what * where * pattern * note - | Clear of hyp list * note - | ClearBody of hyp * note - | Branch of step list list * note - | Reflexivity of note - -val render_steps: - (what, inferred, [> `Whd] as 'b, what CicNotationPt.obj, hyp) GrafiteAst.statement list -> - step list -> - (what, inferred, 'b, what CicNotationPt.obj, hyp) GrafiteAst.statement list - -val count_steps: - int -> step list -> int - -val count_nodes: - int -> step list -> int - -val note_of_step: - step -> note diff --git a/matita/components/grafite_engine/grafiteEngine.ml b/matita/components/grafite_engine/grafiteEngine.ml index ad90b2b2e..b122366c1 100644 --- a/matita/components/grafite_engine/grafiteEngine.ml +++ b/matita/components/grafite_engine/grafiteEngine.ml @@ -25,8 +25,6 @@ (* $Id$ *) -module PEH = ProofEngineHelpers - exception Drop (* mo file name, ma file name *) exception IncludedFileNotCompiled of string * string @@ -63,348 +61,9 @@ let namer_of names = end else FreshNamesGenerator.mk_fresh_name ~subst:[] metasenv context name ~typ -let rec tactic_of_ast status ast = - let module PET = ProofEngineTypes in - match ast with - (* Higher order tactics *) - | GrafiteAst.Do (loc, n, tactic) -> - Tacticals.do_tactic n (tactic_of_ast status tactic) - | GrafiteAst.Seq (loc, tactics) -> (* tac1; tac2; ... *) - Tacticals.seq (List.map (tactic_of_ast status) tactics) - | GrafiteAst.Repeat (loc, tactic) -> - Tacticals.repeat_tactic (tactic_of_ast status tactic) - | GrafiteAst.Then (loc, tactic, tactics) -> (* tac; [ tac1 | ... ] *) - Tacticals.thens - (tactic_of_ast status tactic) - (List.map (tactic_of_ast status) tactics) - | GrafiteAst.First (loc, tactics) -> - Tacticals.first (List.map (tactic_of_ast status) tactics) - | GrafiteAst.Try (loc, tactic) -> - Tacticals.try_tactic (tactic_of_ast status tactic) - | GrafiteAst.Solve (loc, tactics) -> - Tacticals.solve_tactics (List.map (tactic_of_ast status) tactics) - | GrafiteAst.Progress (loc, tactic) -> - Tacticals.progress_tactic (tactic_of_ast status tactic) - (* First order tactics *) - | GrafiteAst.Absurd (_, term) -> Tactics.absurd term - | GrafiteAst.Apply (_, term) -> Tactics.apply term - | GrafiteAst.ApplyRule (_, term) -> Tactics.apply term - | GrafiteAst.ApplyP (_, term) -> Tactics.applyP term - | GrafiteAst.ApplyS (_, term, params) -> - Tactics.applyS ~term ~params ~dbd:(LibraryDb.instance ()) - ~automation_cache:status#automation_cache - | GrafiteAst.Assumption _ -> Tactics.assumption - | GrafiteAst.AutoBatch (_,params) -> - Tactics.auto ~params ~dbd:(LibraryDb.instance ()) - ~automation_cache:status#automation_cache - | GrafiteAst.Cases (_, what, pattern, (howmany, names)) -> - Tactics.cases_intros ?howmany ~mk_fresh_name_callback:(namer_of names) - ~pattern what - | GrafiteAst.Change (_, pattern, with_what) -> - Tactics.change ~pattern with_what - | GrafiteAst.Clear (_,id) -> Tactics.clear id - | GrafiteAst.ClearBody (_,id) -> Tactics.clearbody id - | GrafiteAst.Compose (_,t1,t2,times,(howmany, names)) -> - Tactics.compose times t1 t2 ?howmany - ~mk_fresh_name_callback:(namer_of names) - | GrafiteAst.Contradiction _ -> Tactics.contradiction - | GrafiteAst.Constructor (_, n) -> Tactics.constructor n - | GrafiteAst.Cut (_, ident, term) -> - let names = match ident with None -> [] | Some id -> [Some id] in - Tactics.cut ~mk_fresh_name_callback:(namer_of names) term - | GrafiteAst.Decompose (_, names) -> - let mk_fresh_name_callback = namer_of names in - Tactics.decompose ~mk_fresh_name_callback () - | GrafiteAst.Demodulate (_, params) -> - Tactics.demodulate - ~dbd:(LibraryDb.instance ()) ~params - ~automation_cache:status#automation_cache - | GrafiteAst.Destruct (_,xterms) -> Tactics.destruct xterms - | GrafiteAst.Elim (_, what, using, pattern, (depth, names)) -> - Tactics.elim_intros ?using ?depth ~mk_fresh_name_callback:(namer_of names) - ~pattern what - | GrafiteAst.ElimType (_, what, using, (depth, names)) -> - Tactics.elim_type ?using ?depth ~mk_fresh_name_callback:(namer_of names) - what - | GrafiteAst.Exact (_, term) -> Tactics.exact term - | GrafiteAst.Exists _ -> Tactics.exists - | GrafiteAst.Fail _ -> Tactics.fail - | GrafiteAst.Fold (_, reduction_kind, term, pattern) -> - let reduction = - match reduction_kind with - | `Normalize -> - PET.const_lazy_reduction - (CicReduction.normalize ~delta:false ~subst:[]) - | `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 -> [Some id] in - Tactics.generalize ~mk_fresh_name_callback:(namer_of names) pattern - | GrafiteAst.IdTac _ -> Tactics.id - | GrafiteAst.Intros (_, (howmany, names)) -> - PrimitiveTactics.intros_tac ?howmany - ~mk_fresh_name_callback:(namer_of names) () - | GrafiteAst.Inversion (_, term) -> - Tactics.inversion term - | GrafiteAst.LApply (_, linear, how_many, to_what, what, ident) -> - let names = match ident with None -> [] | Some id -> [Some id] in - Tactics.lapply ~mk_fresh_name_callback:(namer_of names) - ~linear ?how_many ~to_what what - | GrafiteAst.Left _ -> Tactics.left - | GrafiteAst.LetIn (loc,term,name) -> - Tactics.letin term ~mk_fresh_name_callback:(namer_of [Some name]) - | GrafiteAst.Reduce (_, reduction_kind, pattern) -> - (match reduction_kind with - | `Normalize -> Tactics.normalize ~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, names) -> - EqualityTactics.rewrite_tac ~direction ~pattern t -(* to be replaced with ~mk_fresh_name_callback:(namer_of names) *) - (List.map (function Some s -> s | None -> assert false) names) - | GrafiteAst.Right _ -> Tactics.right - | GrafiteAst.Ring _ -> Tactics.ring - | GrafiteAst.Split _ -> Tactics.split - | GrafiteAst.Symmetry _ -> Tactics.symmetry - | GrafiteAst.Transitivity (_, term) -> Tactics.transitivity term - (* Implementazioni Aggiunte *) - | GrafiteAst.Assume (_, id, t) -> Declarative.assume id t - | GrafiteAst.Suppose (_, t, id, t1) -> Declarative.suppose t id t1 - | GrafiteAst.By_just_we_proved (_, just, ty, id, t1) -> - Declarative.by_just_we_proved ~dbd:(LibraryDb.instance()) - ~automation_cache:status#automation_cache just ty id t1 - | GrafiteAst.We_need_to_prove (_, t, id, t2) -> - Declarative.we_need_to_prove t id t2 - | GrafiteAst.Bydone (_, t) -> - Declarative.bydone ~dbd:(LibraryDb.instance()) - ~automation_cache:status#automation_cache t - | GrafiteAst.We_proceed_by_cases_on (_, t, t1) -> - Declarative.we_proceed_by_cases_on t t1 - | GrafiteAst.We_proceed_by_induction_on (_, t, t1) -> - Declarative.we_proceed_by_induction_on t t1 - | GrafiteAst.Byinduction (_, t, id) -> Declarative.byinduction t id - | GrafiteAst.Thesisbecomes (_, t) -> Declarative.thesisbecomes t - | GrafiteAst.ExistsElim (_, just, id1, t1, id2, t2) -> - Declarative.existselim ~dbd:(LibraryDb.instance()) - ~automation_cache:status#automation_cache just id1 t1 id2 t2 - | GrafiteAst.Case (_,id,params) -> Declarative.case id params - | GrafiteAst.AndElim(_,just,id1,t1,id2,t2) -> - Declarative.andelim ~dbd:(LibraryDb.instance ()) - ~automation_cache:status#automation_cache just id1 t1 id2 t2 - | GrafiteAst.RewritingStep (_,termine,t1,t2,cont) -> - Declarative.rewritingstep ~dbd:(LibraryDb.instance ()) - ~automation_cache:status#automation_cache termine t1 t2 cont - -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.IdTac _ - | GrafiteAst.Generalize _ - | GrafiteAst.Elim _ - | GrafiteAst.Cut _ - | GrafiteAst.Decompose _ -> true - (* tactics like apply *) - | _ -> false - -let reorder_metasenv start refine tactic goals current_goal always_opens_a_goal= -(* 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 (text,prefix_len,tactic) (status, goal) = - let starting_metasenv = GrafiteTypes.get_proof_metasenv status in - let before = List.map (fun g, _, _ -> g) starting_metasenv in - let status, tactic = disambiguate_tactic status goal (text,prefix_len,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 always_opens_a_goal = classify_tactic tactic in - let tactic = tactic_of_ast status tactic in - 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 - let proof, opened_goals = - let uri, metasenv_after_tactic, subst, t, ty, attrs = proof in - 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, attrs in - proof', opened_goals - in - let incomplete_proof = - match status#proof_status with - | GrafiteTypes.Incomplete_proof p -> p - | _ -> assert false - in - status#set_proof_status - (GrafiteTypes.Incomplete_proof - { incomplete_proof with GrafiteTypes.proof = proof }), - opened_goals, closed_goals - -let apply_atomic_tactical ~disambiguate_tactic ~patch (text,prefix_len,tactic) (status, goal) = - let starting_metasenv = GrafiteTypes.get_proof_metasenv status in - let before = List.map (fun g, _, _ -> g) starting_metasenv in - let status, tactic = disambiguate_tactic status goal (text,prefix_len,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 always_opens_a_goal = classify_tactic tactic in - let tactic = tactic_of_ast status tactic in - let tactic = patch tactic in - 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 - let proof, opened_goals = - let uri, metasenv_after_tactic, _subst, t, ty, attrs = proof in - 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, _subst, t, ty, attrs in - proof', opened_goals - in - let incomplete_proof = - match status#proof_status with - | GrafiteTypes.Incomplete_proof p -> p - | _ -> assert false - in - status#set_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) - disambiguator_input -> - GrafiteTypes.status * - (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) -> disambiguate_command: (GrafiteTypes.status -> @@ -445,13 +104,6 @@ type 'a eval_comment = 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) - disambiguator_input -> - GrafiteTypes.status * - (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) -> disambiguate_command: (GrafiteTypes.status -> @@ -693,62 +345,6 @@ let eval_prefer_coercion status c = let status = GrafiteTypes.add_moo_content [moo_content] status in status, `Old [] -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 mk_tactic tac = tac - let apply_tactic tac = tac - let goals (_, opened, closed) = 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 - -module MatitaTacticals = Continuationals.Make(MatitaStatus) - -let tactic_of_ast' tac = - MatitaTacticals.Tactical (MatitaTacticals.Tactic (MatitaStatus.mk_tactic tac)) - -let punctuation_tactical_of_ast (text,prefix_len,punct) = - match punct with - | 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.Wildcard _loc -> MatitaTacticals.Wildcard - -let non_punctuation_tactical_of_ast (text,prefix_len,punct) = - match punct with - | GrafiteAst.Focus (_loc,goals) -> MatitaTacticals.Focus goals - | GrafiteAst.Unfocus _loc -> MatitaTacticals.Unfocus - | GrafiteAst.Skip _loc -> MatitaTacticals.Tactical MatitaTacticals.Skip - -let eval_tactical status tac = - let status, _, _ = MatitaTacticals.eval tac (status, ~-1) in - let status = (* is proof completed? *) - match status#proof_status with - | GrafiteTypes.Incomplete_proof - { GrafiteTypes.stack = stack; proof = proof } - when Continuationals.Stack.is_empty stack -> - status#set_proof_status (GrafiteTypes.Proof proof) - | _ -> status - in - status - -let add_obj = GrafiteSync.add_obj ~pack_coercion_obj:CicRefine.pack_coercion_obj - let eval_ng_punct (_text, _prefix_len, punct) = match punct with | GrafiteAst.Dot _ -> NTactics.dot_tac @@ -1113,43 +709,6 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status let status,cmd = disambiguate_command status (text,prefix_len,cmd) in let status,uris = match cmd with - | GrafiteAst.Index (loc,None,uri) -> - assert false (* TODO: for user input *) - | GrafiteAst.Index (loc,Some key,uri) -> - let universe = - status#automation_cache.AutomationCache.univ - in - let universe = Universe.index universe key (CicUtil.term_of_uri uri) in - let cache = { - status#automation_cache with AutomationCache.univ = universe } - in - let status = status#set_automation_cache cache in -(* debug - let msg = - let candidates = Universe.get_candidates status.GrafiteTypes.universe key in - ("candidates for " ^ (CicPp.ppterm key) ^ " = " ^ - (String.concat "\n" (List.map CicPp.ppterm candidates))) - in - prerr_endline msg; -*) - let status = GrafiteTypes.add_moo_content [cmd] status in - status,`Old [] - | GrafiteAst.Select (_,uri) as cmd -> - if List.mem cmd status#moo_content_rev then status, `Old [] - else - let cache = - AutomationCache.add_term_to_active status#automation_cache - [] [] [] (CicUtil.term_of_uri uri) None - in - let status = status#set_automation_cache cache in - let status = GrafiteTypes.add_moo_content [cmd] status in - status, `Old [] - | GrafiteAst.Pump (_,steps) -> - let cache = - AutomationCache.pump status#automation_cache steps - in - let status = status#set_automation_cache cache in - status, `Old [] | GrafiteAst.PreferCoercion (loc, coercion) -> eval_prefer_coercion status coercion | GrafiteAst.Coercion (loc, uri, add_composites, arity, saturations) -> @@ -1157,17 +716,6 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status eval_coercion status ~add_composites uri arity saturations in res,`Old uris - | GrafiteAst.Inverter (loc, name, indty, params) -> - let buri = status#baseuri in - let uri = UriManager.uri_of_string (buri ^ "/" ^ name ^ ".con") in - let indty_uri = - try CicUtil.uri_of_term indty - with Invalid_argument _ -> - raise (Invalid_argument "not an inductive type to invert") in - let res,uris = - Inversion_principle.build_inverter ~add_obj status uri indty_uri params - in - res,`Old uris | GrafiteAst.Default (loc, what, uris) as cmd -> LibraryObjects.set_default what uris; GrafiteTypes.add_moo_content [cmd] status,`Old [] @@ -1198,66 +746,16 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status [GrafiteAst.Include (loc,mode,`New,baseuri)] status in status,`Old [] - | GrafiteAst.Print (_,"proofterm") -> - let _,_,_,p,_, _ = GrafiteTypes.get_current_proof status in - prerr_endline (Auto.pp_proofterm (Lazy.force p)); - status,`Old [] | GrafiteAst.Print (_,_) -> status,`Old [] - | GrafiteAst.Qed loc -> - let uri, metasenv, _subst, bo, ty, attrs = - match status#proof_status with - | GrafiteTypes.Proof (Some uri, metasenv, subst, body, ty, attrs) -> - uri, metasenv, subst, body, ty, attrs - | GrafiteTypes.Proof (None, metasenv, subst, body, ty, attrs) -> - 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 (Lazy.force bo),ty,[],attrs) in - let status, lemmas = add_obj uri obj status in - status#set_proof_status GrafiteTypes.No_proof, - (*CSC: I throw away the arities *) - `Old (uri::lemmas) - | GrafiteAst.Relation (loc, id, a, aeq, refl, sym, trans) -> - Setoids.add_relation id a aeq refl sym trans; - status, `Old [] (*CSC: TO BE FIXED *) | GrafiteAst.Set (loc, name, value) -> status, `Old [] (* GrafiteTypes.set_option status name value,[] *) | GrafiteAst.Obj (loc,obj) -> (* MATITA 1.0 *) assert false in - match status#proof_status with - GrafiteTypes.Intermediate _ -> - status#set_proof_status GrafiteTypes.No_proof,uris - | _ -> status,uris + status,uris -} and eval_executable = {ee_go = fun ~disambiguate_tactic ~disambiguate_command +} and eval_executable = {ee_go = fun ~disambiguate_command ~disambiguate_macro opts status (text,prefix_len,ex) -> match ex with - | GrafiteAst.Tactic (_(*loc*), Some tac, punct) -> - let tac = apply_tactic ~disambiguate_tactic (text,prefix_len,tac) in - let status = eval_tactical status (tactic_of_ast' tac) in - (* CALL auto on every goal, easy way of testing it - let auto = - GrafiteAst.AutoBatch - (loc, ([],["depth","2";"timeout","1";"type","1"])) in - (try - let auto = apply_tactic ~disambiguate_tactic ("",0,auto) in - let _ = eval_tactical status (tactic_of_ast' auto) in - print_endline "GOOD"; () - with ProofEngineTypes.Fail _ -> print_endline "BAD" | _ -> ());*) - eval_tactical status - (punctuation_tactical_of_ast (text,prefix_len,punct)),`Old [] - | GrafiteAst.Tactic (_, None, punct) -> - eval_tactical status - (punctuation_tactical_of_ast (text,prefix_len,punct)),`Old [] | GrafiteAst.NTactic (_(*loc*), tacl) -> if status#ng_mode <> `ProofMode then raise (GrafiteTypes.Command_error "Not in proof mode") @@ -1270,13 +768,6 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status status tacl in status,`New [] - | GrafiteAst.NonPunctuationTactical (_, tac, punct) -> - let status = - eval_tactical status - (non_punctuation_tactical_of_ast (text,prefix_len,tac)) - in - eval_tactical status - (punctuation_tactical_of_ast (text,prefix_len,punct)),`Old [] | GrafiteAst.Command (_, cmd) -> eval_command.ec_go ~disambiguate_command opts status (text,prefix_len,cmd) | GrafiteAst.NCommand (_, cmd) -> @@ -1298,7 +789,6 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status 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 @@ -1306,14 +796,14 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status assert (lemmas=`Old []); status) status moo -} and eval_ast = {ea_go = fun ~disambiguate_tactic ~disambiguate_command +} and eval_ast = {ea_go = fun ~disambiguate_command ~disambiguate_macro ?(do_heavy_checks=false) status (text,prefix_len,st) -> let opts = { do_heavy_checks = do_heavy_checks ; } in match st with | GrafiteAst.Executable (_,ex) -> - eval_executable.ee_go ~disambiguate_tactic ~disambiguate_command + eval_executable.ee_go ~disambiguate_command ~disambiguate_macro opts status (text,prefix_len,ex) | GrafiteAst.Comment (_,c) -> eval_comment.ecm_go ~disambiguate_command opts status (text,prefix_len,c) diff --git a/matita/components/grafite_engine/grafiteEngine.mli b/matita/components/grafite_engine/grafiteEngine.mli index 0b263157f..dbb462d65 100644 --- a/matita/components/grafite_engine/grafiteEngine.mli +++ b/matita/components/grafite_engine/grafiteEngine.mli @@ -33,14 +33,6 @@ exception NMacro of GrafiteAst.loc * GrafiteAst.nmacro type 'a disambiguator_input = string * int * 'a val eval_ast : - disambiguate_tactic: - (GrafiteTypes.status -> - ProofEngineTypes.goal -> - (('term, 'lazy_term, 'reduction, 'ident) GrafiteAst.tactic) - disambiguator_input -> - GrafiteTypes.status * - (Cic.term, Cic.lazy_term, Cic.lazy_term GrafiteAst.reduction, string) GrafiteAst.tactic) -> - disambiguate_command: (GrafiteTypes.status -> (('term,'obj) GrafiteAst.command) disambiguator_input -> diff --git a/matita/components/grafite_engine/grafiteSync.ml b/matita/components/grafite_engine/grafiteSync.ml index 47744f66e..33ec596f5 100644 --- a/matita/components/grafite_engine/grafiteSync.ml +++ b/matita/components/grafite_engine/grafiteSync.ml @@ -72,70 +72,6 @@ let is_equational_fact ty = aux [] ty ;; -let add_obj ~pack_coercion_obj uri obj status = - let lemmas = LibrarySync.add_obj ~pack_coercion_obj uri obj in - let add_to_universe (automation_cache,status) uri = - let term = CicUtil.term_of_uri uri in - let ty,_ = CicTypeChecker.type_of_aux' [] [] term CicUniv.oblivion_ugraph in - let tkeys = Universe.keys [] ty in - let universe = automation_cache.AutomationCache.univ in - let universe, index_cmd = - List.fold_left - (fun (universe,acc) key -> - let cands = Universe.get_candidates universe key in - let tys = - List.map - (fun t -> - let ty, _ = - CicTypeChecker.type_of_aux' [] [] t CicUniv.oblivion_ugraph - in - ty) - cands - in - if List.for_all - (fun cty -> - not (fst(CicReduction.are_convertible [] ty cty - CicUniv.oblivion_ugraph))) tys - then - Universe.index universe key term, - GrafiteAst.Index(HExtlib.dummy_floc,(Some key),uri)::acc - else - universe, acc) - (universe,[]) tkeys - in - let is_equational = is_equational_fact ty in - let select_cmd = - if is_equational then - [ GrafiteAst.Select(HExtlib.dummy_floc,uri) ] - else - [] - in - let automation_cache = - if is_equational then - AutomationCache.add_term_to_active automation_cache [] [] [] term None - else - automation_cache - in - let automation_cache = - { automation_cache with AutomationCache.univ = universe } in - let status = GrafiteTypes.add_moo_content index_cmd status in - let status = GrafiteTypes.add_moo_content select_cmd status in - (automation_cache,status) - in - let uris_to_index = - if is_a_variant obj then [] - else (uris_for_inductive_type uri obj) @ lemmas - in - let automation_cache,status = - List.fold_left add_to_universe - (status#automation_cache,status) - uris_to_index - in - (status - #set_objects (uri :: lemmas @ status#objects)) - #set_automation_cache automation_cache, - lemmas - let add_coercion ~pack_coercion_obj ~add_composites status uri arity saturations baseuri = diff --git a/matita/components/grafite_engine/grafiteSync.mli b/matita/components/grafite_engine/grafiteSync.mli index bac7eee9b..5b4971132 100644 --- a/matita/components/grafite_engine/grafiteSync.mli +++ b/matita/components/grafite_engine/grafiteSync.mli @@ -23,11 +23,6 @@ * http://helm.cs.unibo.it/ *) -val add_obj: - pack_coercion_obj:(Cic.obj -> Cic.obj) -> - UriManager.uri -> Cic.obj -> GrafiteTypes.status -> - GrafiteTypes.status * UriManager.uri list - val add_coercion: pack_coercion_obj:(Cic.obj -> Cic.obj) -> add_composites:bool -> GrafiteTypes.status -> diff --git a/matita/components/grafite_engine/grafiteTypes.ml b/matita/components/grafite_engine/grafiteTypes.ml index 96ae9acfd..618d20050 100644 --- a/matita/components/grafite_engine/grafiteTypes.ml +++ b/matita/components/grafite_engine/grafiteTypes.ml @@ -31,19 +31,6 @@ 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. *) - class status = fun (b : string) -> let fake_obj = NUri.uri_of_string "cic:/matita/dummy.decl",0,[],[], @@ -51,22 +38,16 @@ class status = fun (b : string) -> in object val moo_content_rev = ([] : GrafiteMarshal.moo) - val proof_status = No_proof val objects = ([] : UriManager.uri list) val coercions = CoercDb.empty_coerc_db - val automation_cache = AutomationCache.empty () val baseuri = b val ng_mode = (`CommandMode : [`CommandMode | `ProofMode]) method moo_content_rev = moo_content_rev method set_moo_content_rev v = {< moo_content_rev = v >} - method proof_status = proof_status - method set_proof_status v = {< proof_status = v >} method objects = objects method set_objects v = {< objects = v >} method coercions = coercions method set_coercions v = {< coercions = v >} - method automation_cache = automation_cache - method set_automation_cache v = {< automation_cache = v >} method baseuri = baseuri method set_baseuri v = {< baseuri = v >} method ng_mode = ng_mode; @@ -75,63 +56,6 @@ class status = fun (b : string) -> inherit ([Continuationals.Stack.t] NTacStatus.status fake_obj (Continuationals.Stack.empty)) end -let get_current_proof status = - match status#proof_status with - | Incomplete_proof { proof = p } -> p - | 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#set_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, _, subst, proof, ty, attrs) } as incomplete_proof) -> - Incomplete_proof - { incomplete_proof with proof = (uri, metasenv, subst, proof, ty, attrs) } - | Intermediate _ -> Intermediate metasenv - | Proof (_, metasenv', _, _, _, _) -> - assert (metasenv = metasenv'); - status#proof_status - in - status#set_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' = @@ -154,12 +78,6 @@ let add_moo_content cmds status = 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"; HLog.message "status.coercions\n"; HLog.message "status.objects:\n"; diff --git a/matita/components/grafite_engine/grafiteTypes.mli b/matita/components/grafite_engine/grafiteTypes.mli index 4e2decc9c..03a5c05d3 100644 --- a/matita/components/grafite_engine/grafiteTypes.mli +++ b/matita/components/grafite_engine/grafiteTypes.mli @@ -31,30 +31,15 @@ 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 - class status : string -> object ('self) method moo_content_rev: GrafiteMarshal.moo method set_moo_content_rev: GrafiteMarshal.moo -> 'self - method proof_status: proof_status - method set_proof_status: proof_status -> 'self method objects: UriManager.uri list method set_objects: UriManager.uri list -> 'self method coercions: CoercDb.coerc_db method set_coercions: CoercDb.coerc_db -> 'self - method automation_cache:AutomationCache.cache - method set_automation_cache:AutomationCache.cache -> 'self method baseuri: string method set_baseuri: string -> 'self method ng_mode: [`ProofMode | `CommandMode] @@ -67,12 +52,3 @@ 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_current_proof: status -> ProofEngineTypes.proof -val get_proof_metasenv: status -> Cic.metasenv -val get_stack: status -> Continuationals.Stack.t -val get_proof_context : status -> int -> Cic.context -val get_proof_conclusion : status -> int -> Cic.term - -val set_stack: Continuationals.Stack.t -> status -> status -val set_metasenv: Cic.metasenv -> status -> status diff --git a/matita/components/grafite_parser/grafiteDisambiguate.ml b/matita/components/grafite_parser/grafiteDisambiguate.ml index eb9f33f51..330a93a0d 100644 --- a/matita/components/grafite_parser/grafiteDisambiguate.ml +++ b/matita/components/grafite_parser/grafiteDisambiguate.ml @@ -220,13 +220,11 @@ let disambiguate_nobj estatus ?baseuri (text,prefix_len,obj) = let estatus = LexiconEngine.set_proof_aliases estatus diff in estatus, cic ;; -let disambiguate_command estatus ?baseuri metasenv (text,prefix_len,cmd)= +let disambiguate_command estatus ?baseuri (text,prefix_len,cmd)= match cmd with | GrafiteAst.Index(loc,key,uri) -> (* MATITA 1.0 *) assert false | GrafiteAst.Select (loc,uri) -> - estatus, metasenv, GrafiteAst.Select(loc,uri) - | GrafiteAst.Pump(loc,i) -> - estatus, metasenv, GrafiteAst.Pump(loc,i) + estatus, GrafiteAst.Select(loc,uri) | GrafiteAst.PreferCoercion (loc,t) -> (* MATITA 1.0 *) assert false | GrafiteAst.Coercion (loc,t,b,a,s) -> (* MATITA 1.0 *) assert false | GrafiteAst.Inverter (loc,n,indty,params) -> (* MATITA 1.0 *) assert false @@ -236,6 +234,6 @@ let disambiguate_command estatus ?baseuri metasenv (text,prefix_len,cmd)= | GrafiteAst.Print _ | GrafiteAst.Qed _ | GrafiteAst.Set _ as cmd -> - estatus,metasenv,cmd + estatus,cmd | GrafiteAst.Obj (loc,obj) -> (* MATITA 1.0 *) assert false | GrafiteAst.Relation (loc,id,a,aeq,refl,sym,trans) -> (* MATITA 1.0 *) assert false diff --git a/matita/components/grafite_parser/grafiteDisambiguate.mli b/matita/components/grafite_parser/grafiteDisambiguate.mli index e17769ec9..439a817d3 100644 --- a/matita/components/grafite_parser/grafiteDisambiguate.mli +++ b/matita/components/grafite_parser/grafiteDisambiguate.mli @@ -37,9 +37,8 @@ type lazy_tactic = val disambiguate_command: LexiconEngine.status as 'status -> ?baseuri:string -> - Cic.metasenv -> ((CicNotationPt.term,CicNotationPt.term CicNotationPt.obj) GrafiteAst.command) Disambiguate.disambiguator_input -> - 'status * Cic.metasenv * (Cic.term,Cic.obj) GrafiteAst.command + 'status * (Cic.term,Cic.obj) GrafiteAst.command val disambiguate_nterm : NCic.term option -> diff --git a/matita/components/ng_disambiguation/.depend b/matita/components/ng_disambiguation/.depend index 3630ffef3..a520f2c39 100644 --- a/matita/components/ng_disambiguation/.depend +++ b/matita/components/ng_disambiguation/.depend @@ -3,5 +3,5 @@ disambiguateChoices.cmo: disambiguateChoices.cmi disambiguateChoices.cmx: disambiguateChoices.cmi nCicDisambiguate.cmo: nCicDisambiguate.cmi nCicDisambiguate.cmx: nCicDisambiguate.cmi -nnumber_notation.cmo: -nnumber_notation.cmx: +nnumber_notation.cmo: disambiguateChoices.cmi +nnumber_notation.cmx: disambiguateChoices.cmx diff --git a/matita/components/ng_tactics/.depend b/matita/components/ng_tactics/.depend index c54a536d9..a90df82fa 100644 --- a/matita/components/ng_tactics/.depend +++ b/matita/components/ng_tactics/.depend @@ -1,32 +1,28 @@ +continuationals.cmi: nCicTacReduction.cmi: -nTacStatus.cmi: +nTacStatus.cmi: continuationals.cmi nCicElim.cmi: -nTactics.cmi: nTacStatus.cmi -zipTree.cmi: -andOrTree.cmi: zipTree.cmi +nTactics.cmi: nTacStatus.cmi continuationals.cmi nnAuto.cmi: nTacStatus.cmi -nAuto.cmi: nTacStatus.cmi -nInversion.cmi: nTacStatus.cmi nDestructTac.cmi: nTacStatus.cmi +nInversion.cmi: nTacStatus.cmi +continuationals.cmo: continuationals.cmi +continuationals.cmx: continuationals.cmi nCicTacReduction.cmo: nCicTacReduction.cmi nCicTacReduction.cmx: nCicTacReduction.cmi -nTacStatus.cmo: nCicTacReduction.cmi nTacStatus.cmi -nTacStatus.cmx: nCicTacReduction.cmx nTacStatus.cmi +nTacStatus.cmo: nCicTacReduction.cmi continuationals.cmi nTacStatus.cmi +nTacStatus.cmx: nCicTacReduction.cmx continuationals.cmx nTacStatus.cmi nCicElim.cmo: nCicElim.cmi nCicElim.cmx: nCicElim.cmi -nTactics.cmo: nTacStatus.cmi nCicElim.cmi nTactics.cmi -nTactics.cmx: nTacStatus.cmx nCicElim.cmx nTactics.cmi -zipTree.cmo: zipTree.cmi -zipTree.cmx: zipTree.cmi -andOrTree.cmo: zipTree.cmi andOrTree.cmi -andOrTree.cmx: zipTree.cmx andOrTree.cmi -nnAuto.cmo: nTactics.cmi nTacStatus.cmi nCicTacReduction.cmi nnAuto.cmi -nnAuto.cmx: nTactics.cmx nTacStatus.cmx nCicTacReduction.cmx nnAuto.cmi -nAuto.cmo: zipTree.cmi nnAuto.cmi nTactics.cmi nTacStatus.cmi andOrTree.cmi \ - nAuto.cmi -nAuto.cmx: zipTree.cmx nnAuto.cmx nTactics.cmx nTacStatus.cmx andOrTree.cmx \ - nAuto.cmi -nInversion.cmo: nTactics.cmi nCicElim.cmi nInversion.cmi -nInversion.cmx: nTactics.cmx nCicElim.cmx nInversion.cmi -nDestructTac.cmo: nTactics.cmi nTacStatus.cmi nDestructTac.cmi -nDestructTac.cmx: nTactics.cmx nTacStatus.cmx nDestructTac.cmi +nTactics.cmo: nTacStatus.cmi nCicElim.cmi continuationals.cmi nTactics.cmi +nTactics.cmx: nTacStatus.cmx nCicElim.cmx continuationals.cmx nTactics.cmi +nnAuto.cmo: nTactics.cmi nTacStatus.cmi nCicTacReduction.cmi \ + continuationals.cmi nnAuto.cmi +nnAuto.cmx: nTactics.cmx nTacStatus.cmx nCicTacReduction.cmx \ + continuationals.cmx nnAuto.cmi +nDestructTac.cmo: nTactics.cmi nTacStatus.cmi continuationals.cmi \ + nDestructTac.cmi +nDestructTac.cmx: nTactics.cmx nTacStatus.cmx continuationals.cmx \ + nDestructTac.cmi +nInversion.cmo: nTactics.cmi nCicElim.cmi continuationals.cmi nInversion.cmi +nInversion.cmx: nTactics.cmx nCicElim.cmx continuationals.cmx nInversion.cmi diff --git a/matita/components/ng_tactics/.depend.opt b/matita/components/ng_tactics/.depend.opt index c54a536d9..a90df82fa 100644 --- a/matita/components/ng_tactics/.depend.opt +++ b/matita/components/ng_tactics/.depend.opt @@ -1,32 +1,28 @@ +continuationals.cmi: nCicTacReduction.cmi: -nTacStatus.cmi: +nTacStatus.cmi: continuationals.cmi nCicElim.cmi: -nTactics.cmi: nTacStatus.cmi -zipTree.cmi: -andOrTree.cmi: zipTree.cmi +nTactics.cmi: nTacStatus.cmi continuationals.cmi nnAuto.cmi: nTacStatus.cmi -nAuto.cmi: nTacStatus.cmi -nInversion.cmi: nTacStatus.cmi nDestructTac.cmi: nTacStatus.cmi +nInversion.cmi: nTacStatus.cmi +continuationals.cmo: continuationals.cmi +continuationals.cmx: continuationals.cmi nCicTacReduction.cmo: nCicTacReduction.cmi nCicTacReduction.cmx: nCicTacReduction.cmi -nTacStatus.cmo: nCicTacReduction.cmi nTacStatus.cmi -nTacStatus.cmx: nCicTacReduction.cmx nTacStatus.cmi +nTacStatus.cmo: nCicTacReduction.cmi continuationals.cmi nTacStatus.cmi +nTacStatus.cmx: nCicTacReduction.cmx continuationals.cmx nTacStatus.cmi nCicElim.cmo: nCicElim.cmi nCicElim.cmx: nCicElim.cmi -nTactics.cmo: nTacStatus.cmi nCicElim.cmi nTactics.cmi -nTactics.cmx: nTacStatus.cmx nCicElim.cmx nTactics.cmi -zipTree.cmo: zipTree.cmi -zipTree.cmx: zipTree.cmi -andOrTree.cmo: zipTree.cmi andOrTree.cmi -andOrTree.cmx: zipTree.cmx andOrTree.cmi -nnAuto.cmo: nTactics.cmi nTacStatus.cmi nCicTacReduction.cmi nnAuto.cmi -nnAuto.cmx: nTactics.cmx nTacStatus.cmx nCicTacReduction.cmx nnAuto.cmi -nAuto.cmo: zipTree.cmi nnAuto.cmi nTactics.cmi nTacStatus.cmi andOrTree.cmi \ - nAuto.cmi -nAuto.cmx: zipTree.cmx nnAuto.cmx nTactics.cmx nTacStatus.cmx andOrTree.cmx \ - nAuto.cmi -nInversion.cmo: nTactics.cmi nCicElim.cmi nInversion.cmi -nInversion.cmx: nTactics.cmx nCicElim.cmx nInversion.cmi -nDestructTac.cmo: nTactics.cmi nTacStatus.cmi nDestructTac.cmi -nDestructTac.cmx: nTactics.cmx nTacStatus.cmx nDestructTac.cmi +nTactics.cmo: nTacStatus.cmi nCicElim.cmi continuationals.cmi nTactics.cmi +nTactics.cmx: nTacStatus.cmx nCicElim.cmx continuationals.cmx nTactics.cmi +nnAuto.cmo: nTactics.cmi nTacStatus.cmi nCicTacReduction.cmi \ + continuationals.cmi nnAuto.cmi +nnAuto.cmx: nTactics.cmx nTacStatus.cmx nCicTacReduction.cmx \ + continuationals.cmx nnAuto.cmi +nDestructTac.cmo: nTactics.cmi nTacStatus.cmi continuationals.cmi \ + nDestructTac.cmi +nDestructTac.cmx: nTactics.cmx nTacStatus.cmx continuationals.cmx \ + nDestructTac.cmi +nInversion.cmo: nTactics.cmi nCicElim.cmi continuationals.cmi nInversion.cmi +nInversion.cmx: nTactics.cmx nCicElim.cmx continuationals.cmx nInversion.cmi diff --git a/matita/components/ng_tactics/Makefile b/matita/components/ng_tactics/Makefile index a1b5e0205..3a261d192 100644 --- a/matita/components/ng_tactics/Makefile +++ b/matita/components/ng_tactics/Makefile @@ -1,6 +1,7 @@ PACKAGE = ng_tactics INTERFACE_FILES = \ + continuationals.mli \ nCicTacReduction.mli \ nTacStatus.mli \ nCicElim.mli \ diff --git a/matita/components/tactics/continuationals.ml b/matita/components/ng_tactics/continuationals.ml similarity index 99% rename from matita/components/tactics/continuationals.ml rename to matita/components/ng_tactics/continuationals.ml index 183e8cabf..714dad533 100644 --- a/matita/components/tactics/continuationals.ml +++ b/matita/components/ng_tactics/continuationals.ml @@ -33,7 +33,7 @@ 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 +type goal = int module Stack = struct diff --git a/matita/components/tactics/continuationals.mli b/matita/components/ng_tactics/continuationals.mli similarity index 99% rename from matita/components/tactics/continuationals.mli rename to matita/components/ng_tactics/continuationals.mli index 12681db63..293d056b3 100644 --- a/matita/components/tactics/continuationals.mli +++ b/matita/components/ng_tactics/continuationals.mli @@ -25,7 +25,7 @@ exception Error of string Lazy.t -type goal = ProofEngineTypes.goal +type goal = int (** {2 Goal stack} *) diff --git a/matita/components/tactics/.depend b/matita/components/tactics/.depend deleted file mode 100644 index d9d6034a1..000000000 --- a/matita/components/tactics/.depend +++ /dev/null @@ -1,229 +0,0 @@ -proofEngineTypes.cmi: -proofEngineHelpers.cmi: proofEngineTypes.cmi -proofEngineReduction.cmi: -continuationals.cmi: proofEngineTypes.cmi -tacticals.cmi: proofEngineTypes.cmi -reductionTactics.cmi: proofEngineTypes.cmi -proofEngineStructuralRules.cmi: proofEngineTypes.cmi -primitiveTactics.cmi: proofEngineTypes.cmi -hashtbl_equiv.cmi: -metadataQuery.cmi: proofEngineTypes.cmi -universe.cmi: -autoTypes.cmi: proofEngineTypes.cmi -autoCache.cmi: -paramodulation/utils.cmi: -closeCoercionGraph.cmi: -paramodulation/subst.cmi: -paramodulation/equality.cmi: paramodulation/utils.cmi \ - paramodulation/subst.cmi -paramodulation/founif.cmi: paramodulation/subst.cmi -paramodulation/equality_indexing.cmi: paramodulation/utils.cmi \ - paramodulation/equality.cmi -paramodulation/indexing.cmi: paramodulation/utils.cmi \ - paramodulation/subst.cmi paramodulation/equality_indexing.cmi \ - paramodulation/equality.cmi -paramodulation/saturation.cmi: paramodulation/utils.cmi proofEngineTypes.cmi \ - paramodulation/indexing.cmi paramodulation/equality.cmi -automationCache.cmi: universe.cmi paramodulation/saturation.cmi \ - paramodulation/equality.cmi -variousTactics.cmi: proofEngineTypes.cmi -compose.cmi: proofEngineTypes.cmi -introductionTactics.cmi: proofEngineTypes.cmi -eliminationTactics.cmi: proofEngineTypes.cmi -negationTactics.cmi: proofEngineTypes.cmi -equalityTactics.cmi: proofEngineTypes.cmi -auto.cmi: proofEngineTypes.cmi automationCache.cmi -destructTactic.cmi: proofEngineTypes.cmi -inversion.cmi: proofEngineTypes.cmi -inversion_principle.cmi: -ring.cmi: proofEngineTypes.cmi -setoids.cmi: proofEngineTypes.cmi -fourier.cmi: -fourierR.cmi: proofEngineTypes.cmi -fwdSimplTactic.cmi: proofEngineTypes.cmi -history.cmi: -statefulProofEngine.cmi: proofEngineTypes.cmi -tactics.cmi: tacticals.cmi proofEngineTypes.cmi automationCache.cmi auto.cmi -declarative.cmi: proofEngineTypes.cmi automationCache.cmi auto.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 \ - proofEngineStructuralRules.cmi proofEngineReduction.cmi \ - proofEngineHelpers.cmi primitiveTactics.cmi -primitiveTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \ - proofEngineStructuralRules.cmx proofEngineReduction.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 -universe.cmo: proofEngineTypes.cmi proofEngineReduction.cmi universe.cmi -universe.cmx: proofEngineTypes.cmx proofEngineReduction.cmx universe.cmi -autoTypes.cmo: autoTypes.cmi -autoTypes.cmx: autoTypes.cmi -autoCache.cmo: universe.cmi autoCache.cmi -autoCache.cmx: universe.cmx autoCache.cmi -paramodulation/utils.cmo: proofEngineReduction.cmi paramodulation/utils.cmi -paramodulation/utils.cmx: proofEngineReduction.cmx paramodulation/utils.cmi -closeCoercionGraph.cmo: closeCoercionGraph.cmi -closeCoercionGraph.cmx: closeCoercionGraph.cmi -paramodulation/subst.cmo: paramodulation/subst.cmi -paramodulation/subst.cmx: paramodulation/subst.cmi -paramodulation/equality.cmo: paramodulation/utils.cmi \ - paramodulation/subst.cmi proofEngineTypes.cmi proofEngineReduction.cmi \ - paramodulation/equality.cmi -paramodulation/equality.cmx: paramodulation/utils.cmx \ - paramodulation/subst.cmx proofEngineTypes.cmx proofEngineReduction.cmx \ - paramodulation/equality.cmi -paramodulation/founif.cmo: paramodulation/utils.cmi paramodulation/subst.cmi \ - paramodulation/founif.cmi -paramodulation/founif.cmx: paramodulation/utils.cmx paramodulation/subst.cmx \ - paramodulation/founif.cmi -paramodulation/equality_indexing.cmo: paramodulation/utils.cmi \ - paramodulation/equality.cmi paramodulation/equality_indexing.cmi -paramodulation/equality_indexing.cmx: paramodulation/utils.cmx \ - paramodulation/equality.cmx paramodulation/equality_indexing.cmi -paramodulation/indexing.cmo: paramodulation/utils.cmi \ - paramodulation/subst.cmi proofEngineTypes.cmi paramodulation/founif.cmi \ - paramodulation/equality_indexing.cmi paramodulation/equality.cmi \ - paramodulation/indexing.cmi -paramodulation/indexing.cmx: paramodulation/utils.cmx \ - paramodulation/subst.cmx proofEngineTypes.cmx paramodulation/founif.cmx \ - paramodulation/equality_indexing.cmx paramodulation/equality.cmx \ - paramodulation/indexing.cmi -paramodulation/saturation.cmo: paramodulation/utils.cmi \ - paramodulation/subst.cmi proofEngineTypes.cmi proofEngineHelpers.cmi \ - paramodulation/indexing.cmi paramodulation/founif.cmi \ - paramodulation/equality.cmi paramodulation/saturation.cmi -paramodulation/saturation.cmx: paramodulation/utils.cmx \ - paramodulation/subst.cmx proofEngineTypes.cmx proofEngineHelpers.cmx \ - paramodulation/indexing.cmx paramodulation/founif.cmx \ - paramodulation/equality.cmx paramodulation/saturation.cmi -automationCache.cmo: universe.cmi paramodulation/saturation.cmi \ - paramodulation/equality.cmi automationCache.cmi -automationCache.cmx: universe.cmx paramodulation/saturation.cmx \ - paramodulation/equality.cmx automationCache.cmi -variousTactics.cmo: proofEngineTypes.cmi primitiveTactics.cmi \ - variousTactics.cmi -variousTactics.cmx: proofEngineTypes.cmx primitiveTactics.cmx \ - variousTactics.cmi -compose.cmo: proofEngineTypes.cmi primitiveTactics.cmi closeCoercionGraph.cmi \ - compose.cmi -compose.cmx: proofEngineTypes.cmx primitiveTactics.cmx closeCoercionGraph.cmx \ - compose.cmi -introductionTactics.cmo: proofEngineTypes.cmi primitiveTactics.cmi \ - introductionTactics.cmi -introductionTactics.cmx: proofEngineTypes.cmx primitiveTactics.cmx \ - introductionTactics.cmi -eliminationTactics.cmo: tacticals.cmi reductionTactics.cmi \ - proofEngineTypes.cmi proofEngineStructuralRules.cmi \ - proofEngineHelpers.cmi primitiveTactics.cmi eliminationTactics.cmi -eliminationTactics.cmx: tacticals.cmx reductionTactics.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 -auto.cmo: paramodulation/utils.cmi universe.cmi paramodulation/subst.cmi \ - paramodulation/saturation.cmi proofEngineTypes.cmi \ - proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \ - metadataQuery.cmi paramodulation/indexing.cmi equalityTactics.cmi \ - paramodulation/equality.cmi automationCache.cmi autoTypes.cmi \ - autoCache.cmi auto.cmi -auto.cmx: paramodulation/utils.cmx universe.cmx paramodulation/subst.cmx \ - paramodulation/saturation.cmx proofEngineTypes.cmx \ - proofEngineReduction.cmx proofEngineHelpers.cmx primitiveTactics.cmx \ - metadataQuery.cmx paramodulation/indexing.cmx equalityTactics.cmx \ - paramodulation/equality.cmx automationCache.cmx autoTypes.cmx \ - autoCache.cmx auto.cmi -destructTactic.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \ - proofEngineStructuralRules.cmi proofEngineHelpers.cmi \ - primitiveTactics.cmi introductionTactics.cmi equalityTactics.cmi \ - eliminationTactics.cmi destructTactic.cmi -destructTactic.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \ - proofEngineStructuralRules.cmx proofEngineHelpers.cmx \ - primitiveTactics.cmx introductionTactics.cmx equalityTactics.cmx \ - eliminationTactics.cmx destructTactic.cmi -inversion.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \ - proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \ - equalityTactics.cmi inversion.cmi -inversion.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \ - proofEngineReduction.cmx proofEngineHelpers.cmx primitiveTactics.cmx \ - equalityTactics.cmx inversion.cmi -inversion_principle.cmo: tacticals.cmi proofEngineTypes.cmi \ - primitiveTactics.cmi inversion.cmi inversion_principle.cmi -inversion_principle.cmx: tacticals.cmx proofEngineTypes.cmx \ - primitiveTactics.cmx inversion.cmx inversion_principle.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 -setoids.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \ - primitiveTactics.cmi equalityTactics.cmi setoids.cmi -setoids.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \ - primitiveTactics.cmx equalityTactics.cmx setoids.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 setoids.cmi ring.cmi \ - reductionTactics.cmi proofEngineStructuralRules.cmi primitiveTactics.cmi \ - negationTactics.cmi inversion.cmi introductionTactics.cmi \ - fwdSimplTactic.cmi fourierR.cmi equalityTactics.cmi \ - eliminationTactics.cmi destructTactic.cmi compose.cmi \ - closeCoercionGraph.cmi auto.cmi tactics.cmi -tactics.cmx: variousTactics.cmx tacticals.cmx setoids.cmx ring.cmx \ - reductionTactics.cmx proofEngineStructuralRules.cmx primitiveTactics.cmx \ - negationTactics.cmx inversion.cmx introductionTactics.cmx \ - fwdSimplTactic.cmx fourierR.cmx equalityTactics.cmx \ - eliminationTactics.cmx destructTactic.cmx compose.cmx \ - closeCoercionGraph.cmx auto.cmx tactics.cmi -declarative.cmo: tactics.cmi tacticals.cmi proofEngineTypes.cmi auto.cmi \ - declarative.cmi -declarative.cmx: tactics.cmx tacticals.cmx proofEngineTypes.cmx auto.cmx \ - declarative.cmi diff --git a/matita/components/tactics/.depend.opt b/matita/components/tactics/.depend.opt deleted file mode 100644 index d9d6034a1..000000000 --- a/matita/components/tactics/.depend.opt +++ /dev/null @@ -1,229 +0,0 @@ -proofEngineTypes.cmi: -proofEngineHelpers.cmi: proofEngineTypes.cmi -proofEngineReduction.cmi: -continuationals.cmi: proofEngineTypes.cmi -tacticals.cmi: proofEngineTypes.cmi -reductionTactics.cmi: proofEngineTypes.cmi -proofEngineStructuralRules.cmi: proofEngineTypes.cmi -primitiveTactics.cmi: proofEngineTypes.cmi -hashtbl_equiv.cmi: -metadataQuery.cmi: proofEngineTypes.cmi -universe.cmi: -autoTypes.cmi: proofEngineTypes.cmi -autoCache.cmi: -paramodulation/utils.cmi: -closeCoercionGraph.cmi: -paramodulation/subst.cmi: -paramodulation/equality.cmi: paramodulation/utils.cmi \ - paramodulation/subst.cmi -paramodulation/founif.cmi: paramodulation/subst.cmi -paramodulation/equality_indexing.cmi: paramodulation/utils.cmi \ - paramodulation/equality.cmi -paramodulation/indexing.cmi: paramodulation/utils.cmi \ - paramodulation/subst.cmi paramodulation/equality_indexing.cmi \ - paramodulation/equality.cmi -paramodulation/saturation.cmi: paramodulation/utils.cmi proofEngineTypes.cmi \ - paramodulation/indexing.cmi paramodulation/equality.cmi -automationCache.cmi: universe.cmi paramodulation/saturation.cmi \ - paramodulation/equality.cmi -variousTactics.cmi: proofEngineTypes.cmi -compose.cmi: proofEngineTypes.cmi -introductionTactics.cmi: proofEngineTypes.cmi -eliminationTactics.cmi: proofEngineTypes.cmi -negationTactics.cmi: proofEngineTypes.cmi -equalityTactics.cmi: proofEngineTypes.cmi -auto.cmi: proofEngineTypes.cmi automationCache.cmi -destructTactic.cmi: proofEngineTypes.cmi -inversion.cmi: proofEngineTypes.cmi -inversion_principle.cmi: -ring.cmi: proofEngineTypes.cmi -setoids.cmi: proofEngineTypes.cmi -fourier.cmi: -fourierR.cmi: proofEngineTypes.cmi -fwdSimplTactic.cmi: proofEngineTypes.cmi -history.cmi: -statefulProofEngine.cmi: proofEngineTypes.cmi -tactics.cmi: tacticals.cmi proofEngineTypes.cmi automationCache.cmi auto.cmi -declarative.cmi: proofEngineTypes.cmi automationCache.cmi auto.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 \ - proofEngineStructuralRules.cmi proofEngineReduction.cmi \ - proofEngineHelpers.cmi primitiveTactics.cmi -primitiveTactics.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \ - proofEngineStructuralRules.cmx proofEngineReduction.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 -universe.cmo: proofEngineTypes.cmi proofEngineReduction.cmi universe.cmi -universe.cmx: proofEngineTypes.cmx proofEngineReduction.cmx universe.cmi -autoTypes.cmo: autoTypes.cmi -autoTypes.cmx: autoTypes.cmi -autoCache.cmo: universe.cmi autoCache.cmi -autoCache.cmx: universe.cmx autoCache.cmi -paramodulation/utils.cmo: proofEngineReduction.cmi paramodulation/utils.cmi -paramodulation/utils.cmx: proofEngineReduction.cmx paramodulation/utils.cmi -closeCoercionGraph.cmo: closeCoercionGraph.cmi -closeCoercionGraph.cmx: closeCoercionGraph.cmi -paramodulation/subst.cmo: paramodulation/subst.cmi -paramodulation/subst.cmx: paramodulation/subst.cmi -paramodulation/equality.cmo: paramodulation/utils.cmi \ - paramodulation/subst.cmi proofEngineTypes.cmi proofEngineReduction.cmi \ - paramodulation/equality.cmi -paramodulation/equality.cmx: paramodulation/utils.cmx \ - paramodulation/subst.cmx proofEngineTypes.cmx proofEngineReduction.cmx \ - paramodulation/equality.cmi -paramodulation/founif.cmo: paramodulation/utils.cmi paramodulation/subst.cmi \ - paramodulation/founif.cmi -paramodulation/founif.cmx: paramodulation/utils.cmx paramodulation/subst.cmx \ - paramodulation/founif.cmi -paramodulation/equality_indexing.cmo: paramodulation/utils.cmi \ - paramodulation/equality.cmi paramodulation/equality_indexing.cmi -paramodulation/equality_indexing.cmx: paramodulation/utils.cmx \ - paramodulation/equality.cmx paramodulation/equality_indexing.cmi -paramodulation/indexing.cmo: paramodulation/utils.cmi \ - paramodulation/subst.cmi proofEngineTypes.cmi paramodulation/founif.cmi \ - paramodulation/equality_indexing.cmi paramodulation/equality.cmi \ - paramodulation/indexing.cmi -paramodulation/indexing.cmx: paramodulation/utils.cmx \ - paramodulation/subst.cmx proofEngineTypes.cmx paramodulation/founif.cmx \ - paramodulation/equality_indexing.cmx paramodulation/equality.cmx \ - paramodulation/indexing.cmi -paramodulation/saturation.cmo: paramodulation/utils.cmi \ - paramodulation/subst.cmi proofEngineTypes.cmi proofEngineHelpers.cmi \ - paramodulation/indexing.cmi paramodulation/founif.cmi \ - paramodulation/equality.cmi paramodulation/saturation.cmi -paramodulation/saturation.cmx: paramodulation/utils.cmx \ - paramodulation/subst.cmx proofEngineTypes.cmx proofEngineHelpers.cmx \ - paramodulation/indexing.cmx paramodulation/founif.cmx \ - paramodulation/equality.cmx paramodulation/saturation.cmi -automationCache.cmo: universe.cmi paramodulation/saturation.cmi \ - paramodulation/equality.cmi automationCache.cmi -automationCache.cmx: universe.cmx paramodulation/saturation.cmx \ - paramodulation/equality.cmx automationCache.cmi -variousTactics.cmo: proofEngineTypes.cmi primitiveTactics.cmi \ - variousTactics.cmi -variousTactics.cmx: proofEngineTypes.cmx primitiveTactics.cmx \ - variousTactics.cmi -compose.cmo: proofEngineTypes.cmi primitiveTactics.cmi closeCoercionGraph.cmi \ - compose.cmi -compose.cmx: proofEngineTypes.cmx primitiveTactics.cmx closeCoercionGraph.cmx \ - compose.cmi -introductionTactics.cmo: proofEngineTypes.cmi primitiveTactics.cmi \ - introductionTactics.cmi -introductionTactics.cmx: proofEngineTypes.cmx primitiveTactics.cmx \ - introductionTactics.cmi -eliminationTactics.cmo: tacticals.cmi reductionTactics.cmi \ - proofEngineTypes.cmi proofEngineStructuralRules.cmi \ - proofEngineHelpers.cmi primitiveTactics.cmi eliminationTactics.cmi -eliminationTactics.cmx: tacticals.cmx reductionTactics.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 -auto.cmo: paramodulation/utils.cmi universe.cmi paramodulation/subst.cmi \ - paramodulation/saturation.cmi proofEngineTypes.cmi \ - proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \ - metadataQuery.cmi paramodulation/indexing.cmi equalityTactics.cmi \ - paramodulation/equality.cmi automationCache.cmi autoTypes.cmi \ - autoCache.cmi auto.cmi -auto.cmx: paramodulation/utils.cmx universe.cmx paramodulation/subst.cmx \ - paramodulation/saturation.cmx proofEngineTypes.cmx \ - proofEngineReduction.cmx proofEngineHelpers.cmx primitiveTactics.cmx \ - metadataQuery.cmx paramodulation/indexing.cmx equalityTactics.cmx \ - paramodulation/equality.cmx automationCache.cmx autoTypes.cmx \ - autoCache.cmx auto.cmi -destructTactic.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \ - proofEngineStructuralRules.cmi proofEngineHelpers.cmi \ - primitiveTactics.cmi introductionTactics.cmi equalityTactics.cmi \ - eliminationTactics.cmi destructTactic.cmi -destructTactic.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \ - proofEngineStructuralRules.cmx proofEngineHelpers.cmx \ - primitiveTactics.cmx introductionTactics.cmx equalityTactics.cmx \ - eliminationTactics.cmx destructTactic.cmi -inversion.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \ - proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \ - equalityTactics.cmi inversion.cmi -inversion.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \ - proofEngineReduction.cmx proofEngineHelpers.cmx primitiveTactics.cmx \ - equalityTactics.cmx inversion.cmi -inversion_principle.cmo: tacticals.cmi proofEngineTypes.cmi \ - primitiveTactics.cmi inversion.cmi inversion_principle.cmi -inversion_principle.cmx: tacticals.cmx proofEngineTypes.cmx \ - primitiveTactics.cmx inversion.cmx inversion_principle.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 -setoids.cmo: tacticals.cmi reductionTactics.cmi proofEngineTypes.cmi \ - primitiveTactics.cmi equalityTactics.cmi setoids.cmi -setoids.cmx: tacticals.cmx reductionTactics.cmx proofEngineTypes.cmx \ - primitiveTactics.cmx equalityTactics.cmx setoids.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 setoids.cmi ring.cmi \ - reductionTactics.cmi proofEngineStructuralRules.cmi primitiveTactics.cmi \ - negationTactics.cmi inversion.cmi introductionTactics.cmi \ - fwdSimplTactic.cmi fourierR.cmi equalityTactics.cmi \ - eliminationTactics.cmi destructTactic.cmi compose.cmi \ - closeCoercionGraph.cmi auto.cmi tactics.cmi -tactics.cmx: variousTactics.cmx tacticals.cmx setoids.cmx ring.cmx \ - reductionTactics.cmx proofEngineStructuralRules.cmx primitiveTactics.cmx \ - negationTactics.cmx inversion.cmx introductionTactics.cmx \ - fwdSimplTactic.cmx fourierR.cmx equalityTactics.cmx \ - eliminationTactics.cmx destructTactic.cmx compose.cmx \ - closeCoercionGraph.cmx auto.cmx tactics.cmi -declarative.cmo: tactics.cmi tacticals.cmi proofEngineTypes.cmi auto.cmi \ - declarative.cmi -declarative.cmx: tactics.cmx tacticals.cmx proofEngineTypes.cmx auto.cmx \ - declarative.cmi diff --git a/matita/components/tactics/Makefile b/matita/components/tactics/Makefile deleted file mode 100644 index ecc21a5db..000000000 --- a/matita/components/tactics/Makefile +++ /dev/null @@ -1,62 +0,0 @@ -PACKAGE = tactics - -INTERFACE_FILES = \ - proofEngineTypes.mli \ - proofEngineHelpers.mli proofEngineReduction.mli \ - continuationals.mli \ - tacticals.mli reductionTactics.mli proofEngineStructuralRules.mli \ - primitiveTactics.mli hashtbl_equiv.mli metadataQuery.mli \ - universe.mli \ - autoTypes.mli \ - autoCache.mli \ - paramodulation/utils.mli \ - closeCoercionGraph.mli \ - paramodulation/subst.mli \ - paramodulation/equality.mli\ - paramodulation/founif.mli\ - paramodulation/equality_indexing.mli\ - paramodulation/indexing.mli \ - paramodulation/saturation.mli \ - automationCache.mli \ - variousTactics.mli \ - compose.mli \ - introductionTactics.mli eliminationTactics.mli negationTactics.mli \ - equalityTactics.mli \ - auto.mli \ - destructTactic.mli \ - inversion.mli inversion_principle.mli ring.mli setoids.mli \ - fourier.mli fourierR.mli fwdSimplTactic.mli history.mli \ - statefulProofEngine.mli tactics.mli declarative.mli - -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) - - -all: - -# we omit dependencies since it is a pain when distributing -tactics_mli_deps = tactics.ml *Tactics.mli *Tactic.mli fourierR.mli ring.mli paramodulation/indexing.mli -tactics.mli: tactics.ml - $(H)echo " OCAMLC -i $$(tactics_mli_deps) > $@" - $(H)echo "(* GENERATED FILE, DO NOT EDIT. STAMP:`date` *)" > $@ - $(H)$(OCAMLC) -I paramodulation -i tactics.ml >> $@ - -UTF8DIR = $(shell $(OCAMLFIND) query helm-syntax_extensions) -STR=$(shell $(OCAMLFIND) query str) -MY_SYNTAXOPTIONS = -pp "camlp5o -I $(UTF8DIR) -I $(STR) str.cma pa_extend.cmo profiling_macros.cma -loc loc" -paramodulation/%.cmo: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -paramodulation/%.cmo: OCAMLC = $(OCAMLC_P4) -paramodulation/%.cmx: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -paramodulation/%.cmx: OCAMLOPT = $(OCAMLOPT_P4) - -depend: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) -depend.opt: SYNTAXOPTIONS = $(MY_SYNTAXOPTIONS) - -STATS_EXCLUDE = tactics.mli - -include ../../Makefile.defs -include ../Makefile.common - -OCAMLOPTIONS+= -I paramodulation -OCAMLDEPOPTIONS+= -I paramodulation -#PREPROCOPTIONS:= -#OCAML_PROF=p -p a diff --git a/matita/components/tactics/auto.ml b/matita/components/tactics/auto.ml deleted file mode 100644 index a89bbd4a1..000000000 --- a/matita/components/tactics/auto.ml +++ /dev/null @@ -1,2186 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -open AutoTypes;; -open AutoCache;; - -let debug = false;; -let debug_print s = - if debug then prerr_endline (Lazy.force s);; - - -let mk_irl ctx = CicMkImplicit.identity_relocation_list_for_metavariable ctx;; -let ugraph = CicUniv.oblivion_ugraph;; -let typeof = CicTypeChecker.type_of_aux';; -let ppterm ctx t = - let names = List.map (function None -> None | Some (x,_) -> Some x) ctx in - CicPp.pp t names -;; - -let is_propositional context sort = - match CicReduction.whd context sort with - | Cic.Sort Cic.Prop - | Cic.Sort (Cic.CProp _) -> true - | _-> false -;; - -let is_in_prop context subst metasenv ty = - let sort,u = typeof ~subst metasenv context ty CicUniv.oblivion_ugraph in - is_propositional context sort -;; - -exception NotConvertible;; - -let check_proof_is_valid proof metasenv context goalty = - if debug then - begin - try - let ty,u = typeof metasenv context proof CicUniv.oblivion_ugraph in - let b,_ = CicReduction.are_convertible context ty goalty u in - if not b then raise NotConvertible else b - with _ -> - let names = - List.map (function None -> None | Some (x,_) -> Some x) context - in - debug_print (lazy ("PROOF:" ^ CicPp.pp proof names)); - (* debug_print (lazy ("PROOFTY:" ^ CicPp.pp ty names)); *) - debug_print (lazy ("GOAL:" ^ CicPp.pp goalty names)); - debug_print (lazy ("MENV:" ^ CicMetaSubst.ppmetasenv [] metasenv)); - false - end - else true -;; - -let assert_proof_is_valid proof metasenv context goalty = - assert (check_proof_is_valid proof metasenv context goalty) -;; - -let assert_subst_are_disjoint subst subst' = - if debug then - assert(List.for_all - (fun (i,_) -> List.for_all (fun (j,_) -> i<>j) subst') - subst) - else () -;; - -let split_goals_in_prop metasenv subst gl = - List.partition - (fun g -> - let _,context,ty = CicUtil.lookup_meta g metasenv in - try - let sort,u = typeof ~subst metasenv context ty ugraph in - is_propositional context sort - with - | CicTypeChecker.AssertFailure s - | CicTypeChecker.TypeCheckerFailure s -> - debug_print - (lazy ("NON TIPA" ^ ppterm context (CicMetaSubst.apply_subst subst ty))); - debug_print s; - false) - (* FIXME... they should type! *) - gl -;; - -let split_goals_with_metas metasenv subst gl = - List.partition - (fun g -> - let _,context,ty = CicUtil.lookup_meta g metasenv in - let ty = CicMetaSubst.apply_subst subst ty in - CicUtil.is_meta_closed ty) - gl -;; - -let order_new_goals metasenv subst open_goals ppterm = - let prop,rest = split_goals_in_prop metasenv subst open_goals in - let closed_prop, open_prop = split_goals_with_metas metasenv subst prop in - let closed_type, open_type = split_goals_with_metas metasenv subst rest in - let open_goals = - (List.map (fun x -> x,P) (open_prop @ closed_prop)) - @ - (List.map (fun x -> x,T) (open_type @ closed_type)) - in - let tys = - List.map - (fun (i,sort) -> - let _,_,ty = CicUtil.lookup_meta i metasenv in i,ty,sort) open_goals - in - debug_print (lazy (" OPEN: "^ - String.concat "\n" - (List.map - (function - | (i,t,P) -> string_of_int i ^ ":"^ppterm t^ "Prop" - | (i,t,T) -> string_of_int i ^ ":"^ppterm t^ "Type") - tys))); - open_goals -;; - -let is_an_equational_goal = function - | Cic.Appl [Cic.MutInd(u,_,_);_;_;_] when LibraryObjects.is_eq_URI u -> true - | _ -> false -;; - -type auto_params = Cic.term list option * (string * string) list - -let elems = ref [] ;; - -(* closing a term w.r.t. its metavariables - very naif version: it does not take dependencies properly into account *) - -let naif_closure ?(prefix_name="xxx_") t metasenv context = - let in_term t (i,_,_) = - List.exists (fun (j,_) -> j=i) (CicUtil.metas_of_term t) - in - let metasenv = List.filter (in_term t) metasenv in - let metasenv = ProofEngineHelpers.sort_metasenv metasenv in - let n = List.length metasenv in - let what = List.map (fun (i,cc,ty) -> Cic.Meta(i,[])) metasenv in - let _,with_what = - List.fold_left - (fun (i,acc) (_,cc,ty) -> (i-1,Cic.Rel i::acc)) - (n,[]) metasenv - in - let t = CicSubstitution.lift n t in - let body = - ProofEngineReduction.replace_lifting - ~equality:(fun c t1 t2 -> - match t1,t2 with - | Cic.Meta(i,_),Cic.Meta(j,_) -> i = j - | _ -> false) - ~context ~what ~with_what ~where:t - in - let _, t = - List.fold_left - (fun (n,t) (_,cc,ty) -> - n-1, Cic.Lambda(Cic.Name (prefix_name^string_of_int n), - CicSubstitution.lift n ty,t)) - (n-1,body) metasenv - in - t, List.length metasenv -;; - -let lambda_close ?prefix_name t menv ctx = - let t, num_lambdas = naif_closure ?prefix_name t menv ctx in - List.fold_left - (fun (t,i) -> function - | None -> CicSubstitution.subst (Cic.Implicit None) t,i (* delift *) - | Some (name, Cic.Decl ty) -> Cic.Lambda (name, ty, t),i+1 - | Some (name, Cic.Def (bo, ty)) -> Cic.LetIn (name, bo, ty, t),i+1) - (t,num_lambdas) ctx -;; - -(* functions for retrieving theorems *) - - -exception FillingFailure of AutoCache.cache * AutomationCache.tables - -let rec unfold context = function - | Cic.Prod(name,s,t) -> - let t' = unfold ((Some (name,Cic.Decl s))::context) t in - Cic.Prod(name,s,t') - | t -> ProofEngineReduction.unfold context t - -let find_library_theorems dbd proof goal = - let univ = MetadataQuery.universe_of_goal ~dbd false proof goal in - let terms = List.map CicUtil.term_of_uri univ in - List.map - (fun t -> - (t,fst(CicTypeChecker.type_of_aux' [] [] t CicUniv.oblivion_ugraph))) - terms - -let find_context_theorems context metasenv = - let l,_ = - List.fold_left - (fun (res,i) ctxentry -> - match ctxentry with - | Some (_,Cic.Decl t) -> - (Cic.Rel i, CicSubstitution.lift i t)::res,i+1 - | Some (_,Cic.Def (_,t)) -> - (Cic.Rel i, CicSubstitution.lift i t)::res,i+1 - | None -> res,i+1) - ([],1) context - in l - -let rec is_an_equality = function - | Cic.Appl [Cic.MutInd (uri, _, _); _; _; _] - when (LibraryObjects.is_eq_URI uri) -> true - | Cic.Prod (_, _, t) -> is_an_equality t - | _ -> false -;; - -let partition_equalities = - List.partition (fun (_,ty) -> is_an_equality ty) - - -let default_auto tables _ cache _ _ _ _ = [],cache,tables ;; - -(* giusto per provare che succede -let is_unit_equation context metasenv oldnewmeta term = - let head, metasenv, args, newmeta = - TermUtil.saturate_term oldnewmeta metasenv context term 0 - in - let newmetas = - List.filter (fun (i,_,_) -> i >= oldnewmeta) metasenv - in - Some (args,metasenv,newmetas,head,newmeta) *) - -let is_unit_equation context metasenv oldnewmeta term = - let head, metasenv, args, newmeta = - TermUtil.saturate_term oldnewmeta metasenv context term 0 - in - let propositional_args = - HExtlib.filter_map - (function - | Cic.Meta(i,_) -> - let _,_,mt = CicUtil.lookup_meta i metasenv in - let sort,u = - CicTypeChecker.type_of_aux' metasenv context mt - CicUniv.oblivion_ugraph - in - if is_propositional context sort then Some i else None - | _ -> assert false) - args - in - if propositional_args = [] then - let newmetas = - List.filter (fun (i,_,_) -> i >= oldnewmeta) metasenv - in - Some (args,metasenv,newmetas,head,newmeta) - else None -;; - -let get_candidates skip_trie_filtering universe cache t = - let t = if skip_trie_filtering then Cic.Meta(0,[]) else t in - let candidates= - (Universe.get_candidates universe t)@(AutoCache.get_candidates cache t) - in - let debug_msg = - (lazy ("candidates for " ^ (CicPp.ppterm t) ^ " = " ^ - (String.concat "\n" (List.map CicPp.ppterm candidates)))) in - debug_print debug_msg; - candidates -;; - -let only signature context metasenv t = - try - let ty,_ = - CicTypeChecker.type_of_aux' metasenv context t CicUniv.oblivion_ugraph - in - let consts = MetadataConstraints.constants_of ty in - let b = MetadataConstraints.UriManagerSet.subset consts signature in -(* if b then (prerr_endline ("keeping " ^ (CicPp.ppterm t)); b) *) - if b then b - else - let ty' = unfold context ty in - let consts' = MetadataConstraints.constants_of ty' in - let b = MetadataConstraints.UriManagerSet.subset consts' signature in -(* - if not b then prerr_endline ("filtering " ^ (CicPp.ppterm t)) - else prerr_endline ("keeping " ^ (CicPp.ppterm t)); -*) - b - with - | CicTypeChecker.TypeCheckerFailure _ -> assert false - | ProofEngineTypes.Fail _ -> false (* unfold may fail *) -;; - -let not_default_eq_term t = - try - let uri = CicUtil.uri_of_term t in - not (LibraryObjects.in_eq_URIs uri) - with Invalid_argument _ -> true - -let retrieve_equations dont_filter signature universe cache context metasenv = - match LibraryObjects.eq_URI() with - | None -> [] - | Some eq_uri -> - let eq_uri = UriManager.strip_xpointer eq_uri in - let fake= Cic.Meta(-1,[]) in - let fake_eq = Cic.Appl [Cic.MutInd (eq_uri,0, []);fake;fake;fake] in - let candidates = get_candidates false universe cache fake_eq in - if dont_filter then candidates - else let eq_uri = UriManager.uri_of_uriref eq_uri 0 None in - (* let candidates = List.filter not_default_eq_term candidates in *) - List.filter - (only (MetadataConstraints.UriManagerSet.add eq_uri signature) - context metasenv) candidates - -let build_equality bag head args proof newmetas = - match head with - | Cic.Appl [Cic.MutInd (uri, _, _); ty; t1; t2] -> - let p = - if args = [] then proof else Cic.Appl (proof::args) - in - let o = !Utils.compare_terms t1 t2 in - let stat = (ty,t1,t2,o) in - (* let w = compute_equality_weight stat in *) - let w = 0 in - let proof = Equality.Exact p in - let bag, e = Equality.mk_equality bag (w, proof, stat, newmetas) in - (* to clean the local context of metas *) - Equality.fix_metas bag e - | _ -> assert false -;; - -let partition_unit_equalities context metasenv newmeta bag equations = - List.fold_left - (fun (bag,units,other,maxmeta)(t,ty) -> - if not (CicUtil.is_meta_closed t && CicUtil.is_meta_closed ty) then - let _ = - HLog.warn - ("Skipping " ^ CicMetaSubst.ppterm_in_context ~metasenv [] t context - ^ " since it is not meta closed") - in - bag, units,(t,ty)::other,maxmeta - else - match is_unit_equation context metasenv maxmeta ty with - | Some (args,metasenv,newmetas,head,newmeta') -> - let bag, equality = - build_equality bag head args t newmetas in - bag, equality::units,other,maxmeta - | None -> - bag, units,(t,ty)::other,maxmeta) - (bag,[],[],newmeta) equations -;; - -let init_cache_and_tables - ?dbd ~use_library ~use_context - automation_cache restricted_univ (proof, goal) -= - let _, metasenv, subst, _, _, _ = proof in - let _,context,_ = CicUtil.lookup_meta goal metasenv in - let add_list_to_tables metasenv subst automation_cache ct = - List.fold_left - (fun automation_cache (t,_) -> - AutomationCache.add_term_to_active automation_cache - metasenv subst context t None) - automation_cache ct - in - match restricted_univ with - | None -> - let ct = - if use_context then find_context_theorems context metasenv else [] - in - let lt = - match use_library, dbd with - | true, Some dbd -> find_library_theorems dbd metasenv goal - | _ -> [] - in - let cache = AutoCache.cache_empty in - let cache = cache_add_list cache context (ct@lt) in - let automation_cache = - add_list_to_tables metasenv subst automation_cache ct - in -(* AutomationCache.pp_cache automation_cache; *) - automation_cache.AutomationCache.univ, - automation_cache.AutomationCache.tables, - cache - | Some restricted_univ -> - let t_ty = - List.map - (fun t -> - let ty, _ = CicTypeChecker.type_of_aux' - metasenv ~subst:[] context t CicUniv.oblivion_ugraph - in - t, ty) - restricted_univ - in - (* let automation_cache = AutomationCache.empty () in *) - let automation_cache = - let universe = Universe.empty in - let universe = - Universe.index_list universe context t_ty - in - { automation_cache with AutomationCache.univ = universe } - in - let ct = - if use_context then find_context_theorems context metasenv else t_ty - in - let automation_cache = - add_list_to_tables metasenv subst automation_cache ct - in - (* AutomationCache.pp_cache automation_cache; *) - automation_cache.AutomationCache.univ, - automation_cache.AutomationCache.tables, - cache_empty -;; - -let fill_hypothesis context metasenv subst term tables (universe:Universe.universe) cache auto fast = - let actives, passives, bag = tables in - let bag, head, metasenv, args = - Equality.saturate_term bag metasenv subst context term - in - let tables = actives, passives, bag in - let propositional_args = - HExtlib.filter_map - (function - | Cic.Meta(i,_) -> - let _,_,mt = CicUtil.lookup_meta i metasenv in - let sort,u = - CicTypeChecker.type_of_aux' metasenv context mt - CicUniv.oblivion_ugraph - in - if is_propositional context sort then Some i else None - | _ -> assert false) - args - in - let results,cache,tables = - if propositional_args = [] then - let _,_,bag = tables in - let newmetas = Equality.filter_metasenv_gt_maxmeta bag metasenv in - [args,metasenv,newmetas,head],cache,tables - else - (* - let proof = - None,metasenv,term,term (* term non e' significativo *) - in *) - let flags = - if fast then - {AutoTypes.default_flags() with - AutoTypes.timeout = Unix.gettimeofday() +. 1.0; - maxwidth = 2;maxdepth = 2; - use_paramod=true;use_only_paramod=false} - else - {AutoTypes.default_flags() with - AutoTypes.timeout = Unix.gettimeofday() +. 1.0; - maxwidth = 2;maxdepth = 4; - use_paramod=true;use_only_paramod=false} - in - match auto tables universe cache context metasenv propositional_args flags with - | [],cache,tables -> raise (FillingFailure (cache,tables)) - | substs,cache,tables -> - let actives, passaives, bag = tables in - let bag, res = - List.fold_right - (fun subst (bag,acc) -> - let metasenv = - CicMetaSubst.apply_subst_metasenv subst metasenv - in - let head = CicMetaSubst.apply_subst subst head in - let newmetas = Equality.filter_metasenv_gt_maxmeta bag metasenv in - let args = List.map (CicMetaSubst.apply_subst subst) args in - let newm = CicMkImplicit.new_meta metasenv subst in - let bag = Equality.push_maxmeta bag newm in - bag, ((args,metasenv,newmetas,head) :: acc)) - substs (bag,[]) - in - let tables = actives, passives, bag in - res, cache, tables - in - results,cache,tables -;; - -let build_equalities auto context metasenv subst tables universe cache equations = - List.fold_left - (fun (tables,facts,cache) (t,ty) -> - (* in any case we add the equation to the cache *) - let cache = AutoCache.cache_add_list cache context [(t,ty)] in - try - let saturated, cache, tables = - fill_hypothesis context metasenv subst ty tables universe cache auto true - in - let eqs, tables = - List.fold_left - (fun (acc, tables) (args,metasenv,newmetas,head) -> - let actives, passives, bag = tables in - let bag, equality = - build_equality bag head args t newmetas - in - let tables = actives, passives, bag in - equality::acc,tables) - ([],tables) saturated - in - (tables, eqs@facts, cache) - with FillingFailure (cache,tables) -> - (* if filling hypothesis fails we add the equation to - the cache *) - (tables,facts,cache) - ) - (tables,[],cache) equations - -let close_more tables context status auto signature universe cache = - let proof, goalno = status in - let _, metasenv,subst,_,_, _ = proof in - let equations = - retrieve_equations false signature universe cache context metasenv - in - let eqs_and_types = - HExtlib.filter_map - (fun t -> - let ty,_ = - CicTypeChecker.type_of_aux' metasenv context t - CicUniv.oblivion_ugraph in - (* retrieve_equations could also return flexible terms *) - if is_an_equality ty then Some(t,ty) else None) - equations in - let tables, units, cache = - build_equalities auto context metasenv subst tables universe cache eqs_and_types - in - let active,passive,bag = tables in - let passive = Saturation.add_to_passive units passive in - let no = List.length units in - let active, passive, bag = - Saturation.pump_actives context bag active passive (no+1) infinity - in - (active,passive,bag), cache -;; - -let find_context_equalities dbd tables context proof (universe:Universe.universe) cache -= - let module C = Cic in - let module S = CicSubstitution in - let module T = CicTypeChecker in - let _,metasenv,subst,_,_, _ = proof in - (* if use_auto is true, we try to close the hypothesis of equational - statements using auto; a naif, and probably wrong approach *) - let rec aux tables cache index = function - | [] -> tables, [], cache - | (Some (_, C.Decl (term)))::tl -> - debug_print - (lazy - (Printf.sprintf "Examining: %d (%s)" index (CicPp.ppterm term))); - let do_find tables context term = - match term with - | C.Prod (name, s, t) when is_an_equality t -> - (try - let term = S.lift index term in - let saturated, cache, tables = - fill_hypothesis context metasenv subst term - tables universe cache default_auto false - in - let actives, passives, bag = tables in - let bag,eqs = - List.fold_left - (fun (bag,acc) (args,metasenv,newmetas,head) -> - let bag, equality = - build_equality bag head args (Cic.Rel index) newmetas - in - bag, equality::acc) - (bag,[]) saturated - in - let tables = actives, passives, bag in - tables, eqs, cache - with FillingFailure (cache,tables) -> - tables, [], cache) - | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] - when LibraryObjects.is_eq_URI uri -> - let term = S.lift index term in - let actives, passives, bag = tables in - let bag, e = - build_equality bag term [] (Cic.Rel index) [] - in - let tables = actives, passives, bag in - tables, [e], cache - | _ -> tables, [], cache - in - let tables, eqs, cache = do_find tables context term in - let tables, rest, cache = aux tables cache (index+1) tl in - tables, List.map (fun x -> index,x) eqs @ rest, cache - | _::tl -> - aux tables cache (index+1) tl - in - let tables, il, cache = aux tables cache 1 context in - let indexes, equalities = List.split il in - tables, indexes, equalities, cache -;; - -(********** PARAMETERS PASSING ***************) - -let bool params name default = - try - let s = List.assoc name params in - if s = "" || s = "1" || s = "true" || s = "yes" || s = "on" then true - else if s = "0" || s = "false" || s = "no" || s= "off" then false - else - let msg = "Unrecognized value for parameter "^name^"\n" in - let msg = msg^"Accepted values are 1,true,yes,on and 0,false,no,off" in - raise (ProofEngineTypes.Fail (lazy msg)) - with Not_found -> default -;; - -let string params name default = - try List.assoc name params with - | Not_found -> default -;; - -let int params name default = - try int_of_string (List.assoc name params) with - | Not_found -> default - | Failure _ -> - raise (ProofEngineTypes.Fail (lazy (name ^ " must be an integer"))) -;; - -let flags_of_params params ?(for_applyS=false) () = - let int = int params in - let bool = bool params in - let close_more = bool "close_more" false in - let use_paramod = bool "use_paramod" true in - let skip_trie_filtering = bool "skip_trie_filtering" false in - let skip_context = bool "skip_context" false in - let use_only_paramod = - if for_applyS then true else bool "paramodulation" false in - let use_library = bool "library" - ((AutoTypes.default_flags()).AutoTypes.use_library) in - let depth = int "depth" ((AutoTypes.default_flags()).AutoTypes.maxdepth) in - let width = int "width" ((AutoTypes.default_flags()).AutoTypes.maxwidth) in - let size = int "size" ((AutoTypes.default_flags()).AutoTypes.maxsize) in - let gsize = int "gsize" ((AutoTypes.default_flags()).AutoTypes.maxgoalsizefactor) in - let do_type = bool "type" false in - let timeout = int "timeout" 0 in - { AutoTypes.maxdepth = - if use_only_paramod then 2 else depth; - AutoTypes.maxwidth = width; - AutoTypes.maxsize = size; - AutoTypes.timeout = - if timeout = 0 then - if for_applyS then Unix.gettimeofday () +. 30.0 - else - infinity - else - Unix.gettimeofday() +. (float_of_int timeout); - AutoTypes.use_library = use_library; - AutoTypes.use_paramod = use_paramod; - AutoTypes.use_only_paramod = use_only_paramod; - AutoTypes.close_more = close_more; - AutoTypes.dont_cache_failures = false; - AutoTypes.maxgoalsizefactor = gsize; - AutoTypes.do_types = do_type; - AutoTypes.skip_trie_filtering = skip_trie_filtering; - AutoTypes.skip_context = skip_context; - } - - -let eq_of_goal = function - | Cic.Appl [Cic.MutInd(uri,0,_);_;_;_] when LibraryObjects.is_eq_URI uri -> - uri - | _ -> raise (ProofEngineTypes.Fail (lazy ("The goal is not an equality "))) -;; - -(* performs steps of rewrite with the universe, obtaining if possible - * a trivial goal *) -let solve_rewrite ~automation_cache ~params:(univ,params) (proof,goal)= - let steps = int_of_string (string params "steps" "4") in - let use_context = bool params "use_context" true in - let universe, tables, cache = - init_cache_and_tables ~use_library:false ~use_context - automation_cache univ (proof,goal) - in - let actives, passives, bag = tables in - let pa,metasenv,subst,pb,pc,pd = proof in - let _,context,ty = CicUtil.lookup_meta goal metasenv in - let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in - let context = CicMetaSubst.apply_subst_context subst context in - let ty = CicMetaSubst.apply_subst subst ty in - let eq_uri = eq_of_goal ty in - let initgoal = [], metasenv, ty in - let table = - let equalities = (Saturation.list_of_passive passives) in - List.fold_left (fun tbl eq -> Indexing.index tbl eq) (snd actives) equalities - in - let env = metasenv,context,CicUniv.oblivion_ugraph in - debug_print (lazy ("demod to solve: " ^ CicPp.ppterm ty)); - match Indexing.solve_demodulating bag env table initgoal steps with - | Some (bag, gproof, metasenv, sub_subst, proof) -> - let subst_candidates,extra_infos = - List.split - (HExtlib.filter_map - (fun (i,c,_) -> - if i <> goal && c = context then Some (i,(c,ty)) else None) - metasenv) - in - let proofterm,proto_subst = - let proof = Equality.add_subst sub_subst proof in - Equality.build_goal_proof - bag eq_uri gproof proof ty subst_candidates context metasenv - in - let proofterm = Subst.apply_subst sub_subst proofterm in - let extrasubst = - HExtlib.filter_map - (fun (i,((c,ty),t)) -> - match t with - | Cic.Meta (j,_) when i=j -> None - | _ -> Some (i,(c,t,ty))) - (List.combine subst_candidates - (List.combine extra_infos proto_subst)) - in - let subst = subst @ extrasubst in - let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in - let proofterm, _, metasenv,subst, _ = - CicRefine.type_of metasenv subst context proofterm - CicUniv.oblivion_ugraph - in - let status = (pa,metasenv,subst,pb,pc,pd), goal in - ProofEngineTypes.apply_tactic - (PrimitiveTactics.apply_tac ~term:proofterm) status - | None -> - raise - (ProofEngineTypes.Fail (lazy - ("Unable to solve with " ^ string_of_int steps ^ " demodulations"))) -;; - -(* Demodulate thorem *) -let open_type ty bo = - let rec open_type_aux context ty k args = - match ty with - | Cic.Prod (n,s,t) -> - let n' = - FreshNamesGenerator.mk_fresh_name [] context n ~typ:s ~subst:[] in - let entry = match n' with - | Cic.Name _ -> Some (n',(Cic.Decl s)) - | Cic.Anonymous -> None - in - open_type_aux (entry::context) t (k+1) ((Cic.Rel k)::args) - | Cic.LetIn (n,s,sty,t) -> - let entry = Some (n,(Cic.Def (s,sty))) - in - open_type_aux (entry::context) t (k+1) args - | _ -> context, ty, args - in - let context, ty, args = open_type_aux [] ty 1 [] in - match args with - | [] -> context, ty, bo - | _ -> context, ty, Cic.Appl (bo::args) -;; - -let rec close_type bo ty context = - match context with - | [] -> assert_proof_is_valid bo [] [] ty; (bo,ty) - | Some (n,(Cic.Decl s))::tl -> - close_type (Cic.Lambda (n,s,bo)) (Cic.Prod (n,s,ty)) tl - | Some (n,(Cic.Def (s,sty)))::tl -> - close_type (Cic.LetIn (n,s,sty,bo)) (Cic.LetIn (n,s,sty,ty)) tl - | _ -> assert false -;; - -let is_subsumed univ context ty = - let candidates = Universe.get_candidates univ ty in - List.fold_left - (fun res cand -> - match res with - | Some found -> Some found - | None -> - try - let mk_irl = - CicMkImplicit.identity_relocation_list_for_metavariable in - let metasenv = [(0,context,ty)] in - let fake_proof = - None,metasenv,[] , (lazy (Cic.Meta(0,mk_irl context))),ty,[] - in - let (_,metasenv,subst,_,_,_), open_goals = - ProofEngineTypes.apply_tactic - (PrimitiveTactics.apply_tac ~term:cand) - (fake_proof,0) - in - let prop_goals, other = - split_goals_in_prop metasenv subst open_goals - in - if prop_goals = [] then Some cand else None - with - | ProofEngineTypes.Fail s -> None - | CicUnification.Uncertain s -> None - ) None candidates -;; - -let demodulate_theorem ~automation_cache uri = - let eq_uri = - match LibraryObjects.eq_URI () with - | Some (uri) -> uri - | None -> raise (ProofEngineTypes.Fail (lazy "equality not declared")) in - let obj,_ = CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - let context,ty,bo = - match obj with - | Cic.Constant(n, _, ty ,_, _) -> open_type ty (Cic.Const(uri,[])) - | _ -> raise (ProofEngineTypes.Fail (lazy "not a theorem")) - in - if CicUtil.is_closed ty then - raise (ProofEngineTypes.Fail (lazy ("closed term: dangerous reduction"))); - let initgoal = [], [], ty in - (* compute the signature *) - let signature = - let ty_set = MetadataConstraints.constants_of ty in - let hyp_set = MetadataQuery.signature_of_hypothesis context [] in - let set = MetadataConstraints.UriManagerSet.union ty_set hyp_set in - MetadataQuery.close_with_types set [] context - in - (* retrieve equations from the universe universe *) - (* XXX automation_cache *) - let universe = automation_cache.AutomationCache.univ in - let equations = - retrieve_equations true signature universe AutoCache.cache_empty context [] - in - debug_print - (lazy ("ho trovato equazioni n. "^(string_of_int (List.length equations)))); - let eqs_and_types = - HExtlib.filter_map - (fun t -> - let ty,_ = - CicTypeChecker.type_of_aux' [] context t CicUniv.oblivion_ugraph - in - (* retrieve_equations could also return flexible terms *) - if is_an_equality ty then Some(t,ty) - else - try - let ty' = unfold context ty in - if is_an_equality ty' then Some(t,ty') else None - with ProofEngineTypes.Fail _ -> None) - equations - in - let bag = Equality.mk_equality_bag () in - - let bag, units, _, newmeta = - partition_unit_equalities context [] (CicMkImplicit.new_meta [] []) bag eqs_and_types - in - let table = - List.fold_left - (fun tbl eq -> Indexing.index tbl eq) - Indexing.empty units - in - let changed,(newproof,newmetasenv, newty) = - Indexing.demod bag - ([],context,CicUniv.oblivion_ugraph) table initgoal in - if changed then - begin - let oldproof = Equality.Exact bo in - let proofterm,_ = - Equality.build_goal_proof (~contextualize:false) (~forward:true) bag - eq_uri newproof oldproof ty [] context newmetasenv - in - if newmetasenv <> [] then - raise (ProofEngineTypes.Fail (lazy ("metasenv not empty"))) - else - begin - assert_proof_is_valid proofterm newmetasenv context newty; - match is_subsumed universe context newty with - | Some t -> raise - (ProofEngineTypes.Fail (lazy ("subsumed by " ^ CicPp.ppterm t))) - | None -> close_type proofterm newty context - end - end - else (* if newty = ty then *) - raise (ProofEngineTypes.Fail (lazy "no progress")) - (*else ProofEngineTypes.apply_tactic - (ReductionTactics.simpl_tac - ~pattern:(ProofEngineTypes.conclusion_pattern None)) initialstatus*) -;; - - -(* NEW DEMODULATE *) -let demodulate ~dbd ~automation_cache ~params:(univ, params) (proof,goal)= - let universe, tables, cache = - init_cache_and_tables - ~dbd ~use_library:false ~use_context:true - automation_cache univ (proof,goal) - in - let eq_uri = - match LibraryObjects.eq_URI () with - | Some (uri) -> uri - | None -> raise (ProofEngineTypes.Fail (lazy "equality not declared")) in - let active, passive, bag = tables in - let curi,metasenv,subst,pbo,pty, attrs = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in - let initgoal = [], metasenv, ty in - let equalities = (Saturation.list_of_passive passive) in - (* we demodulate using both actives passives *) - let env = metasenv,context,CicUniv.empty_ugraph in - debug_print (lazy ("PASSIVES:" ^ string_of_int(List.length equalities))); - List.iter (fun e -> debug_print (lazy (Equality.string_of_equality ~env e))) - equalities; - let table = - List.fold_left - (fun tbl eq -> Indexing.index tbl eq) - (snd active) equalities - in - let changed,(newproof,newmetasenv, newty) = - (* Indexing.demodulation_goal bag *) - Indexing.demod bag - (metasenv,context,CicUniv.oblivion_ugraph) table initgoal - in - if changed then - begin - let maxm = CicMkImplicit.new_meta metasenv subst in - let opengoal = Equality.Exact (Cic.Meta(maxm,irl)) in - let subst_candidates = List.map (fun (i,_,_) -> i) metasenv in - let subst_candidates = List.filter (fun x-> x <> goal) subst_candidates in - let proofterm, proto_subst = - Equality.build_goal_proof (~contextualize:false) bag - eq_uri newproof opengoal ty subst_candidates context metasenv - in - (* XXX understan what to do with proto subst *) - let metasenv = (maxm,context,newty)::metasenv in - let proofterm, _, metasenv, subst, _ = - CicRefine.type_of metasenv subst context proofterm - CicUniv.oblivion_ugraph - in - let extended_status = (curi,metasenv,subst,pbo,pty, attrs),goal in - let proof,gl = - ProofEngineTypes.apply_tactic - (PrimitiveTactics.apply_tac ~term:proofterm) extended_status - in - proof,maxm::gl - end - else - raise (ProofEngineTypes.Fail (lazy "no progress")) -;; - -let demodulate_tac ~dbd ~params:(_,flags as params) ~automation_cache = - ProofEngineTypes.mk_tactic - (fun status -> - let all = bool flags "all" false in - if all then - solve_rewrite ~params ~automation_cache status - else - demodulate ~dbd ~params ~automation_cache status) -;; -(***************** applyS *******************) - -let apply_smart_aux - dbd automation_cache (params:auto_params) proof goal newmeta' metasenv' subst - context term' ty termty goal_arity -= - let consthead,newmetasenv,arguments,_ = - TermUtil.saturate_term newmeta' metasenv' context termty goal_arity in - let term'' = - match arguments with - | [] -> term' - | _ -> Cic.Appl (term'::arguments) - in - let consthead = - let rec aux t = function - | [] -> - let t = CicReduction.normalize ~delta:false context t in - (match t, ty with - | Cic.Appl (hd1::_), Cic.Appl (hd2::_) when hd1 <> hd2 -> - let t = ProofEngineReduction.unfold context t in - (match t with - | Cic.Appl (hd1'::_) when hd1' = hd2 -> t - | _ -> raise (ProofEngineTypes.Fail (lazy "incompatible head"))) - | _ -> t) - | arg :: tl -> - match CicReduction.whd context t with - | Cic.Prod (_,_,tgt) -> - aux (CicSubstitution.subst arg tgt) tl - | _ -> assert false - in - aux termty arguments - in - let goal_for_paramod = - match LibraryObjects.eq_URI () with - | Some uri -> - Cic.Appl [Cic.MutInd (uri,0,[]); Cic.Implicit (Some `Type); consthead; ty] - | None -> raise (ProofEngineTypes.Fail (lazy "No equality defined")) - in - try - let goal_for_paramod, _, newmetasenv, subst, _ = - CicRefine.type_of newmetasenv subst context goal_for_paramod - CicUniv.oblivion_ugraph - in - let newmeta = CicMkImplicit.new_meta newmetasenv subst in - let metasenv_for_paramod = (newmeta,context,goal_for_paramod)::newmetasenv in - let proof'' = - let uri,_,_,p,ty, attrs = proof in - uri,metasenv_for_paramod,subst,p,ty, attrs - in - let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in -(* - prerr_endline ("------ prima di rewrite su ------ " ^ string_of_int goal); - prerr_endline ("menv:\n"^CicMetaSubst.ppmetasenv [] metasenv_for_paramod); - prerr_endline ("subst:\n"^CicMetaSubst.ppsubst - ~metasenv:(metasenv_for_paramod) - subst); -*) - - let (proof''',goals) = - ProofEngineTypes.apply_tactic - (EqualityTactics.rewrite_tac ~direction:`RightToLeft - ~pattern:(ProofEngineTypes.conclusion_pattern None) - (Cic.Meta(newmeta,irl)) []) (proof'',goal) - in - let goal = match goals with [g] -> g | _ -> assert false in - let proof'''', _ = - ProofEngineTypes.apply_tactic - (PrimitiveTactics.apply_tac term'') - (proof''',goal) - in - - - let (_,m,_,_,_,_ as p) = - let pu,metasenv,subst,proof,px,py = proof'''' in - let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in - let proof'''' = pu,metasenv,subst,proof,px,py in - let univ, params = params in - let use_context = bool params "use_context" true in - let universe, (active,passive,bag), cache = - init_cache_and_tables ~use_library:false ~use_context - automation_cache univ (proof'''',newmeta) - in - match - Saturation.solve_narrowing bag (proof'''',newmeta) active passive - 2 (*0 infinity*) - with - | None, active, passive, bag -> - raise (ProofEngineTypes.Fail (lazy ("paramod fails"))) - | Some(subst',(pu,metasenv,_,proof,px, py),open_goals),active, - passive,bag -> - assert_subst_are_disjoint subst subst'; - let subst = subst@subst' in - pu,metasenv,subst,proof,px,py - in - -(* - let (_,m,_,_,_,_ as p),_ = - solve_rewrite ~params ~automation_cache (proof'''',newmeta) - in -*) - - let open_goals = - ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv' ~newmetasenv:m - in - p, open_goals - with - CicRefine.RefineFailure msg -> - raise (ProofEngineTypes.Fail msg) -;; - -let apply_smart - ~dbd ~term ~automation_cache ~params (proof, goal) -= - let module T = CicTypeChecker in - let module R = CicReduction in - let module C = Cic in - let (_,metasenv,subst,_,_, _) = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let newmeta = CicMkImplicit.new_meta metasenv subst 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 = - PrimitiveTactics.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 = - PrimitiveTactics.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 = - PrimitiveTactics.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 = - PrimitiveTactics.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' ~subst context term' CicUniv.oblivion_ugraph - in - let termty = CicSubstitution.subst_vars exp_named_subst_diff termty in - let goal_arity = - let rec count_prods context ty = - match CicReduction.whd ~subst context ty with - | Cic.Prod (n,s,t) -> 1 + count_prods (Some (n,Cic.Decl s)::context) t - | _ -> 0 - in - count_prods context ty - in - apply_smart_aux dbd automation_cache params proof goal - newmeta' metasenv' subst context term' ty termty goal_arity -;; - -let applyS_tac ~dbd ~term ~params ~automation_cache = - ProofEngineTypes.mk_tactic - (fun status -> - try - apply_smart ~dbd ~term ~params ~automation_cache status - with - | CicUnification.UnificationFailure msg - | CicTypeChecker.TypeCheckerFailure msg -> - raise (ProofEngineTypes.Fail msg)) -;; - - -(****************** AUTO ********************) - -let calculate_timeout flags = - if flags.timeout = 0. then - (debug_print (lazy "AUTO WITH NO TIMEOUT"); - {flags with timeout = infinity}) - else - flags -;; -let is_equational_case goalty flags = - let ensure_equational t = - if is_an_equational_goal t then true - else false - in - (flags.use_paramod && is_an_equational_goal goalty) || - (flags.use_only_paramod && ensure_equational goalty) -;; - -type menv = Cic.metasenv -type subst = Cic.substitution -type goal = ProofEngineTypes.goal * int * AutoTypes.sort -let candidate_no = ref 0;; -type candidate = int * Cic.term Lazy.t -type cache = AutoCache.cache - -type fail = - (* the goal (mainly for depth) and key of the goal *) - goal * AutoCache.cache_key -type op = - (* goal has to be proved *) - | D of goal - (* goal has to be cached as a success obtained using candidate as the first - * step *) - | S of goal * AutoCache.cache_key * candidate * int -type elem = - (* menv, subst, size, operations done (only S), operations to do, failures to cache if any op fails *) - menv * subst * int * op list * op list * fail list -type status = - (* list of computations that may lead to the solution: all op list will - * end with the same (S(g,_)) *) - elem list -type auto_result = - (* menv, subst, alternatives, tables, cache *) - | Proved of menv * subst * elem list * AutomationCache.tables * cache - | Gaveup of AutomationCache.tables * cache - - -(* the status exported to the external observer *) -type auto_status = - (* context, (goal,candidate) list, and_list, history *) - Cic.context * (int * Cic.term * bool * int * (int * Cic.term Lazy.t) list) list * - (int * Cic.term * int) list * Cic.term Lazy.t list - -let d_prefix l = - let rec aux acc = function - | (D g)::tl -> aux (acc@[g]) tl - | _ -> acc - in - aux [] l -;; -let prop_only l = - List.filter (function (_,_,P) -> true | _ -> false) l -;; - -let d_goals l = - let rec aux acc = function - | (D g)::tl -> aux (acc@[g]) tl - | (S _)::tl -> aux acc tl - | [] -> acc - in - aux [] l -;; - -let calculate_goal_ty (goalno,_,_) s m = - try - let _,cc,goalty = CicUtil.lookup_meta goalno m in - (* XXX applicare la subst al contesto? *) - Some (cc, CicMetaSubst.apply_subst s goalty) - with CicUtil.Meta_not_found i when i = goalno -> None -;; - -let calculate_closed_goal_ty (goalno,_,_) s = - try - let cc,_,goalty = List.assoc goalno s in - (* XXX applicare la subst al contesto? *) - Some (cc, CicMetaSubst.apply_subst s goalty) - with Not_found -> - None -;; - -let pp_status ctx status = - if debug then - let names = Utils.names_of_context ctx in - let pp x = - let x = - ProofEngineReduction.replace - ~equality:(fun a b -> match b with Cic.Meta _ -> true | _ -> false) - ~what:[Cic.Rel 1] ~with_what:[Cic.Implicit None] ~where:x - in - CicPp.pp x names - in - let string_of_do m s (gi,_,_ as g) d = - match calculate_goal_ty g s m with - | Some (_,gty) -> Printf.sprintf "D(%d, %s, %d)" gi (pp gty) d - | None -> Printf.sprintf "D(%d, _, %d)" gi d - in - let string_of_s m su k (ci,ct) gi = - Printf.sprintf "S(%d, %s, %s, %d)" gi (pp k) (pp (Lazy.force ct)) ci - in - let string_of_ol m su l = - String.concat " | " - (List.map - (function - | D (g,d,s) -> string_of_do m su (g,d,s) d - | S ((gi,_,_),k,c,_) -> string_of_s m su k c gi) - l) - in - let string_of_fl m s fl = - String.concat " | " - (List.map (fun ((i,_,_),ty) -> - Printf.sprintf "(%d, %s)" i (pp ty)) fl) - in - let rec aux = function - | [] -> () - | (m,s,_,_,ol,fl)::tl -> - Printf.eprintf "< [%s] ;;; [%s]>\n" - (string_of_ol m s ol) (string_of_fl m s fl); - aux tl - in - Printf.eprintf "-------------------------- status -------------------\n"; - aux status; - Printf.eprintf "-----------------------------------------------------\n"; -;; - -let auto_status = ref [] ;; -let auto_context = ref [];; -let in_pause = ref false;; -let pause b = in_pause := b;; -let cond = Condition.create ();; -let mutex = Mutex.create ();; -let hint = ref None;; -let prune_hint = ref [];; - -let step _ = Condition.signal cond;; -let give_hint n = hint := Some n;; -let give_prune_hint hint = - prune_hint := hint :: !prune_hint -;; - -let check_pause _ = - if !in_pause then - begin - Mutex.lock mutex; - Condition.wait cond mutex; - Mutex.unlock mutex - end -;; - -let get_auto_status _ = - let status = !auto_status in - let and_list,elems,last = - match status with - | [] -> [],[],[] - | (m,s,_,don,gl,fail)::tl -> - let and_list = - HExtlib.filter_map - (fun (id,d,_ as g) -> - match calculate_goal_ty g s m with - | Some (_,x) -> Some (id,x,d) | None -> None) - (d_goals gl) - in - let rows = - (* these are the S goalsin the or list *) - let orlist = - List.map - (fun (m,s,_,don,gl,fail) -> - HExtlib.filter_map - (function S (g,k,c,_) -> Some (g,k,c) | _ -> None) - (List.rev don @ gl)) - status - in - (* this function eats id from a list l::[id,x] returning x, l *) - let eat_tail_if_eq id l = - let rec aux (s, l) = function - | [] -> s, l - | ((id1,_,_),k1,c)::tl when id = id1 -> - (match s with - | None -> aux (Some c,l) tl - | Some _ -> assert false) - | ((id1,_,_),k1,c as e)::tl -> aux (s, e::l) tl - in - let c, l = aux (None, []) l in - c, List.rev l - in - let eat_in_parallel id l = - let rec aux (b,eaten, new_l as acc) l = - match l with - | [] -> acc - | l::tl -> - match eat_tail_if_eq id l with - | None, l -> aux (b@[false], eaten, new_l@[l]) tl - | Some t,l -> aux (b@[true],eaten@[t], new_l@[l]) tl - in - aux ([],[],[]) l - in - let rec eat_all rows l = - match l with - | [] -> rows - | elem::or_list -> - match List.rev elem with - | ((to_eat,depth,_),k,_)::next_lunch -> - let b, eaten, l = eat_in_parallel to_eat l in - let eaten = HExtlib.list_uniq eaten in - let eaten = List.rev eaten in - let b = true (* List.hd (List.rev b) *) in - let rows = rows @ [to_eat,k,b,depth,eaten] in - eat_all rows l - | [] -> eat_all rows or_list - in - eat_all [] (List.rev orlist) - in - let history = - HExtlib.filter_map - (function (S (_,_,(_,c),_)) -> Some c | _ -> None) - gl - in -(* let rows = List.filter (fun (_,l) -> l <> []) rows in *) - and_list, rows, history - in - !auto_context, elems, and_list, last -;; - -(* Works if there is no dependency over proofs *) -let is_a_green_cut goalty = - CicUtil.is_meta_closed goalty -;; -let rec first_s = function - | (D _)::tl -> first_s tl - | (S (g,k,c,s))::tl -> Some ((g,k,c,s),tl) - | [] -> None -;; -let list_union l1 l2 = - (* TODO ottimizzare compare *) - HExtlib.list_uniq (List.sort compare (l1 @ l1)) -;; -let rec eq_todo l1 l2 = - match l1,l2 with - | (D g1) :: tl1,(D g2) :: tl2 when g1=g2 -> eq_todo tl1 tl2 - | (S (g1,k1,(c1,lt1),i1)) :: tl1, (S (g2,k2,(c2,lt2),i2)) :: tl2 - when i1 = i2 && g1 = g2 && k1 = k2 && c1 = c2 -> - if Lazy.force lt1 = Lazy.force lt2 then eq_todo tl1 tl2 else false - | [],[] -> true - | _ -> false -;; -let eat_head todo id fl orlist = - let rec aux acc = function - | [] -> [], acc - | (m, s, _, _, todo1, fl1)::tl as orlist -> - let rec aux1 todo1 = - match first_s todo1 with - | None -> orlist, acc - | Some (((gno,_,_),_,_,_), todo11) -> - (* TODO confronto tra todo da ottimizzare *) - if gno = id && eq_todo todo11 todo then - aux (list_union fl1 acc) tl - else - aux1 todo11 - in - aux1 todo1 - in - aux fl orlist -;; -let close_proof p ty menv context = - let metas = - List.map fst (CicUtil.metas_of_term p @ CicUtil.metas_of_term ty) - in - let menv = List.filter (fun (i,_,_) -> List.exists ((=)i) metas) menv in - naif_closure p menv context -;; -(* XXX capire bene quando aggiungere alla cache *) -let add_to_cache_and_del_from_orlist_if_green_cut - g s m cache key todo orlist fl ctx size minsize -= - let cache = cache_remove_underinspection cache key in - (* prima per fare la irl usavamo il contesto vero e proprio e non quello - * canonico! XXX *) - match calculate_closed_goal_ty g s with - | None -> assert false - | Some (canonical_ctx , gty) -> - let goalno,depth,sort = g in - let irl = mk_irl canonical_ctx in - let goal = Cic.Meta(goalno, irl) in - let proof = CicMetaSubst.apply_subst s goal in - let green_proof, closed_proof = - let b = is_a_green_cut proof in - if not b then - b, (* close_proof proof gty m ctx *) proof - else - b, proof - in - debug_print (lazy ("TENTATIVE CACHE: " ^ CicPp.ppterm key)); - if is_a_green_cut key then - (* if the initia goal was closed, we cut alternatives *) - let _ = debug_print (lazy ("MANGIO: " ^ string_of_int goalno)) in - let orlist, fl = eat_head todo goalno fl orlist in - let cache = - if size < minsize then - (debug_print (lazy ("NO CACHE: 2 (size <= minsize)"));cache) - else - (* if the proof is closed we cache it *) - if green_proof then cache_add_success cache key proof - else (* cache_add_success cache key closed_proof *) - (debug_print (lazy ("NO CACHE: (no gree proof)"));cache) - in - cache, orlist, fl, true - else - let cache = - debug_print (lazy ("TENTATIVE CACHE: " ^ CicPp.ppterm gty)); - if size < minsize then - (debug_print (lazy ("NO CACHE: (size <= minsize)")); cache) else - (* if the substituted goal and the proof are closed we cache it *) - if is_a_green_cut gty then - if green_proof then cache_add_success cache gty proof - else (* cache_add_success cache gty closed_proof *) - (debug_print (lazy ("NO CACHE: (no green proof (gty))"));cache) - else (* - try - let ty, _ = - CicTypeChecker.type_of_aux' ~subst:s - m ctx closed_proof CicUniv.oblivion_ugraph - in - if is_a_green_cut ty then - cache_add_success cache ty closed_proof - else cache - with - | CicTypeChecker.TypeCheckerFailure _ ->*) - (debug_print (lazy ("NO CACHE: (no green gty )"));cache) - in - cache, orlist, fl, false -;; -let close_failures (fl : fail list) (cache : cache) = - List.fold_left - (fun cache ((gno,depth,_),gty) -> - if CicUtil.is_meta_closed gty then - ( debug_print (lazy ("FAIL: INDUCED: " ^ string_of_int gno)); - cache_add_failure cache gty depth) - else - cache) - cache fl -;; -let put_in_subst subst metasenv (goalno,_,_) canonical_ctx t ty = - let entry = goalno, (canonical_ctx, t,ty) in - assert_subst_are_disjoint subst [entry]; - let subst = entry :: subst in - - let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in - - subst, metasenv -;; - -let mk_fake_proof metasenv subst (goalno,_,_) goalty context = - None,metasenv,subst ,(lazy (Cic.Meta(goalno,mk_irl context))),goalty, [] -;; - -let equational_case - tables cache depth fake_proof goalno goalty subst context - flags -= - let active,passive,bag = tables in - let ppterm = ppterm context in - let status = (fake_proof,goalno) in - if flags.use_only_paramod then - begin - debug_print (lazy ("PARAMODULATION SU: " ^ - string_of_int goalno ^ " " ^ ppterm goalty )); - let goal_steps, saturation_steps, timeout = - max_int,max_int,flags.timeout - in - match - Saturation.given_clause bag status active passive - goal_steps saturation_steps timeout - with - | None, active, passive, bag -> - [], (active,passive,bag), cache, flags - | Some(subst',(_,metasenv,_subst,proof,_, _),open_goals),active, - passive,bag -> - assert_subst_are_disjoint subst subst'; - let subst = subst@subst' in - let open_goals = - order_new_goals metasenv subst open_goals ppterm - in - let open_goals = - List.map (fun (x,sort) -> x,depth-1,sort) open_goals - in - incr candidate_no; - [(!candidate_no,proof),metasenv,subst,open_goals], - (active,passive,bag), cache, flags - end - else - begin - debug_print (lazy ("NARROWING DEL GOAL: " ^ - string_of_int goalno ^ " " ^ ppterm goalty )); - let goal_steps, saturation_steps, timeout = - 1,0,flags.timeout - in - match - Saturation.solve_narrowing bag status active passive goal_steps - with - | None, active, passive, bag -> - [], (active,passive,bag), cache, flags - | Some(subst',(_,metasenv,_subst,proof,_, _),open_goals),active, - passive,bag -> - assert_subst_are_disjoint subst subst'; - let subst = subst@subst' in - let open_goals = - order_new_goals metasenv subst open_goals ppterm - in - let open_goals = - List.map (fun (x,sort) -> x,depth-1,sort) open_goals - in - incr candidate_no; - [(!candidate_no,proof),metasenv,subst,open_goals], - (active,passive,bag), cache, flags - end -(* - begin - let params = ([],["use_context","false"]) in - let automation_cache = { - AutomationCache.tables = tables ; - AutomationCache.univ = Universe.empty; } - in - try - let ((_,metasenv,subst,_,_,_),open_goals) = - - solve_rewrite ~params ~automation_cache - (fake_proof, goalno) - in - let proof = lazy (Cic.Meta (-1,[])) in - [(!candidate_no,proof),metasenv,subst,[]],tables, cache, flags - with ProofEngineTypes.Fail _ -> [], tables, cache, flags -(* - let res = Saturation.all_subsumed bag status active passive in - let res' = - List.map - (fun (subst',(_,metasenv,_subst,proof,_, _),open_goals) -> - assert_subst_are_disjoint subst subst'; - let subst = subst@subst' in - let open_goals = - order_new_goals metasenv subst open_goals ppterm - in - let open_goals = - List.map (fun (x,sort) -> x,depth-1,sort) open_goals - in - incr candidate_no; - (!candidate_no,proof),metasenv,subst,open_goals) - res - in - res', (active,passive,bag), cache, flags -*) - end -*) -;; - -let sort_new_elems = - List.sort (fun (_,_,_,l1) (_,_,_,l2) -> - let p1 = List.length (prop_only l1) in - let p2 = List.length (prop_only l2) in - if p1 = p2 then List.length l1 - List.length l2 else p1-p2) -;; - - -let try_candidate dbd - goalty tables subst fake_proof goalno depth context cand -= - let ppterm = ppterm context in - try - let actives, passives, bag = tables in - let (_,metasenv,subst,_,_,_), open_goals = - ProofEngineTypes.apply_tactic - (PrimitiveTactics.apply_tac ~term:cand) - (fake_proof,goalno) - in - let tables = actives, passives, - Equality.push_maxmeta bag - (max (Equality.maxmeta bag) (CicMkImplicit.new_meta metasenv subst)) - in - debug_print (lazy (" OK: " ^ ppterm cand)); - let metasenv = CicRefine.pack_coercion_metasenv metasenv in - let open_goals = order_new_goals metasenv subst open_goals ppterm in - let open_goals = List.map (fun (x,sort) -> x,depth-1,sort) open_goals in - incr candidate_no; - Some ((!candidate_no,lazy cand),metasenv,subst,open_goals), tables - with - | ProofEngineTypes.Fail s -> None,tables - | CicUnification.Uncertain s -> None,tables -;; - -let applicative_case dbd - tables depth subst fake_proof goalno goalty metasenv context - signature universe cache flags -= - (* let goalty_aux = - match goalty with - | Cic.Appl (hd::tl) -> - Cic.Appl (hd :: HExtlib.mk_list (Cic.Meta (0,[])) (List.length tl)) - | _ -> goalty - in *) - let goalty_aux = goalty in - let candidates = - get_candidates flags.skip_trie_filtering universe cache goalty_aux - in - (* if the goal is an equality we skip the congruence theorems - let candidates = - if is_equational_case goalty flags - then List.filter not_default_eq_term candidates - else candidates - in *) - let candidates = List.filter (only signature context metasenv) candidates - in - let tables, elems = - List.fold_left - (fun (tables,elems) cand -> - match - try_candidate dbd goalty - tables subst fake_proof goalno depth context cand - with - | None, tables -> tables, elems - | Some x, tables -> tables, x::elems) - (tables,[]) candidates - in - let elems = sort_new_elems elems in - elems, tables, cache -;; - -let try_smart_candidate dbd - goalty tables subst fake_proof goalno depth context cand -= - let ppterm = ppterm context in - try - let params = (None,[]) in - let automation_cache = { - AutomationCache.tables = tables ; - AutomationCache.univ = Universe.empty; } - in - debug_print (lazy ("candidato per " ^ string_of_int goalno - ^ ": " ^ CicPp.ppterm cand)); -(* - let (_,metasenv,subst,_,_,_) = fake_proof in - prerr_endline ("metasenv:\n" ^ CicMetaSubst.ppmetasenv [] metasenv); - prerr_endline ("subst:\n" ^ CicMetaSubst.ppsubst ~metasenv subst); -*) - let ((_,metasenv,subst,_,_,_),open_goals) = - apply_smart ~dbd ~term:cand ~params ~automation_cache - (fake_proof, goalno) - in - let metasenv = CicRefine.pack_coercion_metasenv metasenv in - let open_goals = order_new_goals metasenv subst open_goals ppterm in - let open_goals = List.map (fun (x,sort) -> x,depth-1,sort) open_goals in - incr candidate_no; - Some ((!candidate_no,lazy cand),metasenv,subst,open_goals), tables - with - | ProofEngineTypes.Fail s -> None,tables - | CicUnification.Uncertain s -> None,tables -;; - -let smart_applicative_case dbd - tables depth subst fake_proof goalno goalty metasenv context signature - universe cache flags -= - let goalty_aux = - match goalty with - | Cic.Appl (hd::tl) -> - Cic.Appl (hd :: HExtlib.mk_list (Cic.Meta (0,[])) (List.length tl)) - | _ -> goalty - in - let smart_candidates = - get_candidates flags.skip_trie_filtering universe cache goalty_aux - in - let candidates = - get_candidates flags.skip_trie_filtering universe cache goalty - in - let smart_candidates = - List.filter - (fun x -> not(List.mem x candidates)) smart_candidates - in - let debug_msg = - (lazy ("smart_candidates" ^ " = " ^ - (String.concat "\n" (List.map CicPp.ppterm smart_candidates)))) in - debug_print debug_msg; - let candidates = List.filter (only signature context metasenv) candidates in - let smart_candidates = - List.filter (only signature context metasenv) smart_candidates - in -(* - let penalty cand depth = - if only signature context metasenv cand then depth else ((prerr_endline ( - "penalizzo " ^ CicPp.ppterm cand));depth -1) - in -*) - let tables, elems = - List.fold_left - (fun (tables,elems) cand -> - match - try_candidate dbd goalty - tables subst fake_proof goalno depth context cand - with - | None, tables -> - (* if normal application fails we try to be smart *) - (match try_smart_candidate dbd goalty - tables subst fake_proof goalno depth context cand - with - | None, tables -> tables, elems - | Some x, tables -> tables, x::elems) - | Some x, tables -> tables, x::elems) - (tables,[]) candidates - in - let tables, smart_elems = - List.fold_left - (fun (tables,elems) cand -> - match - try_smart_candidate dbd goalty - tables subst fake_proof goalno depth context cand - with - | None, tables -> tables, elems - | Some x, tables -> tables, x::elems) - (tables,[]) smart_candidates - in - let elems = sort_new_elems (elems @ smart_elems) in - elems, tables, cache -;; - -let equational_and_applicative_case dbd - signature universe flags m s g gty tables cache context -= - let goalno, depth, sort = g in - let fake_proof = mk_fake_proof m s g gty context in - if is_equational_case gty flags then - let elems,tables,cache, flags = - equational_case tables cache - depth fake_proof goalno gty s context flags - in - let more_elems, tables, cache = - if flags.use_only_paramod then - [],tables, cache - else - applicative_case dbd - tables depth s fake_proof goalno - gty m context signature universe cache flags - in - elems@more_elems, tables, cache, flags - else - let elems, tables, cache = - match LibraryObjects.eq_URI () with - | Some _ -> - smart_applicative_case dbd tables depth s fake_proof goalno - gty m context signature universe cache flags - | None -> - applicative_case dbd tables depth s fake_proof goalno - gty m context signature universe cache flags - in - elems, tables, cache, flags -;; -let rec condition_for_hint i = function - | [] -> false - | S (_,_,(j,_),_):: tl -> j <> i (* && condition_for_hint i tl *) - | _::tl -> condition_for_hint i tl -;; -let remove_s_from_fl (id,_,_) (fl : fail list) = - let rec aux = function - | [] -> [] - | ((id1,_,_),_)::tl when id = id1 -> tl - | hd::tl -> hd :: aux tl - in - aux fl -;; - -let prunable_for_size flags s m todo = - let rec aux b = function - | (S _)::tl -> aux b tl - | (D (_,_,T))::tl -> aux b tl - | (D g)::tl -> - (match calculate_goal_ty g s m with - | None -> aux b tl - | Some (canonical_ctx, gty) -> - let gsize, _ = - Utils.weight_of_term - ~consider_metas:false ~count_metas_occurrences:true gty in - let newb = b || gsize > flags.maxgoalsizefactor in - aux newb tl) - | [] -> b - in - aux false todo - -(* -let prunable ty todo = - let rec aux b = function - | (S(_,k,_,_))::tl -> aux (b || Equality.meta_convertibility k ty) tl - | (D (_,_,T))::tl -> aux b tl - | D _::_ -> false - | [] -> b - in - aux false todo -;; -*) - -let prunable menv subst ty todo = - let rec aux = function - | (S(_,k,_,_))::tl -> - (match Equality.meta_convertibility_subst k ty menv with - | None -> aux tl - | Some variant -> - no_progress variant tl (* || aux tl*)) - | (D (_,_,T))::tl -> aux tl - | _ -> false - and no_progress variant = function - | [] -> (*prerr_endline "++++++++++++++++++++++++ no_progress";*) true - | D ((n,_,P) as g)::tl -> - (match calculate_goal_ty g subst menv with - | None -> no_progress variant tl - | Some (_, gty) -> - (match calculate_goal_ty g variant menv with - | None -> assert false - | Some (_, gty') -> - if gty = gty' then no_progress variant tl -(* -(prerr_endline (string_of_int n); - prerr_endline (CicPp.ppterm gty); - prerr_endline (CicPp.ppterm gty'); - prerr_endline "---------- subst"; - prerr_endline (CicMetaSubst.ppsubst ~metasenv:menv subst); - prerr_endline "---------- variant"; - prerr_endline (CicMetaSubst.ppsubst ~metasenv:menv variant); - prerr_endline "---------- menv"; - prerr_endline (CicMetaSubst.ppmetasenv [] menv); - no_progress variant tl) *) - else false)) - | _::tl -> no_progress variant tl - in - aux todo - -;; -let condition_for_prune_hint prune (m, s, size, don, todo, fl) = - let s = - HExtlib.filter_map (function S (_,_,(c,_),_) -> Some c | _ -> None) todo - in - List.for_all (fun i -> List.for_all (fun j -> i<>j) prune) s -;; -let filter_prune_hint c l = - let prune = !prune_hint in - prune_hint := []; (* possible race... *) - if prune = [] then c,l - else - cache_reset_underinspection c, - List.filter (condition_for_prune_hint prune) l -;; - -let auto_main dbd tables context flags signature universe cache elems = - auto_context := context; - let rec aux tables flags cache (elems : status) = - pp_status context elems; -(* DEBUGGING CODE: uncomment these two lines to stop execution at each iteration - auto_status := elems; - check_pause (); -*) - let cache, elems = filter_prune_hint cache elems in - match elems with - | (m, s, size, don, todo, fl)::orlist when !hint <> None -> - debug_print (lazy "skip"); - (match !hint with - | Some i when condition_for_hint i todo -> - aux tables flags cache orlist - | _ -> - hint := None; - aux tables flags cache elems) - | [] -> - (* complete failure *) - debug_print (lazy "give up"); - Gaveup (tables, cache) - | (m, s, _, _, [],_)::orlist -> - (* complete success *) - debug_print (lazy "success"); - Proved (m, s, orlist, tables, cache) - | (m, s, size, don, (D (_,_,T))::todo, fl)::orlist - when not flags.AutoTypes.do_types -> - (* skip since not Prop, don't even check if closed by side-effect *) - debug_print (lazy "skip existential goal"); - aux tables flags cache ((m, s, size, don, todo, fl)::orlist) - | (m, s, size, don, (S(g, key, c,minsize) as op)::todo, fl)::orlist -> - (* partial success, cache g and go on *) - let cache, orlist, fl, sibling_pruned = - add_to_cache_and_del_from_orlist_if_green_cut - g s m cache key todo orlist fl context size minsize - in - debug_print (lazy (AutoCache.cache_print context cache)); - let fl = remove_s_from_fl g fl in - let don = if sibling_pruned then don else op::don in - aux tables flags cache ((m, s, size, don, todo, fl)::orlist) - | (m, s, size, don, todo, fl)::orlist - when List.length(prop_only (d_goals todo)) > flags.maxwidth -> - debug_print (lazy ("FAIL: WIDTH")); - (* too many goals in and generated by last th *) - let cache = close_failures fl cache in - aux tables flags cache orlist - | (m, s, size, don, todo, fl)::orlist when size > flags.maxsize -> - debug_print - (lazy ("FAIL: SIZE: "^string_of_int size ^ - " > " ^ string_of_int flags.maxsize )); - (* we already have a too large proof term *) - let cache = close_failures fl cache in - aux tables flags cache orlist - | _ when Unix.gettimeofday () > flags.timeout -> - (* timeout *) - debug_print (lazy ("FAIL: TIMEOUT")); - Gaveup (tables, cache) - | (m, s, size, don, (D (gno,depth,_ as g))::todo, fl)::orlist as status -> - (* attack g *) - debug_print (lazy "attack goal"); - match calculate_goal_ty g s m with - | None -> - (* closed by side effect *) - debug_print (lazy ("SUCCESS: SIDE EFFECT: " ^ string_of_int gno)); - aux tables flags cache ((m,s,size,don,todo, fl)::orlist) - | Some (canonical_ctx, gty) -> - let gsize, _ = - Utils.weight_of_term ~consider_metas:false ~count_metas_occurrences:true gty - in - if gsize > flags.maxgoalsizefactor then - (debug_print (lazy ("FAIL: SIZE: goal: "^string_of_int gsize)); - aux tables flags cache orlist) - else if prunable_for_size flags s m todo then - (debug_print (lazy ("POTO at depth: "^(string_of_int depth))); - aux tables flags cache orlist) - else - (* still to be proved *) - (debug_print (lazy ("EXAMINE: "^CicPp.ppterm gty)); - match cache_examine cache gty with - | Failed_in d when d >= depth -> - (* fail depth *) - debug_print (lazy ("FAIL: DEPTH (cache): "^string_of_int gno)); - let cache = close_failures fl cache in - aux tables flags cache orlist - | UnderInspection -> - (* fail loop *) - debug_print (lazy ("FAIL: LOOP: " ^ string_of_int gno)); - let cache = close_failures fl cache in - aux tables flags cache orlist - | Succeded t -> - debug_print (lazy ("SUCCESS: CACHE HIT: " ^ string_of_int gno)); - let s, m = put_in_subst s m g canonical_ctx t gty in - aux tables flags cache ((m, s, size, don,todo, fl)::orlist) - | Notfound - | Failed_in _ when depth > 0 -> - ( (* more depth or is the first time we see the goal *) - if prunable m s gty todo then - (debug_print (lazy( - "FAIL: LOOP: one father is equal")); - aux tables flags cache orlist) - else - let cache = cache_add_underinspection cache gty depth in - auto_status := status; - check_pause (); - debug_print - (lazy ("INSPECTING: " ^ - string_of_int gno ^ "("^ string_of_int size ^ "): "^ - CicPp.ppterm gty)); - (* elems are possible computations for proving gty *) - let elems, tables, cache, flags = - equational_and_applicative_case dbd - signature universe flags m s g gty tables cache context - in - if elems = [] then - (* this goal has failed *) - let cache = close_failures ((g,gty)::fl) cache in - aux tables flags cache orlist - else - (* elems = (cand,m,s,gl) *) - let size_gl l = List.length - (List.filter (function (_,_,P) -> true | _ -> false) l) - in - let elems = - let inj_gl gl = List.map (fun g -> D g) gl in - let rec map = function - | [] -> assert false - | (cand,m,s,gl)::[] -> - (* in the last one we add the failure *) - let todo = - inj_gl gl @ (S(g,gty,cand,size+1))::todo - in - (* we are the last in OR, we fail on g and - * also on all failures implied by g *) - (m,s, size + size_gl gl, don, todo, (g,gty)::fl) - :: orlist - | (cand,m,s,gl)::tl -> - (* we add the S step after gl and before todo *) - let todo = - inj_gl gl @ (S(g,gty,cand,size+1))::todo - in - (* since we are not the last in OR, we do not - * imply failures *) - (m,s, size + size_gl gl, don, todo, []) :: map tl - in - map elems - in - aux tables flags cache elems) - | _ -> - (* no more depth *) - debug_print (lazy ("FAIL: DEPTH: " ^ string_of_int gno)); - let cache = close_failures fl cache in - aux tables flags cache orlist) - in - (aux tables flags cache elems : auto_result) -;; - - -let - auto_all_solutions dbd tables universe cache context metasenv gl flags -= - let signature = - List.fold_left - (fun set g -> - MetadataConstraints.UriManagerSet.union set - (MetadataQuery.signature_of metasenv g) - ) - MetadataConstraints.UriManagerSet.empty gl - in - let goals = order_new_goals metasenv [] gl CicPp.ppterm in - let goals = - List.map - (fun (x,s) -> D (x,flags.maxdepth,s)) goals - in - let elems = [metasenv,[],1,[],goals,[]] in - let rec aux tables solutions cache elems flags = - match auto_main dbd tables context flags signature universe cache elems with - | Gaveup (tables,cache) -> - solutions,cache, tables - | Proved (metasenv,subst,others,tables,cache) -> - if Unix.gettimeofday () > flags.timeout then - ((subst,metasenv)::solutions), cache, tables - else - aux tables ((subst,metasenv)::solutions) cache others flags - in - let rc = aux tables [] cache elems flags in - match rc with - | [],cache,tables -> [],cache,tables - | solutions, cache,tables -> - let solutions = - HExtlib.filter_map - (fun (subst,newmetasenv) -> - let opened = - ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv ~newmetasenv - in - if opened = [] then Some subst else None) - solutions - in - solutions,cache,tables -;; - -(******************* AUTO ***************) - - -let auto dbd flags metasenv tables universe cache context metasenv gl = - let initial_time = Unix.gettimeofday() in - let signature = - List.fold_left - (fun set g -> - MetadataConstraints.UriManagerSet.union set - (MetadataQuery.signature_of metasenv g) - ) - MetadataConstraints.UriManagerSet.empty gl - in - let goals = order_new_goals metasenv [] gl CicPp.ppterm in - let goals = List.map (fun (x,s) -> D(x,flags.maxdepth,s)) goals in - let elems = [metasenv,[],1,[],goals,[]] in - match auto_main dbd tables context flags signature universe cache elems with - | Proved (metasenv,subst,_, tables,cache) -> - debug_print(lazy - ("TIME:"^string_of_float(Unix.gettimeofday()-.initial_time))); - Some (subst,metasenv), cache - | Gaveup (tables,cache) -> - debug_print(lazy - ("TIME:"^string_of_float(Unix.gettimeofday()-.initial_time))); - None,cache -;; - -let auto_tac ~(dbd:HSql.dbd) ~params:(univ,params) ~automation_cache (proof, goal) = - let flags = flags_of_params params () in - let use_library = flags.use_library in - let universe, tables, cache = - init_cache_and_tables - ~dbd ~use_library ~use_context:(not flags.skip_context) - automation_cache univ (proof, goal) - in - let _,metasenv,subst,_,_, _ = proof in - let _,context,goalty = CicUtil.lookup_meta goal metasenv in - let signature = MetadataQuery.signature_of metasenv goal in - let signature = - match univ with - | None -> signature - | Some l -> - List.fold_left - (fun set t -> - let ty, _ = - CicTypeChecker.type_of_aux' metasenv context t - CicUniv.oblivion_ugraph - in - MetadataConstraints.UriManagerSet.union set - (MetadataConstraints.constants_of ty) - ) - signature l - in - let tables,cache = - if flags.close_more then - close_more - tables context (proof, goal) - (auto_all_solutions dbd) signature universe cache - else tables,cache in - let initial_time = Unix.gettimeofday() in - let (_,oldmetasenv,_,_,_, _) = proof in - hint := None; - let elem = - metasenv,subst,1,[],[D (goal,flags.maxdepth,P)],[] - in - match auto_main dbd tables context flags signature universe cache [elem] with - | Proved (metasenv,subst,_, tables,cache) -> - debug_print (lazy - ("TIME:"^string_of_float(Unix.gettimeofday()-.initial_time))); - let proof,metasenv = - ProofEngineHelpers.subst_meta_and_metasenv_in_proof - proof goal subst metasenv - in - let opened = - ProofEngineHelpers.compare_metasenvs ~oldmetasenv - ~newmetasenv:metasenv - in - proof,opened - | Gaveup (tables,cache) -> - debug_print - (lazy ("TIME:"^ - string_of_float(Unix.gettimeofday()-.initial_time))); - raise (ProofEngineTypes.Fail (lazy "Auto gave up")) -;; - -let auto_tac ~dbd ~params ~automation_cache = - ProofEngineTypes.mk_tactic (auto_tac ~params ~dbd ~automation_cache);; - -let pp_proofterm = Equality.pp_proofterm;; - -let revision = "$Revision$";; -let size_and_depth context metasenv t = 100, 100 diff --git a/matita/components/tactics/auto.mli b/matita/components/tactics/auto.mli deleted file mode 100644 index 557d78194..000000000 --- a/matita/components/tactics/auto.mli +++ /dev/null @@ -1,73 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type auto_params = Cic.term list option * (string * string) list - -val auto_tac: - dbd:HSql.dbd -> - params:auto_params -> - automation_cache:AutomationCache.cache -> - ProofEngineTypes.tactic - -val applyS_tac: - dbd:HSql.dbd -> - term: Cic.term -> - params:auto_params -> - automation_cache:AutomationCache.cache -> - ProofEngineTypes.tactic - -val demodulate_tac : - dbd:HSql.dbd -> - params:auto_params -> - automation_cache:AutomationCache.cache -> - ProofEngineTypes.tactic - -val demodulate_theorem : - automation_cache:AutomationCache.cache -> - UriManager.uri -> - Cic.term * Cic.term - -type auto_status = - Cic.context * - (* or list: goalno, goaltype, grey, depth, candidates: (goalno, c) *) - (int * Cic.term * bool * int * (int * Cic.term Lazy.t) list) list * - (* and list *) - (int * Cic.term * int) list * - (* last moves *) - Cic.term Lazy.t list - -val get_auto_status : unit -> auto_status -val pause: bool -> unit -val step : unit -> unit -val give_hint : int -> unit -val give_prune_hint : int -> unit - -val lambda_close : - ?prefix_name:string -> Cic.term -> Cic.metasenv -> Cic.context -> Cic.term * - int - -val pp_proofterm: Cic.term -> string -val revision : string (* svn revision *) -val size_and_depth : Cic.context -> Cic.metasenv -> Cic.term -> int * int diff --git a/matita/components/tactics/autoCache.ml b/matita/components/tactics/autoCache.ml deleted file mode 100644 index 882a18393..000000000 --- a/matita/components/tactics/autoCache.ml +++ /dev/null @@ -1,158 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type cache_key = Cic.term -type cache_elem = - | Failed_in of int - | Succeded of Cic.term - | UnderInspection - | Notfound -type cache = (Universe.universe * ((cache_key * cache_elem) list));; - -let debug = false;; -let prerr_endline s = - if debug then prerr_endline s else () -;; - -let cache_empty = (Universe.empty,[]);; - -let get_candidates (univ,_) ty = -(* if Universe.key ty = ty then *) - Universe.get_candidates univ ty -(* - else - (prerr_endline ("skip: " ^ CicPp.ppterm (Universe.key ty)); []) - *) -;; - -let index (univ,cache) key term = - Universe.index univ key term,cache -;; - -let index_term_and_unfolded_term (univ,cache) context t ty = - Universe.index_local_term univ context t ty, cache -;; - -let cache_add_list (univ,cache) context terms_and_types = - let univ = - List.fold_left - (fun univ (t,ty) -> - prerr_endline ("indexing: " ^ CicPp.ppterm ty); - Universe.index_local_term univ context t ty) - univ terms_and_types - in - univ, cache - -let cache_examine (_,oldcache) cache_key = - prerr_endline ("examine : " ^ CicPp.ppterm cache_key); - try snd (List.find (fun (x,_) -> CicUtil.alpha_equivalence x cache_key) - oldcache) with Not_found -> - prerr_endline "notfound"; - Notfound -;; -let cache_replace (univ,oldcache) key v = - let oldcache = List.filter (fun (i,_) -> i <> key) oldcache in - univ, (key,v)::oldcache -;; -let cache_remove (univ,oldcache) key = - let oldcache = List.filter (fun (i,_) -> i <> key) oldcache in - univ,oldcache -;; -let cache_add_failure cache cache_key depth = - prerr_endline - ("CACHE: ADD FAIL " ^ CicPp.ppterm cache_key ^ - " depth: " ^ string_of_int depth); - match cache_examine cache cache_key with - | Failed_in i when i > depth -> cache - | Notfound - | Failed_in _ - | UnderInspection -> cache_replace cache cache_key (Failed_in depth) - | Succeded t -> cache - (* - prerr_endline (CicPp.ppterm t); - assert false (* if succed it can't fail *) *) -;; -let cache_add_success ((univ,_) as cache) cache_key proof = - let u_key = Universe.key cache_key in - if u_key <> cache_key then - Universe.index univ u_key proof, snd cache - else - univ, - snd - (match cache_examine cache cache_key with - | Failed_in _ -> cache_replace cache cache_key (Succeded proof) - | UnderInspection -> cache_replace cache cache_key (Succeded proof) - | Succeded t -> (* we may decide to keep the smallest proof *) cache - | Notfound -> cache_replace cache cache_key (Succeded proof)) -(* - (if Universe.key cache_key = cache_key then - Universe.index univ cache_key proof - else - univ),snd - (prerr_endline ("CACHE: ADD SUCCESS" ^ CicPp.ppterm cache_key); - match cache_examine cache cache_key with - | Failed_in _ -> cache_replace cache cache_key (Succeded proof) - | UnderInspection -> cache_replace cache cache_key (Succeded proof) - | Succeded t -> (* we may decide to keep the smallest proof *) cache - | Notfound -> cache_replace cache cache_key (Succeded proof)) -;; -*) -let cache_add_underinspection ((univ,oldcache) as cache) cache_key depth = - prerr_endline ("CACHE: ADD INSPECTING" ^ CicPp.ppterm cache_key); - match cache_examine cache cache_key with - | Failed_in i when i < depth -> cache_replace cache cache_key UnderInspection - | Notfound -> univ,(cache_key,UnderInspection)::oldcache - | Failed_in _ - | UnderInspection - | Succeded _ -> assert false (* it must be a new goal *) -;; -let cache_print context (_,oldcache) = - let names = List.map (function None -> None | Some (x,_) -> Some x) context in - String.concat "\n" - (HExtlib.filter_map - (function - | (k,Succeded _) -> Some ("CACHE SUCCESS: " ^ CicPp.pp k names) - | _ -> None) - oldcache) -;; -let cache_remove_underinspection ((univ,oldcache) as cache) cache_key = - prerr_endline ("CACHE: REMOVE INSPECTING" ^ CicPp.ppterm cache_key); - match cache_examine cache cache_key with - | Notfound - | Failed_in _ (* -> assert false *) - | UnderInspection -> cache_remove cache cache_key - | Succeded _ -> cache (* - prerr_endline (CicPp.ppterm cache_key); - assert false (* it must be a new goal *) *) -;; -let cache_size (_,oldcache) = - List.length (List.filter (function (_,Succeded _) -> true | _ -> false) oldcache) -;; -let cache_clean (univ,oldcache) = - univ,List.filter (function (_,Succeded _) -> true | _ -> false) oldcache -;; -let cache_reset_underinspection (u,c) = - u,List.filter (function (_,UnderInspection) -> false | _ -> true) c -;; diff --git a/matita/components/tactics/autoCache.mli b/matita/components/tactics/autoCache.mli deleted file mode 100644 index c4c99c382..000000000 --- a/matita/components/tactics/autoCache.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type cache -type cache_key = Cic.term -type cache_elem = - | Failed_in of int - | Succeded of Cic.term - | UnderInspection - | Notfound -val get_candidates: cache -> Cic.term -> Cic.term list -val cache_add_list: - cache -> Cic.context -> (Cic.term*Cic.term) list -> cache -val cache_examine: cache -> cache_key -> cache_elem -val cache_add_failure: cache -> cache_key -> int -> cache -val cache_add_success: cache -> cache_key -> Cic.term -> cache -val cache_add_underinspection: cache -> cache_key -> int -> cache -val cache_remove_underinspection: cache -> cache_key -> cache -val cache_reset_underinspection: cache -> cache -val cache_empty: cache -val cache_print: Cic.context -> cache -> string -val cache_size: cache -> int -val cache_clean: cache -> cache - diff --git a/matita/components/tactics/autoTypes.ml b/matita/components/tactics/autoTypes.ml deleted file mode 100644 index 9bced7618..000000000 --- a/matita/components/tactics/autoTypes.ml +++ /dev/null @@ -1,65 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type flags = { - maxwidth: int; - maxsize: int; - maxdepth: int; - maxgoalsizefactor : int; - timeout: float; - use_library: bool; - use_paramod: bool; - use_only_paramod : bool; - close_more : bool; - dont_cache_failures: bool; - do_types: bool; - skip_trie_filtering: bool; - skip_context: bool; -} - -let default_flags _ = - {maxwidth=3; - maxdepth=3; - maxsize = 6; - maxgoalsizefactor = max_int; - timeout=Unix.gettimeofday() +.3.0; - use_library=false; - use_paramod=true; - use_only_paramod=false; - close_more=false; - dont_cache_failures=false; - do_types=false; - skip_trie_filtering=false; - skip_context=false; -} -;; - -(* (metasenv, subst, (metano,depth)list *) -type sort = P | T;; -type and_elem = (int * Cic.term * Cic.term) * Cic.metasenv * Cic.substitution * (int * int * sort) list -type auto_result = - | Fail of string - | Success of (int * Cic.term * Cic.term) * Cic.metasenv * Cic.substitution * and_elem list - diff --git a/matita/components/tactics/autoTypes.mli b/matita/components/tactics/autoTypes.mli deleted file mode 100644 index 745438462..000000000 --- a/matita/components/tactics/autoTypes.mli +++ /dev/null @@ -1,51 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type flags = { - maxwidth: int; - maxsize: int; - maxdepth: int; - maxgoalsizefactor : int; - timeout: float; - use_library: bool; - use_paramod: bool; - use_only_paramod : bool; - close_more : bool; - dont_cache_failures: bool; - do_types: bool; - skip_trie_filtering: bool; - skip_context : bool; -} - -val default_flags : unit -> flags - -(* (metasenv, subst, (metano,depth)list *) -type sort = P | T;; -type and_elem = - (int * Cic.term * Cic.term) * Cic.metasenv * Cic.substitution * (ProofEngineTypes.goal * int * sort) list -type auto_result = - | Fail of string - | Success of (int * Cic.term * Cic.term) * Cic.metasenv * Cic.substitution * and_elem list - diff --git a/matita/components/tactics/automationCache.ml b/matita/components/tactics/automationCache.ml deleted file mode 100644 index 34bb3efdf..000000000 --- a/matita/components/tactics/automationCache.ml +++ /dev/null @@ -1,119 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type tables = - Saturation.active_table * Saturation.passive_table * Equality.equality_bag - -type cache = { - univ : Universe.universe; - tables : Saturation.active_table * - Saturation.passive_table * - Equality.equality_bag; -} - -let empty_tables () = - Saturation.make_active [], - Saturation.make_passive [], - Equality.mk_equality_bag () -;; - -let empty () = { - univ = Universe.empty; - tables = empty_tables (); -} - -let pump cache steps = - let active, passive, bag = cache.tables in - let active, passive, bag = - Saturation.pump_actives - [] bag active passive steps infinity - in - let tables = active, passive, bag in - { cache with tables = tables } -;; - -let add_term_to_active cache metasenv subst context t ty_opt = - let actives, passives, bag = cache.tables in - let bag, metasenv, head, t, args, mes, ugraph = - match ty_opt with - | Some ty -> - bag, metasenv, ty, t, [], (CicUtil.metas_of_term (Cic.Appl [t;ty])), - CicUniv.oblivion_ugraph - | None -> - let ty, ugraph = - CicTypeChecker.type_of_aux' - ~subst metasenv context t CicUniv.oblivion_ugraph - in - let bag, head, metasenv, args = - Equality.saturate_term bag metasenv subst context ty - in - let mes = CicUtil.metas_of_term (Cic.Appl (head::t::args)) in - let t = if args = [] then t else Cic.Appl (t:: args) in - bag, metasenv, head, t, args, mes, ugraph - in - if List.exists - (function - | Cic.Meta(i,_) -> - (try - let _,mc, mt = CicUtil.lookup_meta i metasenv in - let sort, u = - CicTypeChecker.type_of_aux' metasenv mc mt ugraph - in - fst (CicReduction.are_convertible mc sort (Cic.Sort Cic.Prop) u) - with - | CicUtil.Meta_not_found _ -> false) - | _ -> assert false) - args - then - cache - else - let env = metasenv, context, CicUniv.oblivion_ugraph in - let newmetas = - List.filter (fun (i,_,_) -> List.mem_assoc i mes) metasenv - in - let tables = - Saturation.add_to_active bag actives passives env head t newmetas - in - { cache with tables = tables } -;; - -let pp_cache cache = - prerr_endline "Automation cache"; - prerr_endline "----------------------------------------------"; - prerr_endline "universe:"; - Universe.iter cache.univ (fun _ ts -> - prerr_endline (" "^ - String.concat "\n " (List.map CicPp.ppterm ts))); - prerr_endline "tables/actives:"; - let active, passive, _ = cache.tables in - List.iter - (fun e -> prerr_endline (" " ^ Equality.string_of_equality e)) - (Saturation.list_of_active active); - prerr_endline "tables/passives:"; - List.iter - (fun e -> prerr_endline (" " ^ Equality.string_of_equality e)) - (Saturation.list_of_passive passive); - prerr_endline "----------------------------------------------"; -;; diff --git a/matita/components/tactics/automationCache.mli b/matita/components/tactics/automationCache.mli deleted file mode 100644 index 8b032870f..000000000 --- a/matita/components/tactics/automationCache.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type tables = - Saturation.active_table * Saturation.passive_table * Equality.equality_bag - -type cache = { - univ : Universe.universe; - tables : tables; -} - - -val empty_tables : unit -> tables -val empty : unit -> cache - -val add_term_to_active: - cache -> Cic.metasenv -> Cic.substitution -> Cic.context -> - Cic.term -> Cic.term option -> cache -val pump: cache -> int -> cache -val pp_cache: cache -> unit - - diff --git a/matita/components/tactics/closeCoercionGraph.ml b/matita/components/tactics/closeCoercionGraph.ml deleted file mode 100644 index 64df14a42..000000000 --- a/matita/components/tactics/closeCoercionGraph.ml +++ /dev/null @@ -1,546 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -(* $Id: cicCoercion.ml 7077 2006-12-05 15:44:54Z fguidi $ *) - -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. the list elements are - * (source, list of coercions to follow, target) - *) -let get_closure_coercions src tgt uri coercions = - let enrich (uri,sat,_) tgt = - let arity = match tgt with CoercDb.Fun n -> n | _ -> 0 in - uri,sat,arity - in - let uri = enrich uri tgt in - let eq_carr ?exact s t = - debug_print(lazy(CoercDb.string_of_carr s^" VS "^CoercDb.string_of_carr t)); - let rc = CoercDb.eq_carr ?exact s t in - debug_print(lazy(string_of_bool rc)); - rc - in - match src,tgt with - | CoercDb.Uri _, CoercDb.Uri _ -> - debug_print (lazy ("Uri, Uri4")); - let c_from_tgt = - List.filter - (fun (f,t,_) -> - debug_print (lazy ("Uri, Uri3")); - eq_carr f tgt) - coercions - in - let c_to_src = - List.filter - (fun (f,t,_) -> - debug_print (lazy ("Uri, Uri2")); - eq_carr t src) - coercions - in - (HExtlib.flatten_map - (fun (_,t,ul) -> - if eq_carr ~exact:true src t then [] else - List.map (fun u -> src,[uri; enrich u t],t) ul) c_from_tgt) @ - (HExtlib.flatten_map - (fun (s,t,ul) -> - if eq_carr ~exact:true s tgt then [] else - List.map (fun u -> s,[enrich u t; uri],tgt) ul) c_to_src) @ - (HExtlib.flatten_map - (fun (s,t1,u1l) -> - HExtlib.flatten_map - (fun (_,t,u2l) -> - HExtlib.flatten_map - (fun u1 -> - debug_print (lazy ("Uri, Uri1")); - if eq_carr ~exact:true s t - || eq_carr ~exact:true s tgt - || eq_carr ~exact:true src t - then [] else - List.map - (fun u2 -> (s,[enrich u1 t1;uri;enrich u2 t],t)) - u2l) - u1l) - c_from_tgt) - c_to_src) - | _ -> [] (* do not close in case source or target is not an indty ?? *) -;; - -exception UnableToCompose - -(* generate_composite (c2 (c1 s)) in the universe graph univ - both living in the same context and metasenv - - c2 ?p2 (c1 ?p1 ?x ?s1) ?s2 - - where: - ?pn + 1 + ?sn = count_pi n - arity n -*) -let generate_composite' (c1,sat1,arity1) (c2,sat2,arity2) context metasenv univ= - let original_metasenv = metasenv in - let c1_ty,univ = CicTypeChecker.type_of_aux' metasenv context c1 univ in - let c2_ty,univ = CicTypeChecker.type_of_aux' metasenv context c2 univ in - let rec mk_implicits = function - | 0 -> [] | n -> (Cic.Implicit None) :: mk_implicits (n-1) - in - let rec mk_lambda_spine c namer = function - | 0 -> c - | n -> - Cic.Lambda - (namer n, - (Cic.Implicit None), - mk_lambda_spine (CicSubstitution.lift 1 c) namer (n-1)) - in - let count_pis t arity = - let rec aux acc n = function - | Cic.Prod (name,src,tgt) -> aux (acc@[name]) (n+1) tgt - | _ -> n,acc - in - let len,names = aux [] 0 t in - let len = len - arity in - List.fold_left - (fun (n,l) x -> if n < len then n+1,l@[x] else n,l) (0,[]) - names - in - let compose c1 nc1 c2 nc2 = - Cic.Appl ((*CicSubstitution.lift 1*) c2 :: mk_implicits (nc2 - sat2 - 1) @ - Cic.Appl ((*CicSubstitution.lift 1*) c1 :: mk_implicits nc1 ) :: - mk_implicits sat2) - in - let rec create_subst_from_metas_to_rels n = function - | [] -> [] - | (metano, ctx, ty)::tl -> - (metano,(ctx,Cic.Rel n,ty)) :: - create_subst_from_metas_to_rels (n-1) tl - in - let split_metasenv metasenv n = - List.partition (fun (_,ctx,_) -> List.length ctx >= n) metasenv - in - let purge_unused_lambdas metasenv t = - let rec aux = function - | Cic.Lambda (_, Cic.Meta (i,_), t) when - List.exists (fun (j,_,_) -> j = i) metasenv -> - aux (CicSubstitution.subst (Cic.Rel ~-100) t) - | Cic.Lambda (name, s, t) -> - Cic.Lambda (name, s, aux t) - | t -> t - in - aux t - in - let order_body_menv term body_metasenv c1_pis c2_pis = - let rec purge_lambdas = function - | Cic.Lambda (_,_,t) -> purge_lambdas t - | t -> t - in - let skip_appl = function | Cic.Appl l -> List.tl l | _ -> assert false in - let rec metas_of_term_and_types t = - let metas = CicUtil.metas_of_term t in - let types = - List.flatten - (List.map - (fun (i,_) -> try - let _,_,ty = CicUtil.lookup_meta i body_metasenv in metas_of_term_and_types ty - with CicUtil.Meta_not_found _ -> []) - metas) - in - metas @ types - in - let sorted_metas_of_term world t = - let metas = metas_of_term_and_types t in - (* this check should be useless *) - let metas = List.filter (fun (i,_)->List.exists (fun (j,_,_) -> j=i) world) metas in - let order_metas metasenv metas = - let module OT = struct type t = int let compare = Pervasives.compare end in - let module S = HTopoSort.Make (OT) in - let dep i = - try - let _,_,ty = List.find (fun (j,_,_) -> j=i) metasenv in - let metas = List.map fst (CicUtil.metas_of_term ty) in - HExtlib.list_uniq (List.sort Pervasives.compare metas) - with Not_found -> [] - in - S.topological_sort (List.map (fun (i,_) -> i) metas) dep - in - order_metas world metas - in - let metas_that_saturate l = - List.fold_left - (fun (acc,n) t -> - let metas = sorted_metas_of_term body_metasenv t in - let metas = - List.filter (fun i -> List.for_all (fun (j,_) -> j<>i) acc) metas in - let metas = List.map (fun i -> i,n) metas in - metas @ acc, n+1) - ([],0) l - in - let l_c2 = skip_appl (purge_lambdas term) in - let l_c2_b,l_c2_a = - try - HExtlib.split_nth (c2_pis - sat2 - 1) l_c2 - with - Failure _ -> assert false in - let l_c1,l_c2_a = - match l_c2_a with - Cic.Appl (_::l_c1)::tl -> l_c1,tl - | _ -> assert false in - let meta_to_be_coerced = - try - match List.nth l_c1 (c1_pis - sat1 - 1) with - | Cic.Meta (i,_) -> Some i - | t -> - debug_print - (lazy("meta_to_be_coerced: " ^ CicPp.ppterm t)); - debug_print - (lazy("c1_pis: " ^ string_of_int c1_pis ^ - " sat1:" ^ string_of_int sat1)); - None - with - Failure _ -> assert false - in - (* BIG HACK ORRIBLE: - * it should be (l_c2_b @ l_c1 @ l_c2_a), but in this case sym (eq_f) gets - * \A,B,f,x,y,Exy and not \B,A,f,x,y,Exy - * as an orrible side effect, the other composites get a type lyke - * \A,x,y,Exy,B,f with 2 saturations - *) - let meta2no = fst (metas_that_saturate (l_c1 @ l_c2_b @ l_c2_a)) in - let sorted = - List.sort - (fun (i,ctx1,ty1) (j,ctx1,ty1) -> - try List.assoc i meta2no - List.assoc j meta2no - with Not_found -> assert false) - body_metasenv - in - let rec position_of n acc = - function - [] -> assert false - | (i,_,_)::_ when i = n -> acc - | _::tl -> position_of n (acc + 1) tl - in - let saturations_res, position_of_meta_to_be_coerced = - match meta_to_be_coerced with - | None -> 0,0 - | Some meta_to_be_coerced -> - debug_print - (lazy ("META_TO_BE_COERCED: " ^ string_of_int meta_to_be_coerced)); - let position_of_meta_to_be_coerced = - position_of meta_to_be_coerced 0 sorted in - debug_print (lazy ("POSITION_OF_META_TO_BE_COERCED: " ^ - string_of_int position_of_meta_to_be_coerced)); - List.length sorted - position_of_meta_to_be_coerced - 1, - position_of_meta_to_be_coerced - in - debug_print (lazy ("SATURATIONS: " ^ string_of_int saturations_res)); - sorted, saturations_res, position_of_meta_to_be_coerced - in - let namer l n = - let l = List.map (function Cic.Name s -> s | _ -> "A") l in - let l = List.fold_left - (fun acc s -> - let rec add' s = - if List.exists ((=) s) acc then add' (s^"'") else s - in - acc@[add' s]) - [] l - in - let l = List.rev l in - Cic.Name (List.nth l (n-1)) - in - debug_print (lazy ("\nCOMPOSING")); - debug_print (lazy (" c1= "^CicPp.ppterm c1 ^" : "^ CicPp.ppterm c1_ty)); - debug_print (lazy (" c2= "^CicPp.ppterm c2 ^" : "^ CicPp.ppterm c2_ty)); - let c1_pis, names_c1 = count_pis c1_ty arity1 in - let c2_pis, names_c2 = count_pis c2_ty arity2 in - let c = compose c1 c1_pis c2 c2_pis in - let spine_len = c1_pis + c2_pis in - let c = mk_lambda_spine c (namer (names_c1 @ names_c2)) spine_len in - debug_print (lazy ("COMPOSTA: " ^ CicPp.ppterm c)); - let old_insert_coercions = !CicRefine.insert_coercions in - let old_pack_coercions = !CicRefine.pack_coercions in - let c, metasenv, univ, saturationsres, cpos = - try - CicRefine.insert_coercions := false; - CicRefine.pack_coercions := false; - let term, ty, metasenv, ugraph = - CicRefine.type_of_aux' metasenv context c univ - in - debug_print(lazy("COMPOSED REFINED: "^CicPp.ppterm term)); - debug_print(lazy("COMPOSED REFINED (pretty): "^ - CicMetaSubst.ppterm_in_context [] ~metasenv term context)); -(* let metasenv = order_metasenv metasenv in *) -(* debug_print(lazy("ORDERED MENV: "^CicMetaSubst.ppmetasenv [] metasenv)); *) - let body_metasenv, lambdas_metasenv = - split_metasenv metasenv (spine_len + List.length context) - in - debug_print(lazy("B_MENV: "^CicMetaSubst.ppmetasenv [] body_metasenv)); - debug_print(lazy("L_MENV: "^CicMetaSubst.ppmetasenv [] lambdas_metasenv)); - let body_metasenv, saturationsres, cpos = - order_body_menv term body_metasenv c1_pis c2_pis - in - debug_print(lazy("ORDERED_B_MENV: "^CicMetaSubst.ppmetasenv [] body_metasenv)); - let subst = create_subst_from_metas_to_rels spine_len body_metasenv in - debug_print (lazy("SUBST: "^CicMetaSubst.ppsubst body_metasenv subst)); - let term = CicMetaSubst.apply_subst subst term in - let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in - debug_print (lazy ("COMPOSED SUBSTITUTED: " ^ CicPp.ppterm term)); - let term, ty, metasenv, ugraph = - CicRefine.type_of_aux' metasenv context term ugraph - in - let body_metasenv, lambdas_metasenv = - split_metasenv metasenv (spine_len + List.length context) - in - let lambdas_metasenv = - List.filter - (fun (i,_,_) -> - List.for_all (fun (j,_,_) -> i <> j) original_metasenv) - lambdas_metasenv - in - let term = purge_unused_lambdas lambdas_metasenv term in - let metasenv = - List.filter - (fun (i,_,_) -> - List.for_all - (fun (j,_,_) -> - i <> j || List.exists (fun (j,_,_) -> j=i) original_metasenv) - lambdas_metasenv) - metasenv - in - debug_print (lazy ("####################")); - debug_print (lazy ("COMPOSED: " ^ CicPp.ppterm term)); - debug_print (lazy ("SATURATIONS: " ^ string_of_int saturationsres)); - debug_print (lazy ("MENV: "^CicMetaSubst.ppmetasenv [] metasenv)); - debug_print (lazy ("####################")); - CicRefine.insert_coercions := old_insert_coercions; - CicRefine.pack_coercions := old_pack_coercions; - term, metasenv, ugraph, saturationsres, cpos - with - | CicRefine.RefineFailure s - | CicRefine.Uncertain s -> debug_print s; - CicRefine.insert_coercions := old_insert_coercions; - CicRefine.pack_coercions := old_pack_coercions; - raise UnableToCompose - | exn -> - CicRefine.insert_coercions := old_insert_coercions; - CicRefine.pack_coercions := old_pack_coercions; - raise exn - in - let c_ty, univ = - CicTypeChecker.type_of_aux' ~subst:[] [] [] c univ - in - let real_composed = ref true in - let c = - let rec is_id = function - | Cic.Lambda(_,_,t) -> is_id t - | Cic.Rel 1 -> true - | _ -> false - in - let is_id = function - | Cic.Const (u,_) -> - (match CicEnvironment.get_obj CicUniv.empty_ugraph u with - | Cic.Constant (_,Some bo,_,_,_), _ -> is_id bo - | _ -> false) - | _ -> false - in - let unvariant u = - match CicEnvironment.get_obj CicUniv.empty_ugraph u with - | Cic.Constant (_,Some (Cic.Const (u',_)),_,_,attrs), _ - when List.exists ((=) (`Flavour `Variant)) attrs -> - u' - | _ -> u - in - let is_variant u = - match CicEnvironment.get_obj CicUniv.empty_ugraph u with - | Cic.Constant (_,Some (Cic.Const (u',_)),_,_,attrs), _ - when List.exists ((=) (`Flavour `Variant)) attrs -> true - | _ -> false - in - let rec aux = function - | Cic.Lambda(n,s,t) -> Cic.Lambda(n,s,aux t) - | Cic.Appl (c::_) as t -> - let t = - if is_id c then - (real_composed := false ; - CicReduction.head_beta_reduce ~delta:true t) - else t - in - (match t with - | Cic.Appl l -> Cic.Appl (List.map aux l) - | Cic.Const (u,[]) when is_variant u -> Cic.Const (unvariant u,[]) - | t -> t) - | Cic.Const (u,[]) when is_variant u -> Cic.Const (unvariant u,[]) - | t -> t - in - let simple_eta_c t = - let incr = - List.map (function Cic.Rel n -> Cic.Rel (n+1) | _ -> assert false) - in - let rec aux acc ctx = function - | Cic.Lambda (n,s,tgt) -> - aux (incr acc @ [Cic.Rel 1]) (Some (n,Cic.Decl s) ::ctx) tgt - | Cic.Appl (t::tl) when tl = acc && - CicTypeChecker.does_not_occur ctx 0 (List.length acc) t -> true, t - | t -> false, t - in - let b, newt = aux [] [] t in - if b then newt else t - in - simple_eta_c (aux c) - in - debug_print (lazy ("COMPOSED COMPRESSED: " ^ string_of_bool !real_composed ^" : " ^ CicPp.ppterm c)); - c, c_ty, metasenv, univ, saturationsres, arity2, cpos, !real_composed -;; - -let build_obj c c_ty univ arity is_var = - let cleaned_ty = - FreshNamesGenerator.clean_dummy_dependent_types c_ty - in - let obj = Cic.Constant ("xxxx",Some c,cleaned_ty,[], - [`Generated] @ if not is_var then [`Flavour `Variant] else [] ) in - - obj,univ -;; - -(* removes from l the coercions that are in !coercions *) -let filter_duplicates l coercions = - List.filter ( - fun (src,l1,tgt) -> - not (List.exists (fun (s,t,l2) -> - CoercDb.eq_carr s src && - CoercDb.eq_carr t tgt && - try - List.for_all2 (fun (u1,_,_) (u2,_,_) -> UriManager.eq u1 u2) l1 l2 - with - | Invalid_argument "List.for_all2" -> - debug_print (lazy("XXX")); false) - coercions)) - l -;; - -let mangle s t l = - (*List.fold_left - (fun s x -> s ^ "_" ^ x) - (s ^ "_OF_" ^ t ^ "_BY" ^ string_of_int (List.length l)) l*) - s ^ "_OF_" ^ t -;; - -exception ManglingFailed of string - -let number_if_already_defined buri name l = - let err () = - raise - (ManglingFailed - ("Unable to give an altenative name to " ^ buri ^ "/" ^ name ^ ".con")) - in - let rec aux n = - let suffix = if n > 0 then ("__" ^ string_of_int n) else "" in - let suri = buri ^ "/" ^ name ^ suffix ^ ".con" in - let uri = UriManager.uri_of_string suri in - let retry () = if n < max_int then aux (n+1) else err () in - if List.exists (UriManager.eq uri) l then retry () - else - try - let _ = Http_getter.resolve' ~local:true ~writable:true uri in - if Http_getter.exists' ~local:true uri then retry () else uri - with - | Http_getter_types.Key_not_found _ -> uri - | Http_getter_types.Unresolvable_URI _ -> assert false - in - aux 0 -;; - -(* 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 saturations baseuri = - (* check if the coercion already exists *) - let coercions = CoercDb.to_list (CoercDb.dump ()) in - let todo_list = get_closure_coercions src tgt (uri,saturations,0) coercions in - debug_print (lazy("composed " ^ string_of_int (List.length todo_list))); - let todo_list = filter_duplicates todo_list coercions in - try - let new_coercions = - List.fold_left - (fun acc (src, l , tgt) -> - try - match l with - | [] -> assert false - | (he,saturations1,arity1) :: tl -> - let first_step = - Cic.Constant ("", Some (CicUtil.term_of_uri he), - Cic.Sort Cic.Prop, [], [`Generated]), - saturations1, - arity1,0 - in - let o,_ = - List.fold_left (fun (o,univ) (coer,saturations2,arity2) -> - match o with - | Cic.Constant (_,Some u,_,[],_),saturations1,arity1,_ -> - let t, t_ty, menv, univ, saturationsres, - arityres, cposres, is_var - = - generate_composite' (u,saturations1,arity1) - (CicUtil.term_of_uri coer, - saturations2, arity2) [] [] univ - in - if (menv <> []) then - HLog.warn "MENV non empty after composing coercions"; - let o,univ = build_obj t t_ty univ arityres is_var in - (o,saturationsres,arityres,cposres),univ - | _ -> assert false - ) (first_step, CicUniv.oblivion_ugraph) tl - in - let name_src = CoercDb.string_of_carr src in - let name_tgt = CoercDb.string_of_carr tgt in - let by = List.map (fun u,_,_ -> UriManager.name_of_uri u) l in - let name = mangle name_tgt name_src by in - let c_uri = - number_if_already_defined baseuri name - (List.map (fun (_,_,u,_,_,_,_) -> u) acc) - in - let named_obj,saturations,arity,cpos = - match o with - | Cic.Constant (_,bo,ty,vl,attrs),saturations,arity,cpos -> - Cic.Constant (name,bo,ty,vl,attrs),saturations,arity,cpos - | _ -> assert false - in - (src,tgt,c_uri,saturations,named_obj,arity,cpos)::acc - with UnableToCompose -> acc - ) [] todo_list - in - new_coercions - with ManglingFailed s -> HLog.error s; [] -;; - -CicCoercion.set_close_coercion_graph close_coercion_graph;; - -(* generate_composite (c2 (c1 s)) in the universe graph univ - * both living in the same context and metasenv *) -let generate_composite c1 c2 context metasenv univ sat1 sat2 = - let a,_,b,c,_,_,_,_ = - generate_composite' (c1,sat1,0) (c2,sat2,0) context metasenv univ - in - a,b,c -;; diff --git a/matita/components/tactics/closeCoercionGraph.mli b/matita/components/tactics/closeCoercionGraph.mli deleted file mode 100644 index 70c4eff9a..000000000 --- a/matita/components/tactics/closeCoercionGraph.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -(* This module implements the Coercions transitive closure *) - -val close_coercion_graph: - CoercDb.coerc_carr -> CoercDb.coerc_carr -> UriManager.uri -> int -> - string (* baseuri *) -> - (CoercDb.coerc_carr * CoercDb.coerc_carr * UriManager.uri * - int (* saturations *) * Cic.obj * int (* arity *) * int (* cpos *)) list - -exception UnableToCompose - -val generate_composite: - Cic.term -> Cic.term (* t2 *) -> Cic.context -> - Cic.metasenv -> CicUniv.universe_graph -> - int -> int (* saturations of t1/t2 *) -> - Cic.term * Cic.metasenv * CicUniv.universe_graph diff --git a/matita/components/tactics/compose.ml b/matita/components/tactics/compose.ml deleted file mode 100644 index e009010a7..000000000 --- a/matita/components/tactics/compose.ml +++ /dev/null @@ -1,195 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -let debug = false;; -let debug_print = - if not debug then (fun _ -> ()) else (fun s -> prerr_endline (Lazy.force s)) -;; - -let rec count_pi = function Cic.Prod (_,_,t) -> count_pi t + 1 | _ -> 0 ;; - -let compose_core t2 t1 (proof, goal) = - let _,metasenv,_subst,_,_,_ = proof in - let _,context,_ = CicUtil.lookup_meta goal metasenv in - let ty1,_ = - CicTypeChecker.type_of_aux' metasenv context t1 CicUniv.oblivion_ugraph - in - let ty2,_ = - CicTypeChecker.type_of_aux' metasenv context t2 CicUniv.oblivion_ugraph - in - let saturated_ty2, menv_for_saturated_ty2, args_t2 = - let maxm = CicMkImplicit.new_meta metasenv [] in - let ty2, menv, args, _ = - TermUtil.saturate_term ~delta:false maxm metasenv context ty2 0 in - ty2, menv, args - in - let saturations_t2 = - let rec aux n = function - | Cic.Meta (i,_)::tl -> - let _,c,ty = CicUtil.lookup_meta i menv_for_saturated_ty2 in - if fst (CicReduction.are_convertible c ty (Cic.Sort Cic.Prop) - CicUniv.oblivion_ugraph) - then n else aux (n+1) tl - | _::tl -> aux (n+1) tl - | [] -> n+1 - in - List.length args_t2 - aux 0 args_t2 +1 - in - debug_print (lazy("saturated_ty2: "^CicMetaSubst.ppterm_in_context - [] ~metasenv:menv_for_saturated_ty2 saturated_ty2 context ^ - " saturations_t2:" ^ string_of_int saturations_t2)); - (* unifies t with saturated_ty2 and gives back a fresh meta of type t *) - let unif menv t = - let m, menv2 = - let n = CicMkImplicit.new_meta menv [] in - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context - in - Cic.Meta (n,irl), ((n,context,t)::menv) - in - try - let _ = - CicUnification.fo_unif menv context t saturated_ty2 - CicUniv.oblivion_ugraph - in - true, menv2, m - with - | CicUnification.UnificationFailure _ - | CicUnification.Uncertain _ -> false, menv2, m - in - (* check which "positions" in the input arrow unifies with saturated_ty2 *) - let rec positions menv cur saturations = function - | Cic.Prod (n,s,t) -> - let b, newmenv, sb = unif menv s in - if b then - (saturations - cur - 1) :: - (positions newmenv (cur + 1) saturations - (CicSubstitution.subst sb t)) - else - positions newmenv (cur + 1) saturations (CicSubstitution.subst sb t) - | _ -> [] - in - (* position is a list of arities, that is if t1 : a -> b -> c and saturations - * is 0 then the computed term will be (t1 ? t2) of type a -> c if saturations - * is 1 then (t1 t2 ?) of type b -> c *) - let rec generate positions menv acc = - match positions with - | [] -> acc, menv - | saturations_t1::tl -> - try - let t, menv1, _ = - CloseCoercionGraph.generate_composite t2 t1 context menv - CicUniv.oblivion_ugraph saturations_t2 saturations_t1 - in - assert (List.length menv1 = List.length menv); - generate tl menv (t::acc) - with - | CloseCoercionGraph.UnableToCompose -> generate tl menv acc - in - let terms, metasenv = - generate (positions menv_for_saturated_ty2 0 (count_pi ty1) ty1) metasenv [] - in - (* the new proof has the resulting metasenv (shouldn't it be the same?) *) - let proof = - let uri, _, _subst, bo, ty, attrs = proof in - uri, metasenv, _subst, bo, ty, attrs - in - (* now we have the terms, we generalize them and intros them *) - let proof, goal = - List.fold_left - (fun (proof,goal) t -> - let lazy_of t = - ProofEngineTypes.const_lazy_term t - in - let proof, gl = - ProofEngineTypes.apply_tactic - (PrimitiveTactics.generalize_tac (Some (lazy_of t), [], None)) - (proof,goal) - in - assert(List.length gl = 1); - proof,List.hd gl) - (proof,goal) terms - in - (proof, goal), List.length terms -;; - -let compose_tac ?howmany ?mk_fresh_name_callback n t1 t2 proofstatus = - let ((proof, goal), k), n = - match t2 with - | Some t2 -> compose_core t1 t2 proofstatus, n-1 - | None -> - let k = - let proof, goal = proofstatus in - let _,metasenv,subst,_,_,_ = proof in - let _,_,ty = CicUtil.lookup_meta goal metasenv in - count_pi (CicMetaSubst.apply_subst subst ty) - in - (proofstatus, k), n - in - let (proof, goal), k = - (* fix iterates n times the composition *) - let rec fix proofstatus k t = function - | 0 -> proofstatus, k - | n -> - let t = CicSubstitution.lift k t in - let proof, gl = - ProofEngineTypes.apply_tactic - (PrimitiveTactics.intros_tac - ~howmany:k ?mk_fresh_name_callback ()) proofstatus - in - assert (List.length gl = 1); - let goal = List.hd gl in - let k, proofstatus = - (* aux compose t with every previous result *) - let rec aux k proofstatus = function - | 0 -> k, proofstatus - | n -> - let (proof, goal), k1 = - compose_core t (Cic.Rel n) proofstatus - in - aux (k+k1) (proof, goal) (n-1) - in - aux 0 (proof, goal) k - in - fix proofstatus k t (n-1) - in - fix (proof, goal) k t1 n - in - let howmany = - match howmany with - | None -> None - | Some i -> - if i - k < 0 then (* we should generalize back and clear *) Some 0 - else Some (i - k) - in - ProofEngineTypes.apply_tactic - (PrimitiveTactics.intros_tac ?howmany ?mk_fresh_name_callback ()) - (proof,goal) -;; - -let compose_tac ?howmany ?mk_fresh_name_callback times t1 t2 = - ProofEngineTypes.mk_tactic - (compose_tac ?howmany ?mk_fresh_name_callback times t1 t2) -;; diff --git a/matita/components/tactics/compose.mli b/matita/components/tactics/compose.mli deleted file mode 100644 index 44db74b76..000000000 --- a/matita/components/tactics/compose.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -val compose_tac: - ?howmany:int -> - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - int (* times *) -> - Cic.term -> Cic.term option -> ProofEngineTypes.tactic diff --git a/matita/components/tactics/declarative.ml b/matita/components/tactics/declarative.ml deleted file mode 100644 index 02d7c6144..000000000 --- a/matita/components/tactics/declarative.ml +++ /dev/null @@ -1,311 +0,0 @@ -(* Copyright (C) 2006, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type just = [ `Term of Cic.term | `Auto of Auto.auto_params ] - -let mk_just ~dbd ~automation_cache = - function - `Auto (l,params) -> - Tactics.auto ~dbd - ~params:(l,("skip_trie_filtering","1")::(*("skip_context","1")::*)params) ~automation_cache - | `Term t -> Tactics.apply t -;; - -let assume id t = - Tacticals.then_ - ~start: - (Tactics.intros ~howmany:1 - ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name id) ()) - ~continuation: - (Tactics.change ~pattern:(None,[id,Cic.Implicit (Some `Hole)],None) - (fun _ metasenv ugraph -> t,metasenv,ugraph)) -;; - -let suppose t id ty = -(*BUG: check on t missing *) - let ty = match ty with None -> t | Some ty -> ty in - Tacticals.then_ - ~start: - (Tactics.intros ~howmany:1 - ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name id) ()) - ~continuation: - (Tactics.change ~pattern:(None,[id,Cic.Implicit (Some `Hole)],None) - (fun _ metasenv ugraph -> ty,metasenv,ugraph)) -;; - -let by_just_we_proved ~dbd ~automation_cache just ty id ty' = - let just = mk_just ~dbd ~automation_cache just in - match id with - None -> - (match ty' with - None -> assert false - | Some ty' -> - Tacticals.then_ - ~start:(Tactics.change - ~pattern:(ProofEngineTypes.conclusion_pattern None) - (fun _ metasenv ugraph -> ty,metasenv,ugraph)) - ~continuation:just - ) - | Some id -> - let ty',continuation = - match ty' with - None -> ty,just - | Some ty' -> - ty', - Tacticals.then_ - ~start: - (Tactics.change - ~with_cast:true - ~pattern:(None,[id,Cic.Implicit (Some `Hole)],None) - (fun _ metasenv ugraph -> ty,metasenv,ugraph)) - ~continuation:just - in - Tacticals.thens - ~start: - (Tactics.cut ty' - ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name id)) - ~continuations:[ Tacticals.id_tac ; continuation ] -;; - -let bydone ~dbd ~automation_cache just = - mk_just ~dbd ~automation_cache just -;; - -let we_need_to_prove t id ty = - match id with - None -> - (match ty with - None -> Tacticals.id_tac (*BUG: check missing here *) - | Some ty -> - Tactics.change ~pattern:(ProofEngineTypes.conclusion_pattern None) - (fun _ metasenv ugraph -> ty,metasenv,ugraph)) - | Some id -> - let aux status = - let cont,cutted = - match ty with - None -> Tacticals.id_tac,t - | Some ty -> - Tactics.change ~pattern:(None,[id,Cic.Implicit (Some `Hole)],None) - (fun _ metasenv ugraph -> t,metasenv,ugraph), ty in - let proof,goals = - ProofEngineTypes.apply_tactic - (Tacticals.thens - ~start: - (Tactics.cut cutted - ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name id)) - ~continuations:[cont]) - status - in - let goals' = - match goals with - [fst; snd] -> [snd; fst] - | _ -> assert false - in - proof,goals' - in - ProofEngineTypes.mk_tactic aux -;; - -let existselim ~dbd ~automation_cache just id1 t1 id2 t2 = - let aux (proof, goal) = - let (n,metasenv,_subst,bo,ty,attrs) = proof in - let metano,context,_ = CicUtil.lookup_meta goal metasenv in - let t2, metasenv, _ = t2 (Some (Cic.Name id1, Cic.Decl t1) :: context) metasenv CicUniv.oblivion_ugraph in - let proof' = (n,metasenv,_subst,bo,ty,attrs) in - ProofEngineTypes.apply_tactic ( - Tacticals.thens - ~start:(Tactics.cut (Cic.Appl [Cic.MutInd (UriManager.uri_of_string "cic:/matita/logic/connectives/ex.ind", 0, []); t1 ; Cic.Lambda (Cic.Name id1, t1, t2)])) - ~continuations: - [ Tactics.elim_intros (Cic.Rel 1) - ~mk_fresh_name_callback: - (let i = ref 0 in - fun _ _ _ ~typ -> - incr i; - if !i = 1 then Cic.Name id1 else Cic.Name id2) ; - (mk_just ~dbd ~automation_cache just) - ]) (proof', goal) - in - ProofEngineTypes.mk_tactic aux -;; - -let andelim ~dbd ~automation_cache just id1 t1 id2 t2 = - Tacticals.thens - ~start:(Tactics.cut (Cic.Appl [Cic.MutInd (UriManager.uri_of_string "cic:/matita/logic/connectives/And.ind", 0, []); t1 ; t2])) - ~continuations: - [ Tactics.elim_intros (Cic.Rel 1) - ~mk_fresh_name_callback: - (let i = ref 0 in - fun _ _ _ ~typ -> - incr i; - if !i = 1 then Cic.Name id1 else Cic.Name id2) ; - (mk_just ~dbd ~automation_cache just) ] -;; - -let rewritingstep ~dbd ~automation_cache lhs rhs just last_step = - let aux ((proof,goal) as status) = - let (curi,metasenv,_subst,proofbo,proofty, attrs) = proof in - let _,context,gty = CicUtil.lookup_meta goal metasenv in - let eq,trans = - match LibraryObjects.eq_URI () with - None -> raise (ProofEngineTypes.Fail (lazy "You need to register the default equality first. Please use the \"default\" command")) - | Some uri -> - Cic.MutInd (uri,0,[]), Cic.Const (LibraryObjects.trans_eq_URI ~eq:uri,[]) - in - let ty,_ = - CicTypeChecker.type_of_aux' metasenv context rhs CicUniv.oblivion_ugraph in - let just' = - match just with - `Auto (univ, params) -> - let params = - if not (List.exists (fun (k,_) -> k = "timeout") params) then - ("timeout","3")::params - else params - in - let params' = - if not (List.exists (fun (k,_) -> k = "paramodulation") params) then - ("paramodulation","1")::params - else params - in - if params = params' then - Tactics.auto ~dbd ~params:(univ, params) ~automation_cache - else - Tacticals.first - [Tactics.auto ~dbd ~params:(univ, params) ~automation_cache ; - Tactics.auto ~dbd ~params:(univ, params') ~automation_cache] - | `Term just -> Tactics.apply just - | `SolveWith term -> - Tactics.demodulate ~automation_cache ~dbd - ~params:(Some [term], - ["all","1";"steps","1"; "use_context","false"]) - | `Proof -> - Tacticals.id_tac - in - let plhs,prhs,prepare = - match lhs with - None -> - let plhs,prhs = - match gty with - Cic.Appl [_;_;plhs;prhs] -> plhs,prhs - | _ -> assert false - in - plhs,prhs, - (fun continuation -> - ProofEngineTypes.apply_tactic continuation status) - | Some (None,lhs) -> - let plhs,prhs = - match gty with - Cic.Appl [_;_;plhs;prhs] -> plhs,prhs - | _ -> assert false - in - (*CSC: manca check plhs convertibile con lhs *) - plhs,prhs, - (fun continuation -> - ProofEngineTypes.apply_tactic continuation status) - | Some (Some name,lhs) -> - let newmeta = CicMkImplicit.new_meta metasenv [] in - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context in - let plhs = lhs in - let prhs = Cic.Meta(newmeta,irl) in - plhs,prhs, - (fun continuation -> - let metasenv = (newmeta, context, ty)::metasenv in - let mk_fresh_name_callback = - fun metasenv context _ ~typ -> - FreshNamesGenerator.mk_fresh_name ~subst:[] metasenv context - (Cic.Name name) ~typ - in - let proof = curi,metasenv,_subst,proofbo,proofty, attrs in - let proof,goals = - ProofEngineTypes.apply_tactic - (Tacticals.thens - ~start:(Tactics.cut ~mk_fresh_name_callback - (Cic.Appl [eq ; ty ; lhs ; prhs])) - ~continuations:[Tacticals.id_tac ; continuation]) (proof,goal) - in - let goals = - match just,goals with - `Proof, [g1;g2;g3] -> [g2;g3;newmeta;g1] - | _, [g1;g2] -> [g2;newmeta;g1] - | _, l -> - prerr_endline (String.concat "," (List.map string_of_int l)); - prerr_endline (CicMetaSubst.ppmetasenv [] metasenv); - assert false - in - proof,goals) - in - let continuation = - if last_step then - (*CSC:manca controllo sul fatto che rhs sia convertibile con prhs*) - just' - else - Tacticals.thens - ~start:(Tactics.apply ~term:(Cic.Appl [trans;ty;plhs;rhs;prhs])) - ~continuations:[just' ; Tacticals.id_tac] - in - prepare continuation - in - ProofEngineTypes.mk_tactic aux -;; - -let we_proceed_by_cases_on t pat = - (*BUG here: pat unused *) - Tactics.cases_intros t -;; - -let we_proceed_by_induction_on t pat = -(* let pattern = None, [], Some pat in *) - Tactics.elim_intros ~depth:0 (*~pattern*) t -;; - -let case id ~params = - (*BUG here: id unused*) - (*BUG here: it does not verify that the previous branch is closed *) - (*BUG here: the params should be parsed telescopically*) - (*BUG here: the tactic_terms should be terms*) - let rec aux ~params ((proof,goal) as status) = - match params with - [] -> proof,[goal] - | (id,t)::tl -> - match ProofEngineTypes.apply_tactic (assume id t) status with - proof,[goal] -> aux tl (proof,goal) - | _ -> assert false - in - ProofEngineTypes.mk_tactic (aux ~params) -;; - -let thesisbecomes t = -let ty = None in - match ty with - None -> - Tactics.change ~pattern:(None,[],Some (Cic.Implicit (Some `Hole))) - (fun _ metasenv ugraph -> t,metasenv,ugraph) - | Some ty -> - (*BUG here: missing check on t *) - Tactics.change ~pattern:(None,[],Some (Cic.Implicit (Some `Hole))) - (fun _ metasenv ugraph -> ty,metasenv,ugraph) -;; - -let byinduction t id = suppose t id None;; diff --git a/matita/components/tactics/declarative.mli b/matita/components/tactics/declarative.mli deleted file mode 100644 index 21e49b8e2..000000000 --- a/matita/components/tactics/declarative.mli +++ /dev/null @@ -1,66 +0,0 @@ -(* Copyright (C) 2006, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type just = [ `Term of Cic.term | `Auto of Auto.auto_params ] - -val assume : string -> Cic.term -> ProofEngineTypes.tactic - -val suppose : Cic.term -> string -> Cic.term option -> ProofEngineTypes.tactic - -val by_just_we_proved : - dbd:HSql.dbd -> automation_cache:AutomationCache.cache -> - just -> Cic.term -> string option -> Cic.term option -> - ProofEngineTypes.tactic - -val bydone : dbd:HSql.dbd -> automation_cache:AutomationCache.cache -> - just -> ProofEngineTypes.tactic - -val we_need_to_prove : - Cic.term -> string option -> Cic.term option -> ProofEngineTypes.tactic - -val we_proceed_by_cases_on : Cic.term -> Cic.term -> ProofEngineTypes.tactic - -val we_proceed_by_induction_on : Cic.term -> Cic.term -> ProofEngineTypes.tactic - -val byinduction : Cic.term -> string -> ProofEngineTypes.tactic - -val thesisbecomes : Cic.term -> ProofEngineTypes.tactic - -val case : string -> params:(string * Cic.term) list -> ProofEngineTypes.tactic - -val existselim : - dbd:HSql.dbd -> automation_cache:AutomationCache.cache -> just -> - string -> Cic.term -> string -> Cic.lazy_term -> ProofEngineTypes.tactic - -val andelim : - dbd:HSql.dbd -> automation_cache:AutomationCache.cache -> just -> - string -> Cic.term -> string -> Cic.term -> ProofEngineTypes.tactic - -val rewritingstep : - dbd:HSql.dbd -> automation_cache:AutomationCache.cache -> - (string option * Cic.term) option -> Cic.term -> - [ `Term of Cic.term | `Auto of Auto.auto_params - | `Proof | `SolveWith of Cic.term] -> - bool (* last step *) -> ProofEngineTypes.tactic diff --git a/matita/components/tactics/destructTactic.ml b/matita/components/tactics/destructTactic.ml deleted file mode 100644 index f6fb61ac1..000000000 --- a/matita/components/tactics/destructTactic.ml +++ /dev/null @@ -1,592 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -module C = Cic -module U = UriManager -module P = PrimitiveTactics -module T = Tacticals -module CR = CicReduction -module PST = ProofEngineStructuralRules -module PET = ProofEngineTypes -module CTC = CicTypeChecker -module CU = CicUniv -module S = CicSubstitution -module RT = ReductionTactics -module PEH = ProofEngineHelpers -module ET = EqualityTactics -module DTI = DoubleTypeInference - -let debug = false -let debug_print = - if debug then (fun x -> prerr_endline (Lazy.force x)) else (fun _ -> ()) - -(* term ha tipo t1=t2; funziona solo se t1 e t2 hanno in testa costruttori -diversi *) - -let discriminate_tac ~term = - let true_URI = - match LibraryObjects.true_URI () with - Some uri -> uri - | None -> raise (PET.Fail (lazy "You need to register the default \"true\" definition first. Please use the \"default\" command")) in - let false_URI = - match LibraryObjects.false_URI () with - Some uri -> uri - | None -> raise (PET.Fail (lazy "You need to register the default \"false\" definition first. Please use the \"default\" command")) in - let fail msg = raise (PET.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_branches_and_outtype turi typeno consno context args = - (* a list of "True" except for the element in position consno which - * is "False" *) - match fst (CicEnvironment.get_obj CU.oblivion_ugraph turi) with - | C.InductiveDefinition (ind_type_list,_,paramsno,_) -> - let _,_,rty,constructor_list = List.nth ind_type_list typeno in - let false_constr_id,_ = List.nth constructor_list (consno - 1) in - let branches = - List.map - (fun (id,cty) -> - (* dubbio: e' corretto ridurre in questo context ??? *) - let red_ty = CR.whd context cty in - let rec aux t k = - match t with - | C.Prod (_,_,target) when (k <= paramsno) -> - S.subst (List.nth args (k-1)) - (aux target (k+1)) - | C.Prod (binder,source,target) when (k > paramsno) -> - C.Lambda (binder, source, (aux target (k+1))) - | _ -> - if (id = false_constr_id) - then (C.MutInd(false_URI,0,[])) - else (C.MutInd(true_URI,0,[])) - in - (S.lift 1 (aux red_ty 1))) - constructor_list in - let outtype = - let seed = ref 0 in - let rec mk_lambdas rev_left_args = - function - 0, args, C.Prod (_,so,ta) -> - C.Lambda - (C.Name (incr seed; "x" ^ string_of_int !seed), - so, - mk_lambdas rev_left_args (0,args,ta)) - | 0, args, C.Sort _ -> - let rec mk_rels = - function - 0 -> [] - | n -> C.Rel n :: mk_rels (n - 1) in - let argsno = List.length args in - C.Lambda - (C.Name "x", - (if argsno + List.length rev_left_args > 0 then - C.Appl - (C.MutInd (turi, typeno, []) :: - (List.map - (S.lift (argsno + 1)) - (List.rev rev_left_args)) @ - mk_rels argsno) - else - C.MutInd (turi,typeno,[])), - C.Sort C.Prop) - | 0, _, _ -> assert false (* seriously screwed up *) - | n, he::tl, C.Prod (_,_,ta) -> - mk_lambdas (he::rev_left_args)(n-1,tl,S.subst he ta) - | n,_,_ -> - assert false (* we should probably reduce in some context *) - in - mk_lambdas [] (paramsno, args, rty) - in - branches, outtype - | _ -> assert false - in - let discriminate'_tac ~term status = - let (proof, goal) = status in - let _,metasenv,_subst,_,_, _ = proof in - let _,context,_ = CicUtil.lookup_meta goal metasenv in - let termty,_ = - CTC.type_of_aux' metasenv context term CU.oblivion_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,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)::args)) -> - turi,typeno,exp_named_subst,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 branches,outtype = - mk_branches_and_outtype turi typeno consno context args - in - PET.apply_tactic - (T.then_ - ~start:(EliminationTactics.elim_type_tac (C.MutInd (false_URI, 0, []))) - ~continuation: - (T.then_ - ~start: - (RT.change_tac - ~pattern:(PET.conclusion_pattern None) - (fun _ m u -> - C.Appl [ - C.Lambda ( C.Name "x", tty, - C.MutCase (turi, typeno, outtype, (C.Rel 1), branches)); - t2 ], - m, u)) - ~continuation: - (T.then_ - ~start: - (ET.rewrite_simpl_tac - ~direction:`RightToLeft - ~pattern:(PET.conclusion_pattern None) - term []) - ~continuation: - (IntroductionTactics.constructor_tac ~n:1)))) status - | _ -> fail "not an equality" - in - PET.mk_tactic (discriminate'_tac ~term) - -let exn_noneq = - PET.Fail (lazy "Injection: not an equality") -let exn_nothingtodo = - PET.Fail (lazy "Nothing to do") -let exn_discrnonind = - PET.Fail (lazy "Discriminate: object is not an Inductive Definition: it's imposible") -let exn_injwronggoal = - PET.Fail (lazy "Injection: goal after cut is not correct") -let exn_noneqind = - PET.Fail (lazy "Injection: not an equality over elements of an inductive type") - -let pp ctx t = - let names = List.map (function Some (n,_) -> Some n | None -> None) ctx in - CicPp.pp t names - -let clear_term first_time lterm = - let clear_term status = - let (proof, goal) = status in - let _,metasenv,_subst,_,_, _ = proof in - let _,context,_ = CicUtil.lookup_meta goal metasenv in - let term, metasenv, _ugraph = lterm context metasenv CU.oblivion_ugraph in - debug_print (lazy ("\nclear di: " ^ pp context term)); - debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context)); - let g () = if first_time then raise exn_nothingtodo else T.id_tac in - let tactic = match term with - | C.Rel n -> - begin match List.nth context (pred n) with - | Some (C.Name id, _) -> - T.if_ ~fail:(g ()) ~start:(PST.clear ~hyps:[id]) ~continuation:T.id_tac - | _ -> assert false - end - | _ -> g () - in - PET.apply_tactic tactic status - in - PET.mk_tactic clear_term - -let exists context = function - | C.Rel i -> List.nth context (pred i) <> None - | _ -> true - -let recur_on_child_tac ~before ~after = - let recur_on_child status = - let (proof, goal) = status in - let _, metasenv, _subst, _, _, _ = proof in - let _, context, _ = CicUtil.lookup_meta goal metasenv in - debug_print (lazy ("\nrecur_on_child")); - debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context)); - let mk_lterm term c m ug = - let distance = List.length c - List.length context in - S.lift distance term, m, ug - in - let lterm = mk_lterm (Cic.Rel 1) in - let tactic = T.then_ ~start:before ~continuation:(after lterm) in - PET.apply_tactic tactic status - in - PET.mk_tactic recur_on_child - -let injection_tac ~lterm ~i ~continuation ~recur = - let give_name seed = function - | C.Name _ as name -> name - | C.Anonymous -> C.Name (incr seed; "y" ^ string_of_int !seed) - in - let rec mk_rels = function | 0 -> [] | n -> C.Rel n :: (mk_rels (n - 1)) in - let injection_tac 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 _,metasenv,_subst,_,_, _ = proof in - let _,context,_ = CicUtil.lookup_meta goal metasenv in - let term, metasenv, _ugraph = lterm context metasenv CU.oblivion_ugraph in - let termty,_ = - CTC.type_of_aux' metasenv context term CU.oblivion_ugraph - in - debug_print (lazy ("\ninjection su : " ^ pp context termty)); - match termty with (* an equality *) - | C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2] - when LibraryObjects.is_eq_URI equri -> - let turi,typeno,ens,params = - match tty with (* some inductive type *) - | C.MutInd (turi,typeno,ens) -> turi,typeno,ens,[] - | C.Appl (C.MutInd (turi,typeno,ens)::params) -> turi,typeno,ens,params - | _ -> raise exn_noneqind - in - let t1',t2',consno = (* sono i due sottotermini che differiscono *) - match t1,t2 with - | C.Appl ((C.MutConstruct (uri1,typeno1,consno1,ens1))::applist1), - C.Appl ((C.MutConstruct (uri2,typeno2,consno2,ens2))::applist2) - when (uri1 = uri2) && (typeno1 = typeno2) && - (consno1 = consno2) && (ens1 = ens2) -> - (* controllo ridondante *) - List.nth applist1 (pred i),List.nth applist2 (pred i),consno2 - | _ -> assert false - in - let tty',_ = CTC.type_of_aux' metasenv context t1' CU.oblivion_ugraph in - let patterns,outtype = - match fst (CicEnvironment.get_obj CU.oblivion_ugraph turi) with - | C.InductiveDefinition (ind_type_list,_,paramsno,_)-> - let left_params, right_params = HExtlib.split_nth paramsno params in - let _,_,_,constructor_list = List.nth ind_type_list typeno in - let i_constr_id,_ = List.nth constructor_list (consno - 1) in - let patterns = - let seed = ref 0 in - List.map - (function (id,cty) -> - let reduced_cty = CR.whd context cty in - let rec aux k = function - | C.Prod (_,_,tgt) when k <= paramsno -> - let left = List.nth left_params (k-1) in - aux (k+1) (S.subst left tgt) - | C.Prod (binder,source,target) when k > paramsno -> - let binder' = give_name seed binder in - C.Lambda (binder',source,(aux (k+1) target)) - | _ -> - let nr_param_constr = k - paramsno - 1 in - if id = i_constr_id then C.Rel (k - i) - else S.lift nr_param_constr t1' - (* + 1 per liftare anche il lambda aggiunto - * esternamente al case *) - in S.lift 1 (aux 1 reduced_cty)) - constructor_list - in - (* this code should be taken from cases_tac *) - let outtype = - let seed = ref 0 in - let rec to_lambdas te head = - match CR.whd context te with - | C.Prod (binder,so,ta) -> - let binder' = give_name seed binder in - C.Lambda (binder',so,to_lambdas ta head) - | _ -> head - in - let rec skip_prods params te = - match params, CR.whd context te with - | [], _ -> te - | left::tl, C.Prod (_,_,ta) -> - skip_prods tl (S.subst left ta) - | _, _ -> assert false - in - let abstracted_tty = - let tty = - List.fold_left (fun x y -> S.subst y x) tty left_params - in - (* non lift, ma subst coi left! *) - match S.lift 1 tty with - | C.MutInd _ as tty' -> tty' - | C.Appl l -> - let keep,abstract = HExtlib.split_nth (paramsno +1) l in - let keep = List.map (S.lift paramsno) keep in - C.Appl (keep@mk_rels (List.length abstract)) - | _ -> assert false - in - match ind_type_list with - | [] -> assert false - | (_,_,ty,_)::_ -> - (* this is in general wrong, do as in cases_tac *) - to_lambdas (skip_prods left_params ty) - (C.Lambda - (C.Name "cased", abstracted_tty, - (* here we should capture right parameters *) - (* 1 for his Lambda, one for the Lambda outside the match - * and then one for each to_lambda *) - S.lift (2+List.length right_params) tty')) - in - patterns,outtype - | _ -> raise exn_discrnonind - in - let cutted = C.Appl [C.MutInd (equri,0,[]) ; tty' ; t1' ; t2'] in - let changed = - C.Appl [ C.Lambda (C.Name "x", tty, - C.MutCase (turi,typeno,outtype,C.Rel 1,patterns)) ; t1] - in - (* check if cutted and changed are well typed and if t1' ~ changed *) - let go_on = - try - let _,g = CTC.type_of_aux' metasenv context cutted - CU.oblivion_ugraph - in - let _,g = CTC.type_of_aux' metasenv context changed g in - fst (CR.are_convertible ~metasenv context t1' changed g) - with - | CTC.TypeCheckerFailure _ -> false - in - if not go_on then begin - HLog.warn "destruct: injection failed"; - PET.apply_tactic continuation status - end else - let fill_cut_tac term = - let fill_cut status = - debug_print (lazy "riempio il cut"); - let (proof, goal) = status in - let _,metasenv,_subst,_,_, _ = proof in - let _,context,gty = CicUtil.lookup_meta goal metasenv in - let gty = Unshare.unshare gty in - let new_t1' = match gty with - | (C.Appl (C.MutInd (_,_,_)::_::t::_)) -> t - | _ -> raise exn_injwronggoal - in - debug_print (lazy ("metto: " ^ pp context changed)); - debug_print (lazy ("al posto di: " ^ pp context new_t1')); - debug_print (lazy ("nel goal: " ^ pp context gty)); - debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context)); - debug_print (lazy ("e poi rewrite con: "^pp context term)); - let tac = T.seq ~tactics:[ - RT.change_tac - ~pattern:(None, [], Some (PEH.pattern_of ~term:gty [new_t1'])) - (fun _ m u -> changed,m,u); - ET.rewrite_simpl_tac - ~direction:`LeftToRight - ~pattern:(PET.conclusion_pattern None) - term []; - ET.reflexivity_tac - ] in - PET.apply_tactic tac status - in - PET.mk_tactic fill_cut - in - debug_print (lazy ("CUT: " ^ pp context cutted)); - let tactic = - T.thens ~start: (P.cut_tac cutted) - ~continuations:[ - recur_on_child_tac continuation recur; - fill_cut_tac term - ] - in - PET.apply_tactic tactic status - | _ -> raise exn_noneq - in - PET.mk_tactic injection_tac - -let subst_tac ~lterm ~direction ~where ~continuation ~recur = - let subst_tac status = - let (proof, goal) = status in - let _,metasenv,_subst,_,_, _ = proof in - let _,context,_ = CicUtil.lookup_meta goal metasenv in - let term, metasenv, _ugraph = lterm context metasenv CU.oblivion_ugraph in - debug_print (lazy ("\nsubst " ^ (match direction with `LeftToRight -> "->" | `RightToLeft -> "<-") ^ " di: " ^ pp context term)); - let tactic = match where with - | None -> - debug_print (lazy ("nella conclusione")); - let pattern = PET.conclusion_pattern None in - let tactic = ET.rewrite_tac ~direction ~pattern term [] in - T.then_ ~start:(T.try_tactic ~tactic) ~continuation - | Some name -> - debug_print (lazy ("nella premessa: " ^ name)); - let pattern = None, [name, PET.hole], None in - let start = ET.rewrite_tac ~direction ~pattern term [] in - let ok_tactic = recur_on_child_tac continuation recur in - T.if_ ~start ~continuation:ok_tactic ~fail:continuation - in - PET.apply_tactic tactic status - in - PET.mk_tactic subst_tac - -let rec destruct ~first_time lterm = - let are_convertible hd1 hd2 metasenv context = - fst (CR.are_convertible ~metasenv context hd1 hd2 CU.oblivion_ugraph) - in - let recur = destruct ~first_time:false in - let destruct status = - let (proof, goal) = status in - let _,metasenv,_subst, _,_, _ = proof in - let _,context,_ = CicUtil.lookup_meta goal metasenv in - let term, metasenv, _ugraph = lterm context metasenv CU.oblivion_ugraph in - let tactic = if not (first_time || exists context term) then T.id_tac else begin - debug_print (lazy ("\ndestruct di: " ^ pp context term)); - debug_print (lazy ("nel contesto:\n" ^ CicPp.ppcontext context)); - let termty,_ = CTC.type_of_aux' metasenv context term CU.oblivion_ugraph in - debug_print (lazy ("\ndestruct su: " ^ pp context termty)); - let mk_lterm term c m ug = - let distance = List.length c - List.length context in - S.lift distance term, m, ug - in - let lterm = mk_lterm term in - let mk_subst_chain direction index with_what what = - let k = match term with C.Rel i -> i | _ -> -1 in - let rec traverse_context first_time j = function - | [] -> - let continuation = - T.seq ~tactics:[ - clear_term first_time lterm; - clear_term false (mk_lterm what); - clear_term false (mk_lterm with_what) - ] - in - subst_tac ~direction ~lterm ~where:None ~continuation ~recur - | Some (C.Name name, _) :: tl when j < index && j <> k -> - debug_print (lazy ("\nsubst programmata: cosa: " ^ string_of_int index ^ ", dove: " ^ string_of_int j)); - subst_tac ~direction ~lterm ~where:(Some name) ~recur - ~continuation:(traverse_context false (succ j) tl) - | _ :: tl -> traverse_context first_time (succ j) tl - in - traverse_context first_time 1 context - in - match termty with - | C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2] - when LibraryObjects.is_eq_URI equri -> - begin match t1,t2 with -(* injection part *) - | C.MutConstruct _, - C.MutConstruct _ - when t1 = t2 -> clear_term first_time lterm - | C.Appl (C.MutConstruct _ as mc1 :: applist1), - C.Appl (C.MutConstruct _ as mc2 :: applist2) - when mc1 = mc2 -> - let rec traverse_list first_time i l1 l2 = - match l1, l2 with - | [], [] -> clear_term first_time lterm - | hd1 :: tl1, hd2 :: tl2 -> - if are_convertible hd1 hd2 metasenv context then - traverse_list first_time (succ i) tl1 tl2 - else - injection_tac ~i ~lterm ~recur ~continuation: - (traverse_list false (succ i) tl1 tl2) - | _ -> assert false - (* i 2 termini hanno in testa lo stesso costruttore, - * ma applicato a un numero diverso di termini *) - in - traverse_list first_time 1 applist1 applist2 -(* discriminate part *) - | C.MutConstruct (_,_,consno1,ens1), - C.MutConstruct (_,_,consno2,ens2) - | C.MutConstruct (_,_,consno1,ens1), - C.Appl ((C.MutConstruct (_,_,consno2,ens2))::_) - | C.Appl ((C.MutConstruct (_,_,consno1,ens1))::_), - C.MutConstruct (_,_,consno2,ens2) - | C.Appl ((C.MutConstruct (_,_,consno1,ens1))::_), - C.Appl ((C.MutConstruct (_,_,consno2,ens2))::_) - when (consno1 <> consno2) || (ens1 <> ens2) -> - discriminate_tac ~term -(* subst part *) - | C.Rel _, C.Rel _ when t1 = t2 -> - T.seq ~tactics:[ - clear_term first_time lterm; - clear_term false (mk_lterm t1) - ] - | C.Rel i1, C.Rel i2 when i1 < i2 -> - mk_subst_chain `LeftToRight i1 t2 t1 - | C.Rel i1, C.Rel i2 when i1 > i2 -> - mk_subst_chain `RightToLeft i2 t1 t2 - | C.Rel i1, _ when DTI.does_not_occur i1 t2 -> - mk_subst_chain `LeftToRight i1 t2 t1 - | _, C.Rel i2 when DTI.does_not_occur i2 t1 -> - mk_subst_chain `RightToLeft i2 t1 t2 -(* else part *) - | _ when first_time -> raise exn_nothingtodo - | _ (* when not first time *) -> T.id_tac - end - | _ when first_time -> raise exn_nothingtodo - | _ (* when not first time *) -> T.id_tac - end in - PET.apply_tactic tactic status - in - PET.mk_tactic destruct - -(* destruct performs either injection or discriminate or subst *) -let destruct_tac xterms = - let destruct status = - let (proof, goal) = status in - let _,metasenv,_subst,_,_, _ = proof in - let _,context,_ = CicUtil.lookup_meta goal metasenv in - let mk_lterm term c m ug = - let distance = List.length c - List.length context in - S.lift distance term, m, ug - in - let tactics = match xterms with - | Some terms -> - let map term = destruct ~first_time:false (mk_lterm term) in - List.map map terms - | None -> - let rec mk_tactics first_time i tacs = function - | [] -> List.rev tacs - | Some _ :: tl -> - let lterm = mk_lterm (C.Rel i) in - let tacs = destruct ~first_time lterm :: tacs in - mk_tactics false (succ i) tacs tl - | _ :: tl -> mk_tactics first_time (succ i) tacs tl - in - mk_tactics false 1 [] context - in - PET.apply_tactic (T.seq ~tactics) status - in - PET.mk_tactic destruct diff --git a/matita/components/tactics/destructTactic.mli b/matita/components/tactics/destructTactic.mli deleted file mode 100644 index cc3f0d5cf..000000000 --- a/matita/components/tactics/destructTactic.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* Performs a recursive comparisons of the two sides of an equation - looking for constructors. If the two sides differ on two constructors, - it closes the current goal. If they differ by other two terms it introduces - an equality. *) -val destruct_tac: Cic.term list option -> ProofEngineTypes.tactic diff --git a/matita/components/tactics/doc/Makefile b/matita/components/tactics/doc/Makefile deleted file mode 100644 index b7d8fb45c..000000000 --- a/matita/components/tactics/doc/Makefile +++ /dev/null @@ -1,124 +0,0 @@ - -# -# Generic makefile for latex -# -# Author: Stefano Zacchiroli -# -# Created: Sun, 29 Jun 2003 12:00:55 +0200 zack -# Last-Modified: Mon, 10 Oct 2005 15:37:12 +0200 zack -# - -######################################################################## - -# list of .tex _main_ files -TEXS = main.tex - -# number of runs of latex (for table of contents, list of figures, ...) -RUNS = 1 - -# do you need bibtex? -BIBTEX = no - -# would you like to use pdflatex? -PDF_VIA_PDFLATEX = yes - -# which formats generated by default ("all" target)? -# (others will be generated by "world" target) -# see AVAILABLE_FORMATS below -BUILD_FORMATS = dvi - -# which format to be shown on "make show" -SHOW_FORMAT = dvi - -######################################################################## - -AVAILABLE_FORMATS = dvi ps ps.gz pdf html - -ADVI = advi -BIBTEX = bibtex -BROWSER = galeon -DVIPDF = dvipdf -DVIPS = dvips -GV = gv -GZIP = gzip -HEVEA = hevea -ISPELL = ispell -LATEX = latex -PDFLATEX = pdflatex -PRINT = lpr -XDVI = xdvi -XPDF = xpdf - -ALL_FORMATS = $(BUILD_FORMATS) -WORLD_FORMATS = $(AVAILABLE_FORMATS) - -all: $(ALL_FORMATS) -world: $(WORLD_FORMATS) - -DVIS = $(TEXS:.tex=.dvi) -PSS = $(TEXS:.tex=.ps) -PSGZS = $(TEXS:.tex=.ps.gz) -PDFS = $(TEXS:.tex=.pdf) -HTMLS = $(TEXS:.tex=.html) - -dvi: $(DVIS) -ps: $(PSS) -ps.gz: $(PSGZS) -pdf: $(PDFS) -html: $(HTMLS) - -show: show$(SHOW_FORMAT) -showdvi: $(DVIS) - $(XDVI) $< -showps: $(PSS) - $(GV) $< -showpdf: $(PDFS) - $(XPDF) $< -showpsgz: $(PSGZS) - $(GV) $< -showps.gz: showpsgz -showhtml: $(HTMLS) - $(BROWSER) $< - -print: $(PSS) - $(PRINT) $^ - -clean: - rm -f \ - $(TEXS:.tex=.dvi) $(TEXS:.tex=.ps) $(TEXS:.tex=.ps.gz) \ - $(TEXS:.tex=.pdf) $(TEXS:.tex=.aux) $(TEXS:.tex=.log) \ - $(TEXS:.tex=.html) $(TEXS:.tex=.out) $(TEXS:.tex=.haux) \ - $(TEXS:.tex=.htoc) $(TEXS:.tex=.tmp) - -%.dvi: %.tex - $(LATEX) $< - if [ "$(BIBTEX)" = "yes" ]; then $(BIBTEX) $*; fi - if [ "$(RUNS)" -gt 1 ]; then \ - for i in seq 1 `expr $(RUNS) - 1`; do \ - $(LATEX) $<; \ - done; \ - fi -ifeq ($(PDF_VIA_PDFLATEX),yes) -%.pdf: %.tex - $(PDFLATEX) $< - if [ "$(BIBTEX)" = "yes" ]; then $(BIBTEX) $*; fi - if [ "$(RUNS)" -gt 1 ]; then \ - for i in seq 1 `expr $(RUNS) - 1`; do \ - $(PDFLATEX) $<; \ - done; \ - fi -else -%.pdf: %.dvi - $(DVIPDF) $< $@ -endif -%.ps: %.dvi - $(DVIPS) $< -%.ps.gz: %.ps - $(GZIP) -c $< > $@ -%.html: %.tex - $(HEVEA) -fix $< - -.PHONY: all ps pdf html clean - -######################################################################## - diff --git a/matita/components/tactics/doc/body.tex b/matita/components/tactics/doc/body.tex deleted file mode 100644 index 8b7bbc9b0..000000000 --- a/matita/components/tactics/doc/body.tex +++ /dev/null @@ -1,474 +0,0 @@ - -\section{Tinycals: \MATITA{} tacticals} - -\subsection{Introduction} - -% outline: -% - script - -Most of modern mainstream proof assistants enable input of proofs of -propositions using a textual language. Compilation units written in such -languages are sequence of textual \emph{statements} and are usually called -\emph{scripts} as a whole. Scripts are so entangled with proof assistants that -they drived the design of state of the art of their Graphical User Interfaces -(GUIs). Fig.~\ref{fig:proofgeneral} is a screenshot of Proof General, a generic -proof assistant interface based on Emacs widely used and compatible with systems -like Coq, Isabelle, PhoX, LEGO, and many more. Other system specific GUIs exist -but share the same design, understanding it and they way such GUIs are operated -is relevant to our discussion. - -%\begin{figure}[ht] -% \begin{center} -% \includegraphic{pics/pg-coq-screenshot} -% \caption{Proof General: a generic interface for proof assistants} -% \label{fig:proofgeneral} -% \end{center} -%\end{figure} - -% - modo di lavorare - -The paradigm behind such GUIs is quite simple. The window on the left is an -editable text area containing the script and split in two by an \emph{execution -point} (the point where background color changes). The part starting at the -beginning of the script and ending at the marker (distinguishable for having a -light blue background in the picture) contains the sequence of statements which -have already been fed into the system. We will call this former part -\emph{locked area} since the user is not free to change it as her willing. The -remaining part, which extends until the end of the script, is named -\emph{scratch area} and can be freely modified. The window on the right is -read-only for the user and includes at the top the current proof status, when -some proof is ongoing, and at the bottom a message area used for error messages -or other feedback from the system to the user. The user usually proceed -alternating editing of the scratch area and execution point movements (forward -to evaluate statements and backward to retract statements if she need to change -something in the locked area). - -Execution point movements are not free, but constrained by the structure of the -script language used. The granularity is that of statements. In systems like Coq -or \MATITA{} examples of statements are: inductive definitions, theorems, and -tactics. \emph{Tactics} are the building blocks of proofs. For example, the -following script snippet contains a theorem about a relationship of natural -minus with natural plus, along with its proof (line numbers have been added for -the sake of presentation) as it can be found in the standard library of the -\MATITA{} proof assistant: - -%\begin{example} -%\begin{Verbatim} -%theorem eq_minus_minus_minus_plus: \forall n,m,p:nat. (n-m)-p = n-(m+p). -% intros. -% cut (m+p \le n \or m+p \nleq n). -% elim Hcut. -% symmetry. -% apply plus_to_minus. -% rewrite > assoc_plus. -% rewrite > (sym_plus p). -% rewrite < plus_minus_m_m. -% rewrite > sym_plus. -% rewrite < plus_minus_m_m. -% reflexivity. -% apply (trans_le ? (m+p)). -% rewrite < sym_plus. -% apply le_plus_n. -% assumption. -% apply le_plus_to_minus_r. -% rewrite > sym_plus. -% assumption. -% rewrite > (eq_minus_n_m_O n (m+p)). -% rewrite > (eq_minus_n_m_O (n-m) p). -% reflexivity. -% apply le_plus_to_minus. -% apply lt_to_le. -% rewrite < sym_plus. -% apply not_le_to_lt. -% assumption. -% apply lt_to_le. -% apply not_le_to_lt. -% assumption. -% apply (decidable_le (m+p) n). -%qed. -%\end{Verbatim} -%\end{example} - -The script snippet is made of 32 statements, one per line (but this is not a -requirement of the \MATITA{} script language, namely \emph{Grafite}). The first -statement is the assertion that the user want to prove a proposition with a -given type, specified after the ``\texttt{:}'', its execution will cause -\MATITA{} to enter the proof state showing to the user the list of goals that -still need to be proved to conclude the proof. The last statement (\texttt{Qed}) -is an assertion that the proof is completed. All intertwining statements are -tactic applications. - -Given the constraint we mentioned about execution point, while inserting (or -replaying) the above script, the user may position it at the end of any line, -having feedback about the status of the proof in that point. See for example -Fig.~\ref{fig:matita} where an intermediate proof status is shown. - -%\begin{figure}[ht] -% \begin{center} -% \includegraphic{matita_screenshot} -% \caption{Matita: ongoing proof} -% \label{fig:matita} -% \end{center} -%\end{figure} - -% - script: sorgenti di un linguaggio imperativo, oggetti la loro semantica -% - script = sequenza di comandi - -You can create an analogy among scripts and sources written in an imperative -programming language, seeing proofs as the denotational semantics of that -language. In such analogy the language used in the script of -Fig.~\ref{fig:matita} is rather poor offering as the only programming construct -the sequential composition of tactic application. What enables step by step -execution is the operational semantics of each tactic application (i.e. how it -changes the current proof status). - -% - pro: concisi - -This kind of scripts have both advantages and drawbacks. Among advantages we can -for sure list the effectiveness of the language. In spite of being longer than -the corresponding informal text version of the proof (a gap hardly fillable with -proof assistants~\cite{debrujinfactor}), the script is fast to write in -interactive use, enable cut and paste approaches, and gives a lot of flexibility -(once the syntax is known of course) in tactic application via additional flags -that can be easily passed to them. - -% - cons: non strutturati, hanno senso solo via reply - -Unfortunately, drawbacks are non negligible. Scripts like those of -Fig.~\ref{fig:matita} are completely unstructured and hardly can be assigned a -meaning simply looking at them. Even experienced users, that knows the details -of all involved tactics, can hardly figure what a script mean without replaying -the proof in their heads. This indeed is a key aspect of scripts: they are -meaningful via \emph{reply}. People interested in understanding a formal proof -written as a script usually start the preferred tool and execute it step by -step. A contrasting approach compared to what happens with high level -programming languages where looking at the code is usually enough to understand -its details. - -% - cons: poco robusti (wrt cambiamenti nelle tattiche, nello statement, ...) - -Additionally, scripts are usually not robust against changes, intending with -that term both changes in the statement that need to be proved (e.g. -strenghtening of an inductive hypothesis) and changes in the implementation of -involved tactics. This drawback can force backward compatibility and slow down -systems development. A real-life example in the history of \MATITA{} was the -reordering of goals after tactic application; the total time needed to port the -(tiny at the time) standard library of no more that 30 scripts was 2 days work. -Having the scripts being structured the task could have been done in much less -time and even automated. - -Tacticals are an attempt at solving this drawbacks. - -\subsection{Tacticals} - -% - script = sequenza di comandi + tatticali - -\ldots descrizione dei tatticali \ldots - -% - pro: fattorizzazione - -Tacticals as described above have several advantages with respect to plain -sequential application of tactics. First of all they enable a great amount of -factorization of proofs using the sequential composition ``;'' operator. Think -for example at proofs by induction on inductive types with several constructors, -which are so frequent when formalizing properties from the computer science -field. It is often the case that several, or even all, cases can be dealt with -uniform strategies, which can in turn by coded in a single script snipped which -can appear only once, at the right hand side of a ``;''. - -% - pro: robustezza - -Scripts properly written using the tacticals above are even more robust with -respect to changes. The additional amount of flexibility is given by -``conditional'' constructs like \texttt{try}, \texttt{solve}, and -\texttt{first}. Using them the scripts no longer contain a single way of -proceeding from one status of the proof to another, they can list more. The wise -proof coder may exploit this mechanism providing fallbacks in order to be more -robust to future changes in tactics implementation. Of course she is not -required to! - -% - pro: strutturazione delle prove (via branching) - -Finally, the branching constructs \texttt{[}, \texttt{|}, and \texttt{]} enable -proof structuring. Consider for example an alternative, branching based, version -of the example above: - -%\begin{example} -%\begin{Verbatim} -%... -%\end{Verbatim} -%\end{example} - -Tactic applications are the same of the previous version of the script, but -branching tacticals are used. The above version is highly more readable and -without executing it key points of the proofs like induction cases can be -observed. - -% - tradeoff: utilizzo dei tatticali vs granularita' dell'esecuzione -% (impossibile eseguire passo passo) - -One can now wonder why thus all scripts are not written in a robust, concise and -structured fashion. The reason is the existence of an unfortunate tradeoff -between the need of using tacticals and the impossibility of executing step by -step \emph{inside} them. Indeed, trying to mimic the structured version of the -proof above in GUIs like Proof General or CoqIDE will result in a single macro -step that will bring you from the beginning of the proof directly at the end of -it! - -Tinycals as implemented in \MATITA{} are a solution to this problem, preserving -the usual tacticals semantics, giving meaning to intermediate execution point -inside complex tacticals. - -\subsection{Tinycals} - -\subsection{Tinycals semantics} - -\subsubsection{Language} - -\[ -\begin{array}{rcll} - S & ::= & & \mbox{(\textbf{continuationals})}\\ - & & \TACTIC{T} & \mbox{(tactic)}\\[2ex] - & | & \DOT & \mbox{(dot)} \\ - & | & \SEMICOLON & \mbox{(semicolon)} \\ - & | & \BRANCH & \mbox{(branch)} \\ - & | & \SHIFT & \mbox{(shift)} \\ - & | & \POS{i} & \mbox{(relative positioning)} \\ - & | & \MERGE & \mbox{(merge)} \\[2ex] - & | & \FOCUS{g_1,\dots,g_n} & \mbox{(absolute positioning)} \\ - & | & \UNFOCUS & \mbox{(unfocus)} \\[2ex] - & | & S ~ S & \mbox{(sequential composition)} \\[2ex] - T & : := & & \mbox{(\textbf{tactics})}\\ - & & \SKIP & \mbox{(skip)} \\ - & | & \mathtt{reflexivity} & \\ - & | & \mathtt{apply}~t & \\ - & | & \dots & -\end{array} -\] - -\subsubsection{Status} - -\[ -\begin{array}{rcll} - \xi & & & \mbox{(proof status)} \\ - \mathit{goal} & & & \mbox{(proof goal)} \\[2ex] - - \SWITCH & = & \OPEN~\mathit{goal} ~ | ~ \CLOSED~\mathit{goal} & \\ - \mathit{locator} & = & \INT\times\SWITCH & \\ - \mathit{tag} & = & \BRANCHTAG ~ | ~ \FOCUSTAG \\[2ex] - - \Gamma & = & \mathit{locator}~\LIST & \mbox{(context)} \\ - \tau & = & \mathit{locator}~\LIST & \mbox{(todo)} \\ - \kappa & = & \mathit{locator}~\LIST & \mbox{(dot's future)} \\[2ex] - - \mathit{stack} & = & (\Gamma\times\tau\times\kappa\times\mathit{tag})~\LIST - \\[2ex] - - \mathit{status} & = & \xi\times\mathit{stack} \\ -\end{array} -\] - -\paragraph{Utilities} -\begin{itemize} - \item $\ZEROPOS([g_1;\cdots;g_n]) = - [\langle 0,\OPEN~g_1\rangle;\cdots;\langle 0,\OPEN~g_n\rangle]$ - \item $\INITPOS([\langle i_1,s_1\rangle;\cdots;\langle i_n,s_n\rangle]) = - [\langle 1,s_1\rangle;\cdots;\langle n,s_n\rangle]$ - \item $\ISFRESH(s) = - \left\{ - \begin{array}{ll} - \mathit{true} & \mathrm{if} ~ s = \langle n, \OPEN~g\rangle\land n > 0 \\ - \mathit{false} & \mathrm{otherwise} \\ - \end{array} - \right.$ - \item $\FILTEROPEN(\mathit{locs})= - \left\{ - \begin{array}{ll} - [] & \mathrm{if}~\mathit{locs} = [] \\ - \langle i,\OPEN~g\rangle :: \FILTEROPEN(\mathit{tl}) - & \mathrm{if}~\mathit{locs} = \langle i,\OPEN~g\rangle :: \mathit{tl} \\ - \FILTEROPEN(\mathit{tl}) - & \mathrm{if}~\mathit{locs} = \mathit{hd} :: \mathit{tl} \\ - \end{array} - \right.$ - \item $\REMOVEGOALS(G,\mathit{locs}) = - \left\{ - \begin{array}{ll} - [] & \mathrm{if}~\mathit{locs} = [] \\ - \REMOVEGOALS(G,\mathit{tl}) - & \mathrm{if}~\mathit{locs} = \langle i,\OPEN~g\rangle :: \mathit{tl} - \land g\in G\\ - hd :: \REMOVEGOALS(G,\mathit{tl}) - & \mathrm{if}~\mathit{locs} = \mathit{hd} :: \mathit{tl} \\ - \end{array} - \right.$ - \item $\DEEPCLOSE(G,S)$: (intuition) given a set of goals $G$ and a stack $S$ - it returns a new stack $S'$ identical to the given one with the exceptions - that each locator whose goal is in $G$ is marked as closed in $\Gamma$ stack - components and removed from $\tau$ and $\kappa$ components. - \item $\GOALS(S)$: (inutition) return all goals appearing in whatever position - on a given stack $S$, appearing in an \OPEN{} switch. -\end{itemize} - -\paragraph{Invariants} -\begin{itemize} - \item $\forall~\mathrm{entry}~\ENTRY{\Gamma}{\tau}{\kappa}{t}, \forall s - \in\tau\cup\kappa, \exists g, s = \OPEN~g$ (each locator on the stack in - $\tau$ and $\kappa$ components has an \OPEN~switch). - \item Unless \FOCUS{} is used the stack contains no duplicate goals. - \item $\forall~\mathrm{locator}~l\in\Gamma \mbox{(with the exception of the - top-level $\Gamma$)}, \ISFRESH(l)$. -\end{itemize} - -\subsubsection{Semantics} - -\[ -\begin{array}{rcll} - \SEMOP{\cdot} & : & C -> \mathit{status} -> \mathit{status} & - \mbox{(continuationals semantics)} \\ - \TSEMOP{\cdot} & : & T -> \xi -> \SWITCH -> - \xi\times\GOAL~\LIST\times\GOAL~\LIST & \mbox{(tactics semantics)} \\ -\end{array} -\] - -\[ -\begin{array}{rcl} - \mathit{apply\_tac} & : & T -> \xi -> \GOAL -> - \xi\times\GOAL~\LIST\times\GOAL~\LIST -\end{array} -\] - -\[ -\begin{array}{rlcc} - \TSEM{T}{\xi}{\OPEN~g} & = & \mathit{apply\_tac}(T,\xi,n) & T\neq\SKIP\\ - \TSEM{\SKIP}{\xi}{\CLOSED~g} & = & \langle \xi, [], [g]\rangle & -\end{array} -\] - -\[ -\begin{array}{rcl} - - \SEM{\TACTIC{T}}{\ENTRY{\GIN}{\tau}{\kappa}{t}::S} - & = - & \langle - \xi_n, - \ENTRY{\Gamma'}{\tau'}{\kappa'}{t} -% \ENTRY{\ZEROPOS(G^o_n)}{\tau\setminus G^c_n}{\kappa\setminus G^o_n}{t} - :: \DEEPCLOSE(G^c_n,S) - \rangle - \\[1ex] - \multicolumn{3}{l}{\hspace{\sidecondlen}\mathit{where} ~ n\geq 1} - \\[1ex] - \multicolumn{3}{l}{\hspace{\sidecondlen}\mathit{and} ~ - \Gamma' = \ZEROPOS(G^o_n) - \land \tau' = \REMOVEGOALS(G^c_n,\tau) - \land \kappa' = \REMOVEGOALS(G^o_n,\kappa) - } - \\[1ex] - \multicolumn{3}{l}{\hspace{\sidecondlen}\mathit{and} ~ - \left\{ - \begin{array}{rcll} - \langle\xi_0, G^o_0, G^c_0\rangle & = & \langle\xi, [], []\rangle \\ - \langle\xi_{i+1}, G^o_{i+1}, G^c_{i+1}\rangle - & = - & \langle\xi_i, G^o_i, G^c_i\rangle - & l_{i+1}\in G^c_i \\ - \langle\xi_{i+1}, G^o_{i+1}, G^c_{i+1}\rangle - & = - & \langle\xi, (G^o_i\setminus G^c)\cup G^o, G^c_i\cup G^c\rangle - & l_{i+1}\not\in G^c_i \\[1ex] - & & \mathit{where} ~ \langle\xi,G^o,G^c\rangle=\TSEM{T}{\xi_i}{l_{i+1}} \\ - \end{array} - \right. - } - \\[6ex] - - \SEM{~\DOT~}{\ENTRY{\Gamma}{\tau}{\kappa}{t}::S} - & = - & \langle \xi, \ENTRY{l_1}{\tau}{\GIN[2]\cup\kappa}{t}::S \rangle - \\[1ex] - & & \mathrm{where} ~ \FILTEROPEN(\Gamma)=\GIN \land n\geq 1 - \\[2ex] - - \SEM{~\DOT~}{\ENTRY{\Gamma}{\tau}{l::\kappa}{t}::S} - & = - & \langle \xi, \ENTRY{[l]}{\tau}{\kappa}{t}::S \rangle - \\[1ex] - & & \mathrm{where} ~ \FILTEROPEN(\Gamma)=[] - \\[2ex] - - \SEM{~\SEMICOLON~}{S} & = & \langle \xi, S \rangle \\[1ex] - - \SEM{~\BRANCH~}{\ENTRY{\GIN}{\tau}{\kappa}{t}::S} - \quad - & = - & \langle\xi, \ENTRY{[l_1']}{[]}{[]}{\BRANCHTAG} - ::\ENTRY{[l_2';\cdots;l_n']}{\tau}{\kappa}{t}::S - \\[1ex] - & & \mathrm{where} ~ n\geq 2 ~ \land ~ \INITPOS(\GIN)=[l_1';\cdots;l_n'] - \\[2ex] - - \SEM{~\SHIFT~} - {\ENTRY{\Gamma}{\tau}{\kappa}{\BRANCHTAG}::\ENTRY{\GIN}{\tau'}{\kappa'}{t'} - ::S} - & = - & \langle - \xi, \ENTRY{[l_1]}{\tau\cup\FILTEROPEN(\Gamma)}{[]}{\BRANCHTAG} - ::\ENTRY{\GIN[2]}{\tau'}{\kappa'}{t'}::S - \rangle - \\[1ex] - & & \mathrm{where} ~ n\geq 1 - \\[2ex] - - \SEM{~\POS{i}~} - {\ENTRY{[l]}{[]}{[]}{\BRANCHTAG}::\ENTRY{\Gamma'}{\tau'}{\kappa'}{t'}::S} - & = - & \langle \xi, \ENTRY{[l_i]}{[]}{[]}{\BRANCHTAG} - ::\ENTRY{l :: (\Gamma'\setminus [l_i])}{\tau'}{\kappa'}{t'}::S \rangle - \\[1ex] - & & \mathrm{where} ~ \langle i,l'\rangle = l_i\in \Gamma'~\land~\ISFRESH(l) - \\[2ex] - - \SEM{~\POS{i}~} - {\ENTRY{\Gamma}{\tau}{\kappa}{\BRANCHTAG} - ::\ENTRY{\Gamma'}{\tau'}{\kappa'}{t'}::S} - & = - & \langle \xi, \ENTRY{[l_i]}{[]}{[]}{\BRANCHTAG} - ::\ENTRY{\Gamma'\setminus [l_i]}{\tau'\cup\FILTEROPEN(\Gamma)}{\kappa'}{t'}::S - \rangle - \\[1ex] - & & \mathrm{where} ~ \langle i, l'\rangle = l_i\in \Gamma' - \\[2ex] - - \SEM{~\MERGE~} - {\ENTRY{\Gamma}{\tau}{\kappa}{\BRANCHTAG}::\ENTRY{\Gamma'}{\tau'}{\kappa'}{t'} - ::S} - & = - & \langle \xi, - \ENTRY{\tau\cup\FILTEROPEN(\Gamma)\cup\Gamma'\cup\kappa}{\tau'}{\kappa'}{t'} - :: S - \rangle - \\[2ex] - - \SEM{\FOCUS{g_1,\dots,g_n}}{S} - & = - & \langle \xi, \ENTRY{\ZEROPOS([g_1;\cdots;g_n])}{[]}{[]}{\FOCUSTAG} - ::\DEEPCLOSE(S) - \rangle - \\[1ex] - & & \mathrm{where} ~ - \forall i=1,\dots,n,~g_i\in\GOALS(S) - \\[2ex] - - \SEM{\UNFOCUS}{\ENTRY{[]}{[]}{[]}{\FOCUSTAG}::S} - & = - & \langle \xi, S\rangle \\[2ex] - -\end{array} -\] - -\subsection{Related works} - -In~\cite{fk:strata2003}, Kirchner described a small step semantics for Coq -tacticals and PVS strategies. - diff --git a/matita/components/tactics/doc/infernce.sty b/matita/components/tactics/doc/infernce.sty deleted file mode 100644 index fc4afeaaf..000000000 --- a/matita/components/tactics/doc/infernce.sty +++ /dev/null @@ -1,217 +0,0 @@ -%% -%% This is file `infernce.sty', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% semantic.dtx (with options: `allOptions,inference') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from infernce.sty. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file semantic.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and -%% Arne John Glenstrup -%% -\expandafter\ifx\csname sem@nticsLoader\endcsname\relax - \PackageError{semantic}{% - This file should not be loaded directly} - {% - This file is an option of the semantic package. It should not be - loaded directly\MessageBreak - but by using \protect\usepackage{semantic} in your document - preamble.\MessageBreak - No commands are defined.\MessageBreak - Type to proceed. - }% -\else -\TestForConflict{\@@tempa,\@@tempb,\@adjustPremises,\@inference} -\TestForConflict{\@inferenceBack,\@inferenceFront,\@inferenceOrPremis} -\TestForConflict{\@premises,\@processInference,\@processPremiseLine} -\TestForConflict{\@setLengths,\inference,\predicate,\predicatebegin} -\TestForConflict{\predicateend,\setnamespace,\setpremisesend} -\TestForConflict{\setpremisesspace,\@makeLength,\@@space} -\TestForConflict{\@@aLineBox,\if@@shortDivider} -\newtoks\@@tempa -\newtoks\@@tempb -\newcommand{\@makeLength}[4]{ - \@@tempa=\expandafter{\csname @@#2\endcsname} - \@@tempb=\expandafter{\csname @set#2\endcsname} % - \expandafter \newlength \the\@@tempa - \expandafter \newcommand \the\@@tempb {} - \expandafter \newcommand \csname set#1\endcsname[1]{} - \expandafter \xdef \csname set#1\endcsname##1% - {{\dimen0=##1}% - \noexpand\renewcommand{\the\@@tempb}{% - \noexpand\setlength{\the \@@tempa}{##1 #4}}% - }% - \csname set#1\endcsname{#3} - \@@tempa=\expandafter{\@setLengths} % - \edef\@setLengths{\the\@@tempa \the\@@tempb} % - } - -\newcommand{\@setLengths}{% - \setlength{\baselineskip}{1.166em}% - \setlength{\lineskip}{1pt}% - \setlength{\lineskiplimit}{1pt}} -\@makeLength{premisesspace}{pSpace}{1.5em}{plus 1fil} -\@makeLength{premisesend}{pEnd}{.75em}{plus 0.5fil} -\@makeLength{namespace}{nSpace}{.5em}{} -\newbox\@@aLineBox -\newif\if@@shortDivider -\newcommand{\@@space}{ } -\newcommand{\predicate}[1]{\predicatebegin #1\predicateend} -\newcommand{\predicatebegin}{$} -\newcommand{\predicateend}{$} -\def\inference{% - \@@shortDividerfalse - \expandafter\hbox\bgroup - \@ifstar{\@@shortDividertrue\@inferenceFront}% - \@inferenceFront -} -\def\@inferenceFront{% - \@ifnextchar[% - {\@inferenceFrontName}% - {\@inferenceMiddle}% -} -\def\@inferenceFrontName[#1]{% - \setbox3=\hbox{\footnotesize #1}% - \ifdim \wd3 > \z@ - \unhbox3% - \hskip\@@nSpace - \fi - \@inferenceMiddle -} -\long\def\@inferenceMiddle#1{% - \@setLengths% - \setbox\@@pBox= - \vbox{% - \@premises{#1}% - \unvbox\@@pBox - }% - \@inferenceBack -} -\long\def\@inferenceBack#1{% - \setbox\@@cBox=% - \hbox{\hskip\@@pEnd \predicate{\ignorespaces#1}\unskip\hskip\@@pEnd}% - \setbox1=\hbox{$ $}% - \setbox\@@pBox=\vtop{\unvbox\@@pBox - \vskip 4\fontdimen8\textfont3}% - \setbox\@@cBox=\vbox{\vskip 4\fontdimen8\textfont3% - \box\@@cBox}% - \if@@shortDivider - \ifdim\wd\@@pBox >\wd\@@cBox% - \dimen1=\wd\@@pBox% - \else% - \dimen1=\wd\@@cBox% - \fi% - \dimen0=\wd\@@cBox% - \hbox to \dimen1{% - \hss - $\frac{\hbox to \dimen0{\hss\box\@@pBox\hss}}% - {\box\@@cBox}$% - \hss - }% - \else - $\frac{\box\@@pBox}% - {\box\@@cBox}$% - \fi - \@ifnextchar[% - {\@inferenceBackName}%{}% - {\egroup} -} -\def\@inferenceBackName[#1]{% - \setbox3=\hbox{\footnotesize #1}% - \ifdim \wd3 > \z@ - \hskip\@@nSpace - \unhbox3% - \fi - \egroup -} -\newcommand{\@premises}[1]{% - \setbox\@@pBox=\vbox{}% - \dimen\@@maxwidth=\wd\@@cBox% - \@processPremises #1\\\end% - \@adjustPremises% -} -\newcommand{\@adjustPremises}{% - \setbox\@@pBox=\vbox{% - \@@moreLinestrue % - \loop % - \setbox\@@pBox=\vbox{% - \unvbox\@@pBox % - \global\setbox\@@aLineBox=\lastbox % - }% - \ifvoid\@@aLineBox % - \@@moreLinesfalse % - \else % - \hbox to \dimen\@@maxwidth{\unhbox\@@aLineBox}% - \fi % - \if@@moreLines\repeat% - }% -} -\def\@processPremises#1\\#2\end{% - \setbox\@@pLineBox=\hbox{}% - \@processPremiseLine #1&\end% - \setbox\@@pLineBox=\hbox{\unhbox\@@pLineBox \unskip}% - \ifdim \wd\@@pLineBox > \z@ % - \setbox\@@pLineBox=% - \hbox{\hskip\@@pEnd \unhbox\@@pLineBox \hskip\@@pEnd}% - \ifdim \wd\@@pLineBox > \dimen\@@maxwidth % - \dimen\@@maxwidth=\wd\@@pLineBox % - \fi % - \setbox\@@pBox=\vbox{\box\@@pLineBox\unvbox\@@pBox}% - \fi % - \def\sem@tmp{#2}% - \ifx \sem@tmp\empty \else % - \@ReturnAfterFi{% - \@processPremises #2\end % - }% - \fi% -} -\def\@processPremiseLine#1\end{% - \def\sem@tmp{#1}% - \ifx \sem@tmp\empty \else% - \ifx \sem@tmp\@@space \else% - \setbox\@@pLineBox=% - \hbox{\unhbox\@@pLineBox% - \@inferenceOrPremis #1\inference\end% - \hskip\@@pSpace}% - \fi% - \fi% - \def\sem@tmp{#2}% - \ifx \sem@tmp\empty \else% - \@ReturnAfterFi{% - \@processPremiseLine#2\end% - }% - \fi% -} -\def\@inferenceOrPremis#1\inference{% - \@ifnext \end - {\@dropnext{\predicate{\ignorespaces #1}\unskip}}% - {\@processInference #1\inference}% -} -\def\@processInference#1\inference\end{% - \ignorespaces #1% - \setbox3=\lastbox - \dimen3=\dp3 - \advance\dimen3 by -\fontdimen22\textfont2 - \advance\dimen3 by \fontdimen8\textfont3 - \expandafter\raise\dimen3\box3% -} -\long\def\@ReturnAfterFi#1\fi{\fi#1} -\fi -\endinput -%% -%% End of file `infernce.sty'. diff --git a/matita/components/tactics/doc/ligature.sty b/matita/components/tactics/doc/ligature.sty deleted file mode 100644 index a914d91d1..000000000 --- a/matita/components/tactics/doc/ligature.sty +++ /dev/null @@ -1,169 +0,0 @@ -%% -%% This is file `ligature.sty', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% semantic.dtx (with options: `allOptions,ligature') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from ligature.sty. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file semantic.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and -%% Arne John Glenstrup -%% -\expandafter\ifx\csname sem@nticsLoader\endcsname\relax - \PackageError{semantic}{% - This file should not be loaded directly} - {% - This file is an option of the semantic package. It should not be - loaded directly\MessageBreak - but by using \protect\usepackage{semantic} in your document - preamble.\MessageBreak - No commands are defined.\MessageBreak - Type to proceed. - }% -\else -\TestForConflict{\@addligto,\@addligtofollowlist,\@def@ligstep} -\TestForConflict{\@@trymathlig,\@defactive,\@defligstep} -\TestForConflict{\@definemathlig,\@domathligfirsts,\@domathligfollows} -\TestForConflict{\@exitmathlig,\@firstmathligs,\@ifactive,\@ifcharacter} -\TestForConflict{\@ifinlist,\@lastvalidmathlig,\@mathliglink} -\TestForConflict{\@mathligredefactive,\@mathligsoff,\@mathligson} -\TestForConflict{\@seentoks,\@setupfirstligchar,\@try@mathlig} -\TestForConflict{\@trymathlig,\if@mathligon,\mathlig,\mathligprotect} -\TestForConflict{\mathligsoff,\mathligson,\@startmathlig,\@pushedtoks} -\newif\if@mathligon -\DeclareRobustCommand\mathlig[1]{\@addligtolists#1\@@ - \if@mathligon\mathligson\fi - \@setupfirstligchar#1\@@ - \@defligstep{}#1\@@} -\def\@mathligson{\if@mathligon\mathligson\fi} -\def\@mathligsoff{\if@mathligon\mathligsoff\@mathligontrue\fi} -\DeclareRobustCommand\mathligprotect[1]{\expandafter - \def\expandafter#1\expandafter{% - \expandafter\@mathligsoff#1\@mathligson}} -\DeclareRobustCommand\mathligson{\def\do##1##2##3{\mathcode`##1="8000}% - \@domathligfirsts\@mathligontrue} -\AtBeginDocument{\mathligson} -\DeclareRobustCommand\mathligsoff{\def\do##1##2##3{\mathcode`##1=##2}% - \@domathligfirsts\@mathligonfalse} -\edef\@mathliglink{Error: \noexpand\verb|\string\@mathliglink| expanded} -{\catcode`\A=11\catcode`\1=12\catcode`\~=13 % Letter, Other and Active -\gdef\@ifcharacter#1{\ifcat A\noexpand#1\let\next\@firstoftwo - \else\ifcat 1\noexpand#1\let\next\@firstoftwo - \else\ifcat \noexpand~\noexpand#1\let\next\@firstoftwo - \else\let\next\@secondoftwo\fi\fi\fi\next}% -\gdef\@ifactive#1{\ifcat \noexpand~\noexpand#1\let\next\@firstoftwo - \else\let\next\@secondoftwo\fi\next}} -\def\@domathligfollows{}\def\@domathligfirsts{} -\def\@makemathligsactive{\mathligson - \def\do##1##2##3{\catcode`##1=12}\@domathligfollows} -\def\@makemathligsnormal{\mathligsoff - \def\do##1##2##3{\catcode`##1=##3}\@domathligfollows} -\def\@ifinlist#1#2{\@tempswafalse - \def\do##1##2##3{\ifnum`##1=`#2\relax\@tempswatrue\fi}#1% - \if@tempswa\let\next\@firstoftwo\else\let\next\@secondoftwo\fi\next} -\def\@addligto#1#2{% - \@ifinlist#1#2{\def\do##1##2##3{\noexpand\do\noexpand##1% - \ifnum`##1=`#2 {\the\mathcode`#2}{\the\catcode`#2}% - \else{##2}{##3}\fi}% - \edef#1{#1}}% - {\def\do##1##2##3{\noexpand\do\noexpand##1% - \ifnum`##1=`#2 {\the\mathcode`#2}{\the\catcode`#2}% - \else{##2}{##3}\fi}% - \edef#1{#1\do#2{\the\mathcode`#2}{\the\catcode`#2}}}} -\def\@addligtolists#1{\expandafter\@addligto - \expandafter\@domathligfirsts - \csname\string#1\endcsname\@addligtofollowlist} -\def\@addligtofollowlist#1{\ifx#1\@@\let\next\relax\else - \def\next{\expandafter\@addligto - \expandafter\@domathligfollows - \csname\string#1\endcsname - \@addligtofollowlist}\fi\next} -\def\@defligstep#1#2{\def\@tempa##1{\ifx##1\endcsname - \expandafter\endcsname\else - \string##1\expandafter\@tempa\fi}% - \expandafter\@def@ligstep\csname @mathlig\@tempa#1#2\endcsname{#1#2}} -\def\@def@ligstep#1#2#3{% - \ifx#3\@@ - \def\next{\def#1}% - \else - \ifx#1\relax - \def\next{\let#1\@mathliglink\@defligstep{#2}#3}% - \else - \def\next{\@defligstep{#2}#3}% - \fi - \fi\next} -\def\@setupfirstligchar#1#2\@@{% - \@ifactive{#1}{% - \expandafter\expandafter\expandafter\@mathligredefactive - \expandafter\string\expandafter#1\expandafter{#1}{#1}}% - {\@defactive#1{\@startmathlig #1}\@namedef{@mathlig#1}{#1}}} -\def\@mathligredefactive#1#2#3{% - \def#3{{}\ifmmode\def\next{\@startmathlig#1}\else - \def\next{#2}\fi\next}% - \@namedef{@mathlig#1}{#2}} -\def\@defactive#1{\@ifundefined{@definemathlig\string#1}% - {\@latex@error{Illegal first character in math ligature} - {You can only use \@firstmathligs\space as the first^^J - character of a math ligature}}% - {\csname @definemathlig\string#1\endcsname}} - -{\def\@firstmathligs{}\def\do#1{\catcode`#1=\active - \expandafter\gdef\expandafter\@firstmathligs - \expandafter{\@firstmathligs\space\string#1}\next} - \def\next#1{\expandafter\gdef\csname - @definemathlig\string#1\endcsname{\def#1}} - \do{"}"\do{@}@\do{/}/\do{(}(\do{)})\do{[}[\do{]}]\do{=}= - \do{?}?\do{!}!\do{`}`\do{'}'\do{|}|\do{~}~\do{<}<\do{>}> - \do{+}+\do{-}-\do{*}*\do{.}.\do{,},\do{:}:\do{;};} -\newtoks\@pushedtoks -\newtoks\@seentoks -\def\@startmathlig{\def\@lastvalidmathlig{}\@pushedtoks{}% - \@seentoks{}\@trymathlig} -\def\@trymathlig{\futurelet\next\@@trymathlig} -\def\@@trymathlig{\@ifcharacter\next{\@try@mathlig}{\@exitmathlig{}}} -\def\@exitmathlig#1{% - \expandafter\@makemathligsnormal\@lastvalidmathlig\mathligson - \the\@pushedtoks#1} -\def\@try@mathlig#1{%\typeout{char: #1 catcode: \the\catcode`#1 - \@ifundefined{@mathlig\the\@seentoks#1}{\@exitmathlig{#1}}% - {\expandafter\ifx - \csname @mathlig\the\@seentoks#1\endcsname - \@mathliglink - \expandafter\@pushedtoks - \expandafter=\expandafter{\the\@pushedtoks#1}% - \else - \expandafter\let\expandafter\@lastvalidmathlig - \csname @mathlig\the\@seentoks#1\endcsname - \@pushedtoks={}% - \fi - \expandafter\@seentoks\expandafter=\expandafter% - {\the\@seentoks#1}\@makemathligsactive\obeyspaces\@trymathlig}} -\edef\patch@newmcodes@{% - \mathcode\number`\'=39 - \mathcode\number`\*=42 - \mathcode\number`\.=\string "613A - \mathchardef\noexpand\std@minus=\the\mathcode`\-\relax - \mathcode\number`\-=45 - \mathcode\number`\/=47 - \mathcode\number`\:=\string "603A\relax -} -\AtBeginDocument{\let\newmcodes@=\patch@newmcodes@} -\fi -\endinput -%% -%% End of file `ligature.sty'. diff --git a/matita/components/tactics/doc/main.tex b/matita/components/tactics/doc/main.tex deleted file mode 100644 index 06952d61c..000000000 --- a/matita/components/tactics/doc/main.tex +++ /dev/null @@ -1,70 +0,0 @@ -\documentclass[a4paper]{article} - -\usepackage{a4wide} -\usepackage{pifont} -\usepackage{semantic} -\usepackage{stmaryrd} -\usepackage{graphicx} - -\newcommand{\MATITA}{\ding{46}\textsf{\textbf{Matita}}} - -\title{Continuationals semantics for \MATITA} -\author{Claudio Sacerdoti Coen \quad Enrico Tassi \quad Stefano Zacchiroli \\ -\small Department of Computer Science, University of Bologna \\ -\small Mura Anteo Zamboni, 7 -- 40127 Bologna, ITALY \\ -\small \{\texttt{sacerdot}, \texttt{tassi}, \texttt{zacchiro}\}\texttt{@cs.unibo.it}} - -\newcommand{\MATHIT}[1]{\ensuremath{\mathit{#1}}} -\newcommand{\MATHTT}[1]{\ensuremath{\mathtt{#1}}} - -\newcommand{\DOT}{\ensuremath{\mbox{\textbf{.}}}} -\newcommand{\SEMICOLON}{\ensuremath{\mbox{\textbf{;}}}} -\newcommand{\BRANCH}{\ensuremath{\mbox{\textbf{[}}}} -\newcommand{\SHIFT}{\ensuremath{\mbox{\textbf{\textbar}}}} -\newcommand{\POS}[1]{\ensuremath{#1\mbox{\textbf{:}}}} -\newcommand{\MERGE}{\ensuremath{\mbox{\textbf{]}}}} -\newcommand{\FOCUS}[1]{\ensuremath{\mathtt{focus}~#1}} -\newcommand{\UNFOCUS}{\ensuremath{\mathtt{unfocus}}} -\newcommand{\SKIP}{\MATHTT{skip}} -\newcommand{\TACTIC}[1]{\ensuremath{\mathtt{tactic}~#1}} - -\newcommand{\APPLY}[1]{\ensuremath{\mathtt{apply}~\mathit{#1}}} - -\newcommand{\GOAL}{\MATHIT{goal}} -\newcommand{\SWITCH}{\MATHIT{switch}} -\newcommand{\LIST}{\MATHTT{list}} -\newcommand{\INT}{\MATHTT{int}} -\newcommand{\OPEN}{\MATHTT{Open}} -\newcommand{\CLOSED}{\MATHTT{Closed}} - -\newcommand{\SEMOP}[1]{|[#1|]} -\newcommand{\TSEMOP}[1]{{}_t|[#1|]} -\newcommand{\SEM}[3][\xi]{\SEMOP{#2}_{{#1},{#3}}} -\newcommand{\ENTRY}[4]{\langle#1,#2,#3,#4\rangle} -\newcommand{\TSEM}[3]{\TSEMOP{#1}_{#2,#3}} - -\newcommand{\GIN}[1][1]{\ensuremath{[l_{#1};\cdots;l_n]}} - -\newcommand{\ZEROPOS}{\MATHIT{zero\_pos}} -\newcommand{\INITPOS}{\MATHIT{init\_pos}} -\newcommand{\ISFRESH}{\MATHIT{is\_fresh}} -\newcommand{\FILTER}{\MATHIT{filter}} -\newcommand{\FILTEROPEN}{\MATHIT{filter\_open}} -\newcommand{\ISOPEN}{\MATHIT{is\_open}} -\newcommand{\DEEPCLOSE}{\MATHIT{deep\_close}} -\newcommand{\REMOVEGOALS}{\MATHIT{remove\_goals}} -\newcommand{\GOALS}{\MATHIT{open\_goals}} - -\newcommand{\BRANCHTAG}{\ensuremath{\mathtt{B}}} -\newcommand{\FOCUSTAG}{\ensuremath{\mathtt{F}}} - -\newlength{\sidecondlen} -\setlength{\sidecondlen}{2cm} - -\begin{document} -\maketitle - -\input{body.tex} - -\end{document} - diff --git a/matita/components/tactics/doc/reserved.sty b/matita/components/tactics/doc/reserved.sty deleted file mode 100644 index c0d56b8aa..000000000 --- a/matita/components/tactics/doc/reserved.sty +++ /dev/null @@ -1,80 +0,0 @@ -%% -%% This is file `reserved.sty', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% semantic.dtx (with options: `allOptions,reservedWords') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from reserved.sty. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file semantic.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and -%% Arne John Glenstrup -%% -\expandafter\ifx\csname sem@nticsLoader\endcsname\relax - \PackageError{semantic}{% - This file should not be loaded directly} - {% - This file is an option of the semantic package. It should not be - loaded directly\MessageBreak - but by using \protect\usepackage{semantic} in your document - preamble.\MessageBreak - No commands are defined.\MessageBreak - Type to proceed. - }% -\else -\TestForConflict{\reservestyle,\@reservestyle,\setreserved,\<} -\TestForConflict{\@parseDefineReserved,\@xparseDefineReserved} -\TestForConflict{\@defineReserved,\@xdefineReserved} -\newcommand{\reservestyle}[3][]{ - \newcommand{#2}{\@parseDefineReserved{#1}{#3}} - \expandafter\expandafter\expandafter\def - \expandafter\csname set\expandafter\@gobble\string#2\endcsname##1% - {#1{#3{##1}}}} -\newtoks\@@spacing -\newtoks\@@formating -\def\@parseDefineReserved#1#2{% - \@ifnextchar[{\@xparseDefineReserved{#2}}% - {\@xparseDefineReserved{#2}[#1]}} -\def\@xparseDefineReserved#1[#2]#3{% - \@@formating{#1}% - \@@spacing{#2}% - \expandafter\@defineReserved#3,\end -} -\def\@defineReserved#1,{% - \@ifnextchar\end - {\@xdefineReserved #1[]\END\@gobble}% - {\@xdefineReserved#1[]\END\@defineReserved}} -\def\@xdefineReserved#1[#2]#3\END{% - \def\reserved@a{#2}% - \ifx \reserved@a\empty \toks0{#1}\else \toks0{#2} \fi - \expandafter\edef\csname\expandafter<#1>\endcsname - {\the\@@formating{\the\@@spacing{\the\toks0}}}} -\def\setreserved#1>{% - \expandafter\let\expandafter\reserved@a\csname<#1>\endcsname - \@ifundefined{reserved@a}{\PackageError{Semantic} - {``#1'' is not defined as a reserved word}% - {Before referring to a name as a reserved word, it % - should be defined\MessageBreak using an appropriate style - definer. A style definer is defined \MessageBreak - using \protect\reservestyle.\MessageBreak% - Type to proceed --- nothing will be set.}}% - {\reserved@a}} -\let\<=\setreserved -\fi -\endinput -%% -%% End of file `reserved.sty'. diff --git a/matita/components/tactics/doc/semantic.sty b/matita/components/tactics/doc/semantic.sty deleted file mode 100644 index 98257cab8..000000000 --- a/matita/components/tactics/doc/semantic.sty +++ /dev/null @@ -1,137 +0,0 @@ -%% -%% This is file `semantic.sty', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% semantic.dtx (with options: `general') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from semantic.sty. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file semantic.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and -%% Arne John Glenstrup -%% -\NeedsTeXFormat{LaTeX2e} -\newcommand{\semanticVersion}{2.0(epsilon)} -\newcommand{\semanticDate}{2003/10/28} -\ProvidesPackage{semantic} - [\semanticDate\space v\semanticVersion\space] -\typeout{Semantic Package v\semanticVersion\space [\semanticDate]} -\typeout{CVSId: $Id$} -\newcounter{@@conflict} -\newcommand{\@semanticNotDefinable}{% - \typeout{Command \@backslashchar\reserved@a\space already defined} - \stepcounter{@@conflict}} -\newcommand{\@oldNotDefinable}{} -\let\@oldNotDefinable=\@notdefinable -\let\@notdefinable=\@semanticNotDefinable -\newcommand{\TestForConflict}{} -\def\TestForConflict#1{\sem@test #1,,} -\newcommand{\sem@test}{} -\newcommand{\sem@tmp}{} -\newcommand{\@@next}{} -\def\sem@test#1,{% - \def\sem@tmp{#1}% - \ifx \sem@tmp\empty \let\@@next=\relax \else - \@ifdefinable{#1}{} \let\@@next=\sem@test \fi - \@@next} -\TestForConflict{\@inputLigature,\@inputInference,\@inputTdiagram} -\TestForConflict{\@inputReservedWords,\@inputShorthand} -\TestForConflict{\@ddInput,\sem@nticsLoader,\lo@d} -\def\@inputLigature{\input{ligature.sty}\message{ math mode ligatures,}% - \let\@inputLigature\relax} -\def\@inputInference{\input{infernce.sty}\message{ inference rules,}% - \let\@inputInference\relax} -\def\@inputTdiagram{\input{tdiagram.sty}\message{ T diagrams,}% - \let\@inputTdiagram\relax} -\def\@inputReservedWords{\input{reserved.sty}\message{ reserved words,}% - \let\@inputReservedWords\relax} -\def\@inputShorthand{\input{shrthand.sty}\message{ short hands,}% - \let\@inputShorthand\relax} -\toks1={} -\newcommand{\@ddInput}[1]{% - \toks1=\expandafter{\the\toks1\noexpand#1}} -\DeclareOption{ligature}{\@ddInput\@inputLigature} -\DeclareOption{inference}{\@ddInput\@inputInference} -\DeclareOption{tdiagram}{\@ddInput\@inputTdiagram} -\DeclareOption{reserved}{\@ddInput\@inputReservedWords} -\DeclareOption{shorthand}{\@ddInput\@inputLigature - \@ddInput\@inputShorthand} -\ProcessOptions* -\typeout{Loading features: } -\def\sem@nticsLoader{} -\edef\lo@d{\the\toks1} -\ifx\lo@d\empty - \@inputLigature - \@inputInference - \@inputTdiagram - \@inputReservedWords - \@inputShorthand -\else - \lo@d -\fi -\typeout{and general definitions.^^J} -\let\@ddInput\relax -\let\@inputInference\relax -\let\@inputLigature\relax -\let\@inputTdiagram\relax -\let\@inputReservedWords\relax -\let\@inputShorthand\relax -\let\sem@nticsLoader\realx -\let\lo@d\relax -\TestForConflict{\@dropnext,\@ifnext,\@ifn,\@ifNextMacro,\@ifnMacro} -\TestForConflict{\@@maxwidth,\@@pLineBox,\if@@Nested,\@@cBox} -\TestForConflict{\if@@moreLines,\@@pBox} -\def\@ifnext#1#2#3{% - \let\reserved@e=#1\def\reserved@a{#2}\def\reserved@b{#3}\futurelet% - \reserved@c\@ifn} -\def\@ifn{% - \ifx \reserved@c \reserved@e\let\reserved@d\reserved@a\else% - \let\reserved@d\reserved@b\fi \reserved@d} -\def\@ifNextMacro#1#2{% - \def\reserved@a{#1}\def\reserved@b{#2}% - \futurelet\reserved@c\@ifnMacro} -\def\@ifnMacro{% - \ifcat\noexpand\reserved@c\noexpand\@ifnMacro - \let\reserved@d\reserved@a - \else \let\reserved@d\reserved@b\fi \reserved@d} -\newcommand{\@dropnext}[2]{#1} -\ifnum \value{@@conflict} > 0 - \PackageError{Semantic} - {The \the@@conflict\space command(s) listed above have been - redefined.\MessageBreak - Please report this to turtle@bu.edu} - {Some of the commands defined in semantic was already defined % - and has\MessageBreak now be redefined. There is a risk that % - these commands will be used\MessageBreak by other packages % - leading to spurious errors.\MessageBreak - \space\space Type and cross your fingers% -}\fi -\let\@notdefinable=\@oldNotDefinable -\let\@semanticNotDefinable=\relax -\let\@oldNotDefinable=\relax -\let\TestForConflict=\relax -\let\@endmark=\relax -\let\sem@test=\relax -\newdimen\@@maxwidth -\newbox\@@pLineBox -\newbox\@@cBox -\newbox\@@pBox -\newif\if@@moreLines -\newif\if@@Nested \@@Nestedfalse -\endinput -%% -%% End of file `semantic.sty'. diff --git a/matita/components/tactics/doc/shrthand.sty b/matita/components/tactics/doc/shrthand.sty deleted file mode 100644 index b73af4470..000000000 --- a/matita/components/tactics/doc/shrthand.sty +++ /dev/null @@ -1,96 +0,0 @@ -%% -%% This is file `shrthand.sty', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% semantic.dtx (with options: `allOptions,shorthand') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from shrthand.sty. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file semantic.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and -%% Arne John Glenstrup -%% -\expandafter\ifx\csname sem@nticsLoader\endcsname\relax - \PackageError{semantic}{% - This file should not be loaded directly} - {% - This file is an option of the semantic package. It should not be - loaded directly\MessageBreak - but by using \protect\usepackage{semantic} in your document - preamble.\MessageBreak - No commands are defined.\MessageBreak - Type to proceed. - }% -\else -\IfFileExists{DONOTUSEmathbbol.sty}{% - \RequirePackage{mathbbol} - \newcommand{\@bblb}{\textbb{[}} - \newcommand{\@bbrb}{\textbb{]}} - \newcommand{\@mbblb}{\mathopen{\mbox{\textbb{[}}}} - \newcommand{\@mbbrb}{\mathclose{\mbox{\textbb{]}}}} -} -{ \newcommand{\@bblb}{\textnormal{[\kern-.15em[}} - \newcommand{\@bbrb}{\textnormal{]\kern-.15em]}} - \newcommand{\@mbblb}{\mathopen{[\mkern-2.67mu[}} - \newcommand{\@mbbrb}{\mathclose{]\mkern-2.67mu]}} -} -\mathlig{|-}{\vdash} -\mathlig{|=}{\models} -\mathlig{->}{\rightarrow} -\mathlig{->*}{\mathrel{\rightarrow^*}} -\mathlig{->+}{\mathrel{\rightarrow^+}} -\mathlig{-->}{\longrightarrow} -\mathlig{-->*}{\mathrel{\longrightarrow^*}} -\mathlig{-->+}{\mathrel{\longrightarrow^+}} -\mathlig{=>}{\Rightarrow} -\mathlig{=>*}{\mathrel{\Rightarrow^*}} -\mathlig{=>+}{\mathrel{\Rightarrow^+}} -\mathlig{==>}{\Longrightarrow} -\mathlig{==>*}{\mathrel{\Longrightarrow^*}} -\mathlig{==>+}{\mathrel{\Longrightarrow^+}} -\mathlig{<-}{\leftarrow} -\mathlig{*<-}{\mathrel{{}^*\mkern-1mu\mathord\leftarrow}} -\mathlig{+<-}{\mathrel{{}^+\mkern-1mu\mathord\leftarrow}} -\mathlig{<--}{\longleftarrow} -\mathlig{*<--}{\mathrel{{}^*\mkern-1mu\mathord{\longleftarrow}}} -\mathlig{+<--}{\mathrel{{}^+\mkern-1mu\mathord{\longleftarrow}}} -\mathlig{<=}{\Leftarrow} -\mathlig{*<=}{\mathrel{{}^*\mkern-1mu\mathord\Leftarrow}} -\mathlig{+<=}{\mathrel{{}^+\mkern-1mu\mathord\Leftarrow}} -\mathlig{<==}{\Longleftarrow} -\mathlig{*<==}{\mathrel{{}^*\mkern-1mu\mathord{\Longleftarrow}}} -\mathlig{+<==}{\mathrel{{}^+\mkern-1mu\mathord{\Longleftarrow}}} -\mathlig{<->}{\longleftrightarrow} -\mathlig{<=>}{\Longleftrightarrow} -\mathlig{|[}{\@mbblb} -\mathlig{|]}{\@mbbrb} -\newcommand{\evalsymbol}[1][]{\ensuremath{\mathcal{E}^{#1}}} -\newcommand{\compsymbol}[1][]{\ensuremath{\mathcal{C}^{#1}}} -\newcommand{\eval}[3][]% - {\mbox{$\mathcal{E}^{#1}$\@bblb \texttt{#2}\@bbrb}% - \ensuremath{\mathtt{#3}}} -\newcommand{\comp}[3][]% - {\mbox{$\mathcal{C}^{#1}$\@bblb \texttt{#2}\@bbrb}% - \ensuremath{\mathtt{#3}}} -\newcommand{\@exe}[3]{} -\newcommand{\exe}[1]{\@ifnextchar[{\@exe{#1}}{\@exe{#1}[]}} -\def\@exe#1[#2]#3{% - \mbox{\@bblb\texttt{#1}\@bbrb$^\mathtt{#2}\mathtt{(#3)}$}} -\fi -\endinput -%% -%% End of file `shrthand.sty'. diff --git a/matita/components/tactics/doc/tdiagram.sty b/matita/components/tactics/doc/tdiagram.sty deleted file mode 100644 index 02202b34a..000000000 --- a/matita/components/tactics/doc/tdiagram.sty +++ /dev/null @@ -1,166 +0,0 @@ -%% -%% This is file `tdiagram.sty', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% semantic.dtx (with options: `allOptions,Tdiagram') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from tdiagram.sty. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file semantic.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% semantic.dtx (c)1995--2002 Peter M^^f8ller Neergaard and -%% Arne John Glenstrup -%% -\expandafter\ifx\csname sem@nticsLoader\endcsname\relax - \PackageError{semantic}{% - This file should not be loaded directly} - {% - This file is an option of the semantic package. It should not be - loaded directly\MessageBreak - but by using \protect\usepackage{semantic} in your document - preamble.\MessageBreak - No commands are defined.\MessageBreak - Type to proceed. - }% -\else -\TestForConflict{\@getSymbol,\@interpreter,\@parseArg,\@program} -\TestForConflict{\@putSymbol,\@saveBeforeSymbolMacro,\compiler} -\TestForConflict{\interpreter,\machine,\program,\@compiler} -\newif\if@@Left -\newif\if@@Up -\newcount\@@xShift -\newcount\@@yShift -\newtoks\@@symbol -\newtoks\@@tempSymbol -\newcommand{\compiler}[1]{\@compiler#1\end} -\def\@compiler#1,#2,#3\end{% - \if@@Nested % - \if@@Up % - \@@yShift=40 \if@@Left \@@xShift=-50 \else \@@xShift=-30 \fi - \else% - \@@yShift=20 \@@xShift =0 % - \fi% - \else% - \@@yShift=40 \@@xShift=-40% - \fi - \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{% - \put(0,0){\line(1,0){80}}% - \put(0,-20){\line(1,0){30}}% - \put(50,-20){\line(1,0){30}}% - \put(30,-40){\line(1,0){20}}% - \put(0,0){\line(0,-1){20}}% - \put(80,0){\line(0,-1){20}}% - \put(30,-20){\line(0,-1){20}}% - \put(50,-20){\line(0,-1){20}}% - \put(30,-20){\makebox(20,20){$\rightarrow$}} % - {\@@Uptrue \@@Lefttrue \@parseArg(0,-20)(5,-20)#1\end}% - \if@@Up \else \@@tempSymbol=\expandafter{\the\@@symbol}\fi - {\@@Uptrue \@@Leftfalse \@parseArg(80,-20)(55,-20)#3\end}% - {\@@Upfalse \@@Lefttrue \@parseArg(50,-40)(30,-40)#2\end}% - \if@@Up \@@tempSymbol=\expandafter{\the\@@symbol}\fi - \if@@Nested \global\@@symbol=\expandafter{\the\@@tempSymbol} \fi% - }% -} -\newcommand{\interpreter}[1]{\@interpreter#1\end} -\def\@interpreter#1,#2\end{% - \if@@Nested % - \if@@Up % - \@@yShift=40 \if@@Left \@@xShift=0 \else \@@xShift=20 \fi - \else% - \@@yShift=0 \@@xShift =0 % - \fi% - \else% - \@@yShift=40 \@@xShift=10% - \fi - \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{% - \put(0,0){\line(-1,0){20}}% - \put(0,-40){\line(-1,0){20}}% - \put(0,0){\line(0,-1){40}}% - \put(-20,0){\line(0,-1){40}}% - {\@@Uptrue \@@Lefttrue \@parseArg(0,0)(-20,-20)#1\end}% - \if@@Up \else \@@tempSymbol=\expandafter{\the\@@symbol}\fi - {\@@Upfalse \@@Lefttrue \@parseArg(0,-40)(-20,-40)#2\end}% - \if@@Up \@@tempSymbol=\expandafter{\the\@@symbol}\fi - \if@@Nested \global\@@symbol=\expandafter{\the\@@tempSymbol} \fi% - }% -} -\newcommand{\program}[1]{\@program#1\end} -\def\@program#1,#2\end{% - \if@@Nested % - \if@@Up % - \@@yShift=0 \if@@Left \@@xShift=0 \else \@@xShift=20 \fi - \else% - \PackageError{semantic}{% - A program cannot be at the bottom} - {% - You have tried to use a \protect\program\space as the - bottom\MessageBreak parameter to \protect\compiler, - \protect\interpreter\space or \protect\program.\MessageBreak - Type to proceed --- Output can be distorted.}% - \fi% - \else% - \@@yShift=0 \@@xShift=10% - \fi - \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{% - \put(0,0){\line(-1,0){20}}% - \put(0,0){\line(0,1){30}}% - \put(-20,0){\line(0,1){30}}% - \put(-10,30){\oval(20,20)[t]}% - \@putSymbol[#1]{-20,20}% - {\@@Upfalse \@@Lefttrue \@parseArg(0,0)(-20,0)#2\end}% - }% -} -\newcommand{\machine}[1]{% - \if@@Nested % - \if@@Up % - \PackageError{semantic}{% - A machine cannot be at the top} - {% - You have tried to use a \protect\machine\space as a - top\MessageBreak parameter to \protect\compiler or - \protect\interpreter.\MessageBreak - Type to proceed --- Output can be distorted.}% - \else \@@yShift=0 \@@xShift=0 - \fi% - \else% - \@@yShift=20 \@@xShift=10% - \fi - \hskip\@@xShift\unitlength\raise \@@yShift\unitlength\hbox{% - \put(0,0){\line(-1,0){20}} \put(-20,0){\line(3,-5){10}} - \put(0,0){\line(-3,-5){10}}% - {\@@Uptrue \@@Lefttrue \@parseArg(0,0)(-20,-15)#1\end}% - }% -} -\def\@parseArg(#1)(#2){% - \@ifNextMacro{\@doSymbolMacro(#1)(#2)}{\@getSymbol(#2)}} -\def\@getSymbol(#1)#2\end{\@putSymbol[#2]{#1}} -\def\@doSymbolMacro(#1)(#2)#3{% - \@ifnextchar[{\@saveBeforeSymbolMacro(#1)(#2)#3}% - {\@symbolMacro(#1)(#2)#3}} -\def\@saveBeforeSymbolMacro(#1)(#2)#3[#4]#5\end{% - \@@tempSymbol={#4}% - \@@Nestedtrue\put(#1){#3#5}% - \@putSymbol[\the\@@tempSymbol]{#2}} -\def\@symbolMacro(#1)(#2)#3\end{% - \@@Nestedtrue\put(#1){#3}% - \@putSymbol{#2}} -\newcommand{\@putSymbol}[2][\the\@@symbol]{% - \global\@@symbol=\expandafter{#1}% - \put(#2){\makebox(20,20){\texttt{\the\@@symbol}}}} -\fi -\endinput -%% -%% End of file `tdiagram.sty'. diff --git a/matita/components/tactics/eliminationTactics.ml b/matita/components/tactics/eliminationTactics.ml deleted file mode 100644 index 5a293bcaf..000000000 --- a/matita/components/tactics/eliminationTactics.ml +++ /dev/null @@ -1,170 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -module C = Cic -module I = CicInspect -module S = CicSubstitution -module TC = CicTypeChecker -module P = PrimitiveTactics -module T = Tacticals -module PESR = ProofEngineStructuralRules -module F = FreshNamesGenerator -module PET = ProofEngineTypes -module RT = ReductionTactics -module E = CicEnvironment -module R = CicReduction -module Un = CicUniv -module PEH = ProofEngineHelpers - -let premise_pattern what = None, [what, C.Implicit (Some `Hole)], None - -let get_inductive_def uri = - match E.get_obj Un.oblivion_ugraph uri with - | C.InductiveDefinition (tys, _, lpsno, _), _ -> - lpsno, tys - | _ -> assert false - -let is_not_recursive uri tyno tys = - let map mutinds (_, ty) = -(* FG: we can do much better here *) - let map mutinds (_, t) = I.S.union mutinds (I.get_mutinds_of_uri uri t) in -(**********************************) - let premises, _ = PEH.split_with_whd ([], ty) in - List.fold_left map mutinds (List.tl premises) - in - let msg = "recursiveness check non implemented for mutually inductive types" in - if List.length tys > 1 then raise (PET.Fail (lazy msg)) else - let _, _, _, constructors = List.nth tys tyno in - let mutinds = List.fold_left map I.S.empty constructors in - I.S.is_empty mutinds - -let rec check_type sorts metasenv context t = - match R.whd ~delta:true context t with - | C.MutInd (uri, tyno, _) as t -> - let lpsno, tys = get_inductive_def uri in - let _, inductive, arity, _ = List.nth tys tyno in - let _, psno = PEH.split_with_whd ([], arity) in - let not_relation = (lpsno = psno) in - let not_recursive = is_not_recursive uri tyno tys in - let ty_ty, _ = TC.type_of_aux' metasenv context t Un.oblivion_ugraph in - let sort = match PEH.split_with_whd (context, ty_ty) with - | (_, C.Sort sort) ::_ , _ -> CicPp.ppsort sort - | (_, C.Meta _) :: _, _ -> CicPp.ppsort (C.Type (Un.fresh ())) - | _ -> assert false - in - let right_sort = List.mem sort sorts in - if not_relation && inductive && not_recursive && right_sort then - begin - HLog.warn (Printf.sprintf "Decomposing %s %u" (UriManager.string_of_uri uri) (succ tyno)); - true - end - else false - | C.Appl (hd :: tl) -> check_type sorts metasenv context hd - | _ -> false - -(* unexported tactics *******************************************************) - -let rec scan_tac ~old_context_length ~index ~tactic = - let scan_tac status = - let (proof, goal) = status in - let _, metasenv, _subst, _, _, _ = proof in - let _, context, _ = CicUtil.lookup_meta goal metasenv in - let context_length = List.length context in - let rec aux index = - match PEH.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 PET.apply_tactic tac status - with PET.Fail _ -> aux (pred index) - in aux (index + context_length - old_context_length) - in - PET.mk_tactic scan_tac - -let elim_clear_unfold_tac ~sorts ~mk_fresh_name_callback ~what = - let elim_clear_unfold_tac status = - let (proof, goal) = status in - let _, metasenv, _subst, _, _, _ = proof in - let _, context, _ = CicUtil.lookup_meta goal metasenv in - let index, ty = PEH.lookup_type metasenv context what in - let tac = - if check_type sorts metasenv context (S.lift index ty) then - T.then_ ~start:(P.elim_intros_tac ~mk_fresh_name_callback (C.Rel index)) - ~continuation:(PESR.clear [what]) - else - let msg = "unexported elim_clear: not an decomposable type" in - raise (PET.Fail (lazy msg)) - in - PET.apply_tactic tac status - in - PET.mk_tactic elim_clear_unfold_tac - -(* elim type ****************************************************************) - -let elim_type_tac ?(mk_fresh_name_callback = F.mk_fresh_name ~subst:[]) ?depth - ?using what -= - let elim = - P.elim_intros_simpl_tac ?using ?depth ~mk_fresh_name_callback - in - let elim_type_tac status = - let tac = - T.thens ~start: (P.cut_tac what) ~continuations:[elim (C.Rel 1); T.id_tac] - in - PET.apply_tactic tac status - in - PET.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))) - -(* roba seria ------------------------------------------------------------- *) - -let decompose_tac ?(sorts=[CicPp.ppsort C.Prop; CicPp.ppsort (C.CProp (CicUniv.fresh ()))]) - ?(mk_fresh_name_callback = F.mk_fresh_name ~subst:[]) () = - let decompose_tac status = - let (proof, goal) = status in - let _, metasenv, _subst, _,_, _ = proof in - let _, context, _ = CicUtil.lookup_meta goal metasenv in - let tactic = elim_clear_unfold_tac ~sorts ~mk_fresh_name_callback in - let old_context_length = List.length context in - let tac = scan_tac ~old_context_length ~index:old_context_length ~tactic - in - PET.apply_tactic tac status - in - PET.mk_tactic decompose_tac diff --git a/matita/components/tactics/eliminationTactics.mli b/matita/components/tactics/eliminationTactics.mli deleted file mode 100644 index b203bee22..000000000 --- a/matita/components/tactics/eliminationTactics.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val elim_type_tac: - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?depth:int -> ?using:Cic.term -> Cic.term -> ProofEngineTypes.tactic - -val decompose_tac: - ?sorts:string list -> - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - unit -> ProofEngineTypes.tactic diff --git a/matita/components/tactics/equalityTactics.ml b/matita/components/tactics/equalityTactics.ml deleted file mode 100644 index 1a0fe31d0..000000000 --- a/matita/components/tactics/equalityTactics.ml +++ /dev/null @@ -1,376 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -module C = Cic -module U = UriManager -module PET = ProofEngineTypes -module PER = ProofEngineReduction -module PEH = ProofEngineHelpers -module PESR = ProofEngineStructuralRules -module P = PrimitiveTactics -module T = Tacticals -module R = CicReduction -module S = CicSubstitution -module TC = CicTypeChecker -module LO = LibraryObjects -module DTI = DoubleTypeInference -module HEL = HExtlib - -let rec rewrite ~direction ~pattern:(wanted,hyps_pat,concl_pat) equality status= - assert (wanted = None); (* this should be checked syntactically *) - let proof,goal = status in - let curi, metasenv, subst, pbo, pty, attrs = proof in - let (metano,context,gty) = CicUtil.lookup_meta goal metasenv in - match hyps_pat with - he::(_::_ as tl) -> - PET.apply_tactic - (T.then_ - (PET.mk_tactic (rewrite ~direction - ~pattern:(None,[he],None) equality)) - (PET.mk_tactic (rewrite ~direction - ~pattern:(None,tl,concl_pat) (S.lift 1 equality))) - ) status - | [_] as hyps_pat when concl_pat <> None -> - PET.apply_tactic - (T.then_ - (PET.mk_tactic (rewrite ~direction - ~pattern:(None,hyps_pat,None) equality)) - (PET.mk_tactic (rewrite ~direction - ~pattern:(None,[],concl_pat) (S.lift 1 equality))) - ) status - | _ -> - let arg,dir2,tac,concl_pat,gty = - match hyps_pat with - [] -> None,true,(fun ~term _ -> P.exact_tac term),concl_pat,gty - | [name,pat] -> - let arg,gty = ProofEngineHelpers.find_hyp name context in - let dummy = "dummy" in - Some arg,false, - (fun ~term typ -> - T.seq - ~tactics: - [PESR.rename [name] [dummy]; - P.letin_tac - ~mk_fresh_name_callback:(fun _ _ _ ~typ -> Cic.Name name) term; - PESR.clearbody name; - ReductionTactics.change_tac - ~pattern: - (None,[name,Cic.Implicit (Some `Hole)], None) - (ProofEngineTypes.const_lazy_term typ); - PESR.clear [dummy] - ]), - Some pat,gty - | _::_ -> assert false - in - let gsort,_ = - CicTypeChecker.type_of_aux' - metasenv ~subst context gty CicUniv.oblivion_ugraph - 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 ~subst context equality - CicUniv.oblivion_ugraph in - let (ty_eq,metasenv',arguments,fresh_meta) = - TermUtil.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 = - match gsort with - C.Sort C.Prop -> - if_right_to_left dir2 - LibraryObjects.eq_ind_URI LibraryObjects.eq_ind_r_URI - | C.Sort C.Set -> - if_right_to_left dir2 - LibraryObjects.eq_rec_URI LibraryObjects.eq_rec_r_URI - | _ -> - if_right_to_left dir2 - LibraryObjects.eq_rect_URI LibraryObjects.eq_rect_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 = S.lift 1 t1x in - let lifted_gty = S.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 (S.lift 1 term) in - Some (fun c m u -> - let distance = pred (List.length c - List.length context) in - S.lift distance lifted_t1, m, u),[],lifted_concl_pat - in - let subst,metasenv',ugraph,_,selected_terms_with_context = - ProofEngineHelpers.select - ~metasenv:metasenv' ~subst ~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 ty = CicMetaSubst.apply_subst subst ty in - let pbo = lazy (CicMetaSubst.apply_subst subst (Lazy.force pbo)) in - let pty = CicMetaSubst.apply_subst subst pty 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 - if lifted_gty = abstr_gty then - raise (ProofEngineTypes.Fail (lazy "nothing to do")); - 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 fresh_meta = CicMkImplicit.new_meta metasenv' subst in - let gty' = S.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' = S.subst t1 abstr_gty in - metasenv',arg,gty' - in - let exact_proof = - C.Appl [eq_ind ; ty ; t2 ; pred ; arg ; t1 ;equality] - in - try - let (proof',goals) = - PET.apply_tactic (tac ~term:exact_proof newtyp) - ((curi,metasenv',subst,pbo,pty, attrs),goal) - in - let goals = - goals@(ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv - ~newmetasenv:metasenv') - in - (proof',goals) - with (* FG: this should be PET.Fail _ *) - TC.TypeCheckerFailure m -> - let msg = lazy ("rewrite: "^ Lazy.force m) in - raise (PET.Fail msg) -;; - -let rewrite_tac ~direction ~pattern equality names = - let _, hyps_pat, _ = pattern in - let froms = List.map fst hyps_pat in - let start = PET.mk_tactic (rewrite ~direction ~pattern equality) in - let continuation = PESR.rename ~froms ~tos:names in - if names = [] then start else T.then_ ~start ~continuation -;; - -let rewrite_simpl_tac ~direction ~pattern equality names = - T.then_ - ~start:(rewrite_tac ~direction ~pattern equality names) - ~continuation: - (ReductionTactics.simpl_tac - ~pattern:(ProofEngineTypes.conclusion_pattern None)) - -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 uri,metasenv,subst,pbo,pty, attrs = proof in - let (_,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in - assert (hyps_pat = []); (*CSC: not implemented yet *) - let eq_URI = - match LibraryObjects.eq_URI () with - Some uri -> uri - | None -> raise (ProofEngineTypes.Fail (lazy "You need to register the default equality first. Please use the \"default\" command")) - in - let context_len = List.length context in - let subst,metasenv,u,_,selected_terms_with_context = - ProofEngineHelpers.select ~subst ~metasenv ~ugraph:CicUniv.oblivion_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 = lazy (CicMetaSubst.apply_subst subst (Lazy.force pbo)) in - let pty = CicMetaSubst.apply_subst subst pty in - let status = (uri,metasenv,subst,pbo,pty, attrs),goal in - let ty_of_with_what,u = - CicTypeChecker.type_of_aux' - metasenv ~subst context with_what CicUniv.oblivion_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 ~subst context t_in_context - CicUniv.oblivion_ugraph in - let b,u = CicReduction.are_convertible ~metasenv ~subst 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 : ProofEngineTypes.status) = - match whats with - [] -> ProofEngineTypes.apply_tactic T.id_tac status - | (what,lazy_pattern)::tl -> - let what = S.lift n what in - let with_what = S.lift n with_what in - let ty_of_with_what = S.lift n ty_of_with_what in - ProofEngineTypes.apply_tactic - (T.thens - ~start:( - P.cut_tac - (C.Appl [ - (C.MutInd (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 hyps = - try - match List.hd context with - Some (Cic.Name name,_) -> [name] - | _ -> assert false - with (Failure "hd") -> assert false - in - ProofEngineTypes.apply_tactic - (PESR.clear ~hyps) 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 : ProofEngineTypes.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 (_,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 (_,metasenv,_,_,_, _) = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - match (R.whd context ty) with - (C.Appl [(C.MutInd (uri, 0, [])); _; _; _]) - when LibraryObjects.is_eq_URI uri -> - ProofEngineTypes.apply_tactic - (T.thens - ~start:(PrimitiveTactics.apply_tac - ~term: (C.Const (LibraryObjects.trans_eq_URI uri, []))) - ~continuations: - [PrimitiveTactics.exact_tac ~term ; T.id_tac ; T.id_tac]) - status - - | _ -> raise (ProofEngineTypes.Fail (lazy "Transitivity failed")) - in - ProofEngineTypes.mk_tactic (transitivity_tac ~term) -;; - diff --git a/matita/components/tactics/equalityTactics.mli b/matita/components/tactics/equalityTactics.mli deleted file mode 100644 index 1aa48173c..000000000 --- a/matita/components/tactics/equalityTactics.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val rewrite_tac: - direction:[`LeftToRight | `RightToLeft] -> - pattern:ProofEngineTypes.lazy_pattern -> Cic.term -> string list -> - ProofEngineTypes.tactic - -val rewrite_simpl_tac: - direction:[`LeftToRight | `RightToLeft] -> - pattern:ProofEngineTypes.lazy_pattern -> Cic.term -> string list -> - ProofEngineTypes.tactic - -val replace_tac: - pattern:ProofEngineTypes.lazy_pattern -> - with_what:Cic.lazy_term -> ProofEngineTypes.tactic - -val reflexivity_tac: ProofEngineTypes.tactic -val symmetry_tac: ProofEngineTypes.tactic -val transitivity_tac: term:Cic.term -> ProofEngineTypes.tactic diff --git a/matita/components/tactics/fourier.ml b/matita/components/tactics/fourier.ml deleted file mode 100644 index d7728c0b3..000000000 --- a/matita/components/tactics/fourier.ml +++ /dev/null @@ -1,244 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* match ie.coef with - [] -> raise (Failure "empty ineq") - |(c::r) -> if rinf c r0 - then pop ie lneg - else if rinf r0 c then pop ie lpos - else pop ie lnul) - s; - [!lneg;!lnul;!lpos] -;; -(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!): -(add_hist [(equation 1, s1);...;(équation n, sn)]) -= -[{équation 1, [1;0;...;0], s1}; - {équation 2, [0;1;...;0], s2}; - ... - {équation n, [0;0;...;1], sn}] -*) -let add_hist le = - let n = List.length le in - let i=ref 0 in - List.map (fun (ie,s) -> - let h =ref [] in - for k=1 to (n-(!i)-1) do pop r0 h; done; - pop r1 h; - for k=1 to !i do pop r0 h; done; - i:=!i+1; - {coef=ie;hist=(!h);strict=s}) - le -;; -(* additionne deux inéquations *) -let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef; - hist=List.map2 rplus ie1.hist ie2.hist; - strict=ie1.strict || ie2.strict} -;; -(* multiplication d'une inéquation par un rationnel (positif) *) -let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef; - hist=List.map (fun x -> rmult a x) ie.hist; - strict= ie.strict} -;; -(* on enlève le premier coefficient *) -let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict} -;; -(* le premier coefficient: "tête" de l'inéquation *) -let hd_coef ie = List.hd ie.coef -;; - -(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient. -*) -let deduce_add lneg lpos = - let res=ref [] in - List.iter (fun i1 -> - List.iter (fun i2 -> - let a = rop (hd_coef i1) in - let b = hd_coef i2 in - pop (ie_tl (ie_add (ie_emult b i1) - (ie_emult a i2))) res) - lpos) - lneg; - !res -;; -(* élimination de la première variable à partir d'une liste d'inéquations: -opération qu'on itère dans l'algorithme de Fourier. -*) -let deduce1 s i= - match (partitionne s) with - [lneg;lnul;lpos] -> - let lnew = deduce_add lneg lpos in - (match lneg with [] -> print_string("non posso ridurre "^string_of_int i^"\n")|_->(); - match lpos with [] -> print_string("non posso ridurre "^string_of_int i^"\n")|_->()); - (List.map ie_tl lnul)@lnew - |_->assert false -;; -(* algorithme de Fourier: on élimine successivement toutes les variables. -*) -let deduce lie = - let n = List.length (fst (List.hd lie)) in - let lie=ref (add_hist lie) in - for i=1 to n-1 do - lie:= deduce1 !lie i; - done; - !lie -;; - -(* donne [] si le système a des find solutions, -sinon donne [c,s,lc] -où lc est la combinaison linéaire des inéquations de départ -qui donne 0 < c si s=true - ou 0 <= c sinon -cette inéquation étant absurde. -*) -(** Tryes to find if the system admits solutions. - @param lie the list of inequations - @return a list that can be empty if the system has solutions. Otherwise it returns a - one elements list [\[(c,s,lc)\]]. {b c} is the rational that can be obtained solving the system, - {b s} is true if the inequation that proves that the system is absurd is of type [c < 0], false if - [c <= 0], {b lc} is a list of rational that represents the liear combination to obtain the - absurd inequation *) -let unsolvable lie = - let lr = deduce lie in - let res = ref [] in - (try (List.iter (fun e -> - match e with - {coef=[c];hist=lc;strict=s} -> - if (rinf c r0 && (not s)) || (rinfeq c r0 && s) - then (res := [c,s,lc]; - raise (Failure "contradiction found")) - |_->assert false) - lr) - with _ -> ()); - !res -;; - -(* Exemples: - -let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];; -deduce test1;; -unsolvable test1;; - -let test2=[ -[r1;r1;r0;r0;r0],false; -[r0;r1;r1;r0;r0],false; -[r0;r0;r1;r1;r0],false; -[r0;r0;r0;r1;r1],false; -[r1;r0;r0;r0;r1],false; -[rop r1;rop r1;r0;r0;r0],false; -[r0;rop r1;rop r1;r0;r0],false; -[r0;r0;rop r1;rop r1;r0],false; -[r0;r0;r0;rop r1;rop r1],false; -[rop r1;r0;r0;r0;rop r1],false -];; -deduce test2;; -unsolvable test2;; - -*) diff --git a/matita/components/tactics/fourier.mli b/matita/components/tactics/fourier.mli deleted file mode 100644 index 8b26bc21a..000000000 --- a/matita/components/tactics/fourier.mli +++ /dev/null @@ -1,27 +0,0 @@ -type rational = { num : int; den : int; } -val print_rational : rational -> unit -val pgcd : int -> int -> int -val r0 : rational -val r1 : rational -val rnorm : rational -> rational -val rop : rational -> rational -val rplus : rational -> rational -> rational -val rminus : rational -> rational -> rational -val rmult : rational -> rational -> rational -val rinv : rational -> rational -val rdiv : rational -> rational -> rational -val rinf : rational -> rational -> bool -val rinfeq : rational -> rational -> bool -type ineq = { coef : rational list; hist : rational list; strict : bool; } -val pop : 'a -> 'a list ref -> unit -val partitionne : ineq list -> ineq list list -val add_hist : (rational list * bool) list -> ineq list -val ie_add : ineq -> ineq -> ineq -val ie_emult : rational -> ineq -> ineq -val ie_tl : ineq -> ineq -val hd_coef : ineq -> rational -val deduce_add : ineq list -> ineq list -> ineq list -val deduce1 : ineq list -> int -> ineq list -val deduce : (rational list * bool) list -> ineq list -val unsolvable : - (rational list * bool) list -> (rational * bool * rational list) list diff --git a/matita/components/tactics/fourierR.ml b/matita/components/tactics/fourierR.ml deleted file mode 100644 index eb3201c58..000000000 --- a/matita/components/tactics/fourierR.ml +++ /dev/null @@ -1,1199 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - - -(******************** THE FOURIER TACTIC ***********************) - -(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients -des inéquations et équations sont entiers. En attendant la tactique Field. -*) - -open Fourier -open ProofEngineTypes - - -let debug x = print_string ("____ "^x) ; flush stdout;; - -let debug_pcontext x = - let str = ref "" in - List.iter (fun y -> match y with Some(Cic.Name(a),_) -> str := !str ^ - a ^ " " | _ ->()) x ; - debug ("contesto : "^ (!str) ^ "\n") -;; - -(****************************************************************************** -Operations on linear combinations. - -Opérations sur les combinaisons linéaires affines. -La partie homogène d'une combinaison linéaire est en fait une table de hash -qui donne le coefficient d'un terme du calcul des constructions, -qui est zéro si le terme n'y est pas. -*) - - - -(** - The type for linear combinations -*) -type flin = {fhom:(Cic.term , rational)Hashtbl.t;fcste:rational} -;; - -(** - @return an empty flin -*) -let flin_zero () = {fhom = Hashtbl.create 50;fcste=r0} -;; - -(** - @param f a flin - @param x a Cic.term - @return the rational associated with x (coefficient) -*) -let flin_coef f x = - try - (Hashtbl.find f.fhom x) - with - _ -> r0 -;; - -(** - Adds c to the coefficient of x - @param f a flin - @param x a Cic.term - @param c a rational - @return the new flin -*) -let flin_add f x c = - match x with - Cic.Rel(n) ->( - let cx = flin_coef f x in - Hashtbl.remove f.fhom x; - Hashtbl.add f.fhom x (rplus cx c); - f) - |_->debug ("Internal error in Fourier! this is not a Rel "^CicPp.ppterm x^"\n"); - let cx = flin_coef f x in - Hashtbl.remove f.fhom x; - Hashtbl.add f.fhom x (rplus cx c); - f -;; -(** - Adds c to f.fcste - @param f a flin - @param c a rational - @return the new flin -*) -let flin_add_cste f c = - {fhom=f.fhom; - fcste=rplus f.fcste c} -;; - -(** - @return a empty flin with r1 in fcste -*) -let flin_one () = flin_add_cste (flin_zero()) r1;; - -(** - Adds two flin -*) -let flin_plus f1 f2 = - let f3 = flin_zero() in - Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; - Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom; - flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste; -;; - -(** - Substracts two flin -*) -let flin_minus f1 f2 = - let f3 = flin_zero() in - Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; - Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom; - flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste); -;; - -(** - @return a times f -*) -let flin_emult a f = - let f2 = flin_zero() in - Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom; - flin_add_cste f2 (rmult a f.fcste); -;; - - -(*****************************************************************************) - - -(** - @param t a term - @raise Failure if conversion is impossible - @return rational proiection of t -*) -let rec rational_of_term t = - (* fun to apply f to the first and second rational-term of l *) - let rat_of_binop f l = - let a = List.hd l and - b = List.hd(List.tl l) in - f (rational_of_term a) (rational_of_term b) - in - (* as before, but f is unary *) - let rat_of_unop f l = - f (rational_of_term (List.hd l)) - in - match t with - | Cic.Cast (t1,t2) -> (rational_of_term t1) - | Cic.Appl (t1::next) -> - (match t1 with - Cic.Const (u,boh) -> - if UriManager.eq u HelmLibraryObjects.Reals.ropp_URI then - rat_of_unop rop next - else if UriManager.eq u HelmLibraryObjects.Reals.rinv_URI then - rat_of_unop rinv next - else if UriManager.eq u HelmLibraryObjects.Reals.rmult_URI then - rat_of_binop rmult next - else if UriManager.eq u HelmLibraryObjects.Reals.rdiv_URI then - rat_of_binop rdiv next - else if UriManager.eq u HelmLibraryObjects.Reals.rplus_URI then - rat_of_binop rplus next - else if UriManager.eq u HelmLibraryObjects.Reals.rminus_URI then - rat_of_binop rminus next - else failwith "not a rational" - | _ -> failwith "not a rational") - | Cic.Const (u,boh) -> - if UriManager.eq u HelmLibraryObjects.Reals.r1_URI then r1 - else if UriManager.eq u HelmLibraryObjects.Reals.r0_URI then r0 - else failwith "not a rational" - | _ -> failwith "not a rational" -;; - -(* coq wrapper -let rational_of_const = rational_of_term;; -*) -let fails f a = - try - ignore (f a); - false - with - _-> true - ;; - -let rec flin_of_term t = - let fl_of_binop f l = - let a = List.hd l and - b = List.hd(List.tl l) in - f (flin_of_term a) (flin_of_term b) - in - try( - match t with - | Cic.Cast (t1,t2) -> (flin_of_term t1) - | Cic.Appl (t1::next) -> - begin - match t1 with - Cic.Const (u,boh) -> - begin - if UriManager.eq u HelmLibraryObjects.Reals.ropp_URI then - flin_emult (rop r1) (flin_of_term (List.hd next)) - else if UriManager.eq u HelmLibraryObjects.Reals.rplus_URI then - fl_of_binop flin_plus next - else if UriManager.eq u HelmLibraryObjects.Reals.rminus_URI then - fl_of_binop flin_minus next - else if UriManager.eq u HelmLibraryObjects.Reals.rmult_URI then - begin - let arg1 = (List.hd next) and - arg2 = (List.hd(List.tl next)) - in - if fails rational_of_term arg1 - then - if fails rational_of_term arg2 - then - ( (* prodotto tra 2 incognite ????? impossibile*) - failwith "Sistemi lineari!!!!\n" - ) - else - ( - match arg1 with - Cic.Rel(n) -> (*trasformo al volo*) - (flin_add (flin_zero()) arg1 (rational_of_term arg2)) - |_-> (* test this *) - let tmp = flin_of_term arg1 in - flin_emult (rational_of_term arg2) (tmp) - ) - else - if fails rational_of_term arg2 - then - ( - match arg2 with - Cic.Rel(n) -> (*trasformo al volo*) - (flin_add (flin_zero()) arg2 (rational_of_term arg1)) - |_-> (* test this *) - let tmp = flin_of_term arg2 in - flin_emult (rational_of_term arg1) (tmp) - - ) - else - ( (*prodotto tra razionali*) - (flin_add_cste (flin_zero()) (rmult (rational_of_term arg1) (rational_of_term arg2))) - ) - (*try - begin - (*let a = rational_of_term arg1 in - debug("ho fatto rational of term di "^CicPp.ppterm arg1^ - " e ho ottenuto "^string_of_int a.num^"/"^string_of_int a.den^"\n");*) - let a = flin_of_term arg1 - try - begin - let b = (rational_of_term arg2) in - debug("ho fatto rational of term di "^CicPp.ppterm arg2^ - " e ho ottenuto "^string_of_int b.num^"/"^string_of_int b.den^"\n"); - (flin_add_cste (flin_zero()) (rmult a b)) - end - with - _ -> debug ("ho fallito2 su "^CicPp.ppterm arg2^"\n"); - (flin_add (flin_zero()) arg2 a) - end - with - _-> debug ("ho fallito1 su "^CicPp.ppterm arg1^"\n"); - (flin_add(flin_zero()) arg1 (rational_of_term arg2)) - *) - end - else if UriManager.eq u HelmLibraryObjects.Reals.rinv_URI then - let a=(rational_of_term (List.hd next)) in - flin_add_cste (flin_zero()) (rinv a) - else if UriManager.eq u HelmLibraryObjects.Reals.rdiv_URI then - begin - let b=(rational_of_term (List.hd(List.tl next))) in - try - begin - let a = (rational_of_term (List.hd next)) in - (flin_add_cste (flin_zero()) (rdiv a b)) - end - with - _-> (flin_add (flin_zero()) (List.hd next) (rinv b)) - end - else assert false - end - |_ -> assert false - end - | Cic.Const (u,boh) -> - begin - if UriManager.eq u HelmLibraryObjects.Reals.r1_URI then flin_one () - else if UriManager.eq u HelmLibraryObjects.Reals.r0_URI then flin_zero () - else assert false - end - |_-> assert false) - with _ -> debug("eccezione = "^CicPp.ppterm t^"\n");flin_add (flin_zero()) t r1 -;; - -(* coq wrapper -let flin_of_constr = flin_of_term;; -*) - -(** - Translates a flin to (c,x) list - @param f a flin - @return something like (c1,x1)::(c2,x2)::...::(cn,xn) -*) -let flin_to_alist f = - let res=ref [] in - Hashtbl.iter (fun x c -> res:=(c,x)::(!res)) f; - !res -;; - -(* Représentation des hypothèses qui sont des inéquations ou des équations. -*) - -(** - The structure for ineq -*) -type hineq={hname:Cic.term; (* le nom de l'hypothèse *) - htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *) - hleft:Cic.term; - hright:Cic.term; - hflin:flin; - hstrict:bool} -;; - -(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0 -*) - -let ineq1_of_term (h,t) = - match t with (* match t *) - Cic.Appl (t1::next) -> - let arg1= List.hd next in - let arg2= List.hd(List.tl next) in - (match t1 with (* match t1 *) - Cic.Const (u,boh) -> - if UriManager.eq u HelmLibraryObjects.Reals.rlt_URI then - [{hname=h; - htype="Rlt"; - hleft=arg1; - hright=arg2; - hflin= flin_minus (flin_of_term arg1) - (flin_of_term arg2); - hstrict=true}] - else if UriManager.eq u HelmLibraryObjects.Reals.rgt_URI then - [{hname=h; - htype="Rgt"; - hleft=arg2; - hright=arg1; - hflin= flin_minus (flin_of_term arg2) - (flin_of_term arg1); - hstrict=true}] - else if UriManager.eq u HelmLibraryObjects.Reals.rle_URI then - [{hname=h; - htype="Rle"; - hleft=arg1; - hright=arg2; - hflin= flin_minus (flin_of_term arg1) - (flin_of_term arg2); - hstrict=false}] - else if UriManager.eq u HelmLibraryObjects.Reals.rge_URI then - [{hname=h; - htype="Rge"; - hleft=arg2; - hright=arg1; - hflin= flin_minus (flin_of_term arg2) - (flin_of_term arg1); - hstrict=false}] - else assert false - | Cic.MutInd (u,i,o) -> - if UriManager.eq u HelmLibraryObjects.Logic.eq_URI then - let t0= arg1 in - let arg1= arg2 in - let arg2= List.hd(List.tl (List.tl next)) in - (match t0 with - Cic.Const (u,boh) -> - if UriManager.eq u HelmLibraryObjects.Reals.r_URI then - [{hname=h; - htype="eqTLR"; - hleft=arg1; - hright=arg2; - hflin= flin_minus (flin_of_term arg1) - (flin_of_term arg2); - hstrict=false}; - {hname=h; - htype="eqTRL"; - hleft=arg2; - hright=arg1; - hflin= flin_minus (flin_of_term arg2) - (flin_of_term arg1); - hstrict=false}] - else assert false - |_-> assert false) - else assert false - |_-> assert false)(* match t1 *) - |_-> assert false (* match t *) -;; -(* coq wrapper -let ineq1_of_constr = ineq1_of_term;; -*) - -(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq) -*) - -let rec print_rl l = - match l with - []-> () - | a::next -> Fourier.print_rational a ; print_string " " ; print_rl next -;; - -let rec print_sys l = - match l with - [] -> () - | (a,b)::next -> (print_rl a; - print_string (if b=true then "strict\n"else"\n"); - print_sys next) - ;; - -(*let print_hash h = - Hashtbl.iter (fun x y -> print_string ("("^"-"^","^"-"^")")) h -;;*) - -let fourier_lineq lineq1 = - let nvar=ref (-1) in - let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *) - List.iter (fun f -> - Hashtbl.iter (fun x c -> - try ignore(Hashtbl.find hvar x) - with Not_found -> nvar:=(!nvar)+1; - Hashtbl.add hvar x (!nvar); - debug("aggiungo una var "^ - string_of_int !nvar^" per "^ - CicPp.ppterm x^"\n")) - f.hflin.fhom) - lineq1; - (*print_hash hvar;*) - debug("Il numero di incognite e' "^string_of_int (!nvar+1)^"\n"); - let sys= List.map (fun h-> - let v=Array.create ((!nvar)+1) r0 in - Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x) <- c) - h.hflin.fhom; - ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict)) - lineq1 in - debug ("chiamo unsolvable sul sistema di "^ - string_of_int (List.length sys) ^"\n"); - print_sys sys; - unsolvable sys -;; - -(***************************************************************************** -Construction de la preuve en cas de succès de la méthode de Fourier, -i.e. on obtient une contradiction. -*) - - -let _eqT = Cic.MutInd(HelmLibraryObjects.Logic.eq_URI, 0, []) ;; -let _False = Cic.MutInd (HelmLibraryObjects.Logic.false_URI, 0, []) ;; -let _not = Cic.Const (HelmLibraryObjects.Logic.not_URI,[]);; -let _R0 = Cic.Const (HelmLibraryObjects.Reals.r0_URI,[]);; -let _R1 = Cic.Const (HelmLibraryObjects.Reals.r1_URI,[]);; -let _R = Cic.Const (HelmLibraryObjects.Reals.r_URI,[]);; -let _Rfourier_eqLR_to_le=Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_eqLR_to_le.con"), []) ;; -let _Rfourier_eqRL_to_le=Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_eqRL_to_le.con"), []) ;; -let _Rfourier_ge_to_le =Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_ge_to_le.con"), []) ;; -let _Rfourier_gt_to_lt =Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_gt_to_lt.con"), []) ;; -let _Rfourier_le=Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_le.con"), []) ;; -let _Rfourier_le_le =Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_le_le.con"), []) ;; -let _Rfourier_le_lt =Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_le_lt.con"), []) ;; -let _Rfourier_lt=Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_lt.con"), []) ;; -let _Rfourier_lt_le =Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_lt_le.con"), []) ;; -let _Rfourier_lt_lt =Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_lt_lt.con"), []) ;; -let _Rfourier_not_ge_lt = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_not_ge_lt.con"), []) ;; -let _Rfourier_not_gt_le = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_not_gt_le.con"), []) ;; -let _Rfourier_not_le_gt = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_not_le_gt.con"), []) ;; -let _Rfourier_not_lt_ge = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rfourier_not_lt_ge.con"), []) ;; -let _Rinv = Cic.Const (HelmLibraryObjects.Reals.rinv_URI, []);; -let _Rinv_R1 = Cic.Const(HelmLibraryObjects.Reals.rinv_r1_URI, []);; -let _Rle = Cic.Const (HelmLibraryObjects.Reals.rle_URI, []);; -let _Rle_mult_inv_pos = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rle_mult_inv_pos.con"), []) ;; -let _Rle_not_lt = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rle_not_lt.con"), []) ;; -let _Rle_zero_1 = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rle_zero_1.con"), []) ;; -let _Rle_zero_pos_plus1 = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rle_zero_pos_plus1.con"), []) ;; -let _Rlt = Cic.Const (HelmLibraryObjects.Reals.rlt_URI, []);; -let _Rlt_mult_inv_pos = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rlt_mult_inv_pos.con"), []) ;; -let _Rlt_not_le = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rlt_not_le.con"), []) ;; -let _Rlt_zero_1 = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rlt_zero_1.con"), []) ;; -let _Rlt_zero_pos_plus1 = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rlt_zero_pos_plus1.con"), []) ;; -let _Rminus = Cic.Const (HelmLibraryObjects.Reals.rminus_URI, []);; -let _Rmult = Cic.Const (HelmLibraryObjects.Reals.rmult_URI, []);; -let _Rnot_le_le =Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rnot_le_le.con"), []) ;; -let _Rnot_lt0 = Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rnot_lt0.con"), []) ;; -let _Rnot_lt_lt =Cic.Const ((UriManager.uri_of_string - "cic:/Coq/fourier/Fourier_util/Rnot_lt_lt.con"), []) ;; -let _Ropp = Cic.Const (HelmLibraryObjects.Reals.ropp_URI, []);; -let _Rplus = Cic.Const (HelmLibraryObjects.Reals.rplus_URI, []);; - -(******************************************************************************) - -let is_int x = (x.den)=1 -;; - -(* fraction = couple (num,den) *) -let rec rational_to_fraction x= (x.num,x.den) -;; - -(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1))) -*) - -let rec int_to_real_aux n = - match n with - 0 -> _R0 (* o forse R0 + R0 ????? *) - | 1 -> _R1 - | _ -> Cic.Appl [ _Rplus ; _R1 ; int_to_real_aux (n-1) ] -;; - - -let int_to_real n = - let x = int_to_real_aux (abs n) in - if n < 0 then - Cic.Appl [ _Ropp ; x ] - else - x -;; - - -(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1))) -*) - -let rational_to_real x = - let (n,d)=rational_to_fraction x in - Cic.Appl [ _Rmult ; int_to_real n ; Cic.Appl [ _Rinv ; int_to_real d ] ] -;; - -(* preuve que 0 - pall "n0" status _Rlt_zero_1 ; - apply_tactic (PrimitiveTactics.apply_tac ~term:_Rlt_zero_1) status )) in - let tacd=ref (mk_tactic (fun status -> - pall "d0" status _Rlt_zero_1 ; - apply_tactic (PrimitiveTactics.apply_tac ~term:_Rlt_zero_1) status )) in - - - for i=1 to n-1 do - tacn:=(Tacticals.then_ - ~start:(mk_tactic (fun status -> - pall ("n"^string_of_int i) status _Rlt_zero_pos_plus1; - apply_tactic - (PrimitiveTactics.apply_tac ~term:_Rlt_zero_pos_plus1) - status)) - ~continuation:!tacn); - done; - for i=1 to d-1 do - tacd:=(Tacticals.then_ - ~start:(mk_tactic (fun status -> - pall "d" status _Rlt_zero_pos_plus1 ; - apply_tactic - (PrimitiveTactics.apply_tac ~term:_Rlt_zero_pos_plus1) status)) - ~continuation:!tacd); - done; - -debug("TAC ZERO INF POS\n"); - apply_tactic - (Tacticals.thens - ~start:(PrimitiveTactics.apply_tac ~term:_Rlt_mult_inv_pos) - ~continuations:[!tacn ;!tacd ] ) - status - in - mk_tactic (tac_zero_inf_pos (n,d)) -;; - - - -(* preuve que 0<=n*1/d -*) - -let tac_zero_infeq_pos gl (n,d) = - let tac_zero_infeq_pos gl (n,d) status = - (*let cste = pf_parse_constr gl in*) - debug("inizio tac_zero_infeq_pos\n"); - let tacn = ref - (*(if n=0 then - (PrimitiveTactics.apply_tac ~term:_Rle_zero_zero ) - else*) - (PrimitiveTactics.apply_tac ~term:_Rle_zero_1 ) - (* ) *) - in - let tacd=ref (PrimitiveTactics.apply_tac ~term:_Rlt_zero_1 ) in - for i=1 to n-1 do - tacn:=(Tacticals.then_ ~start:(PrimitiveTactics.apply_tac - ~term:_Rle_zero_pos_plus1) ~continuation:!tacn); - done; - for i=1 to d-1 do - tacd:=(Tacticals.then_ ~start:(PrimitiveTactics.apply_tac - ~term:_Rlt_zero_pos_plus1) ~continuation:!tacd); - done; - apply_tactic - (Tacticals.thens - ~start:(PrimitiveTactics.apply_tac ~term:_Rle_mult_inv_pos) - ~continuations:[!tacn;!tacd]) status - in - mk_tactic (tac_zero_infeq_pos gl (n,d)) -;; - - - -(* preuve que 0<(-n)*(1/d) => False -*) - -let tac_zero_inf_false gl (n,d) = - let tac_zero_inf_false gl (n,d) status = - if n=0 then - apply_tactic (PrimitiveTactics.apply_tac ~term:_Rnot_lt0) status - else - apply_tactic (Tacticals.then_ - ~start:(mk_tactic (apply_tactic (PrimitiveTactics.apply_tac ~term:_Rle_not_lt))) - ~continuation:(tac_zero_infeq_pos gl (-n,d))) - status - in - mk_tactic (tac_zero_inf_false gl (n,d)) -;; - -(* preuve que 0<=n*(1/d) => False ; n est negatif -*) - -let tac_zero_infeq_false gl (n,d) = - let tac_zero_infeq_false gl (n,d) status = - let (proof, goal) = status in - let curi,metasenv,_subst,pbo,pty, attrs = 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,_subst,pbo,pty, attrs = 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',_subst,pbo,pty, attrs 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,_subst,pbo,pty, attrs = 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',_subst,pbo,pty, attrs 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,_subst,pbo,pty, attrs = 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,ty))::next -> - [Some(name, - Cic.Def((CicSubstitution.lift n a),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,_subst,pbo,pty, attrs = 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',_subst,pbo,pty, attrs),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,_subst,s_pbo,s_pty, attrs = 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,_subst,pbo,pty, attrs = 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,_subst,pbo,pty, attrs = 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,_subst,pbo,pty, attrs = 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,_subst,pbo,pty, attrs = 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_tac; Tacticals.id_tac] - ]) - ;(*Tacticals.id_tac*) - Tacticals.then_ - ~start:(mk_tactic (fun status -> - let (proof, goal) = status in - let curi,metasenv,_subst,pbo,pty, attrs = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - (* check if ty is of type *) - let w1 = - debug("qui c'e' gia' l'or "^CicPp.ppterm ty^"\n"); - (match ty with - Cic.Prod (Cic.Anonymous,a,b) -> (Cic.Appl [_not;a]) - |_ -> assert false) - in - let r = apply_tactic - (ReductionTactics.change_tac - ~pattern:(ProofEngineTypes.conclusion_pattern (Some ty)) - (const_lazy_term w1)) status - in - debug("fine MY_CHNGE\n"); - r)) - ~continuation:(*PORTINGTacticals.id_tac*)tac2])) - ;(*Tacticals.id_tac*)!tac1]);(*end tac:=*) - - |_-> assert false)(*match (!lutil) *) - |_-> assert false); (*match res*) - debug ("finalmente applico tac\n"); - ( - let r = apply_tactic !tac (proof,goal) in - debug("\n\n]]]]]]]]]]]]]]]]]) That's all folks ([[[[[[[[[[[[[[[[[[[\n\n");r - - ) -;; - -let fourier_tac = mk_tactic fourier - - diff --git a/matita/components/tactics/fourierR.mli b/matita/components/tactics/fourierR.mli deleted file mode 100644 index e5790ec0f..000000000 --- a/matita/components/tactics/fourierR.mli +++ /dev/null @@ -1,5 +0,0 @@ -(* -val rewrite_tac: term:Cic.term -> ProofEngineTypes.tactic -val rewrite_simpl_tac: term:Cic.term -> ProofEngineTypes.tactic -*) -val fourier_tac: ProofEngineTypes.tactic diff --git a/matita/components/tactics/fwdSimplTactic.ml b/matita/components/tactics/fwdSimplTactic.ml deleted file mode 100644 index 087e4b3f5..000000000 --- a/matita/components/tactics/fwdSimplTactic.ml +++ /dev/null @@ -1,175 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -module PEH = ProofEngineHelpers -module U = CicUniv -module TC = CicTypeChecker -module PET = ProofEngineTypes -module S = CicSubstitution -module PT = PrimitiveTactics -module T = Tacticals -module FNG = FreshNamesGenerator -module MI = CicMkImplicit -module PESR = ProofEngineStructuralRules -module HEL = HExtlib - -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, _subst, _, _, _ = 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, _subst, _, _, _ = 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 get_clearables context terms = - let aux = function - | Cic.Rel i - | Cic.Appl (Cic.Rel i :: _) -> PEH.get_name context i - | _ -> None - in - HEL.list_rev_map_filter aux terms - -let lapply_tac_aux ?(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, _subst, u, t, attrs = proof in - let _, context, _ = CicUtil.lookup_meta goal metasenv in - let lemma, _ = TC.type_of_aux' metasenv context what U.oblivion_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, _subst, u, t, attrs) 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 - -let lapply_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) - (* ?(substs = []) *) ?(linear = false) ?how_many ?(to_what = []) what = - let lapply_tac status = - let proof, goal = status in - let _, metasenv, _subst, _, _, _ = proof in - let _, context, _ = CicUtil.lookup_meta goal metasenv in - let lapply = lapply_tac_aux ~mk_fresh_name_callback ?how_many ~to_what what in - let tac = - if linear then - let hyps = get_clearables context (what :: to_what) in - T.then_ ~start:lapply - ~continuation:(PESR.clear ~hyps) (* T.try_tactic ~tactic: *) - else - lapply - in - PET.apply_tactic tac status - in - PET.mk_tactic lapply_tac - -(* fwd **********************************************************************) - -let fwd_simpl_tac - ?(mk_fresh_name_callback = FNG.mk_fresh_name ~subst:[]) - ~dbd hyp = -assert false (* MATITA 1.0 - 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, _subst, _, _, _ = 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 ~hyps:[hyp]) in - PET.apply_tactic tac status - in - PET.mk_tactic fwd_simpl_tac - *) diff --git a/matita/components/tactics/fwdSimplTactic.mli b/matita/components/tactics/fwdSimplTactic.mli deleted file mode 100644 index f130fe7b4..000000000 --- a/matita/components/tactics/fwdSimplTactic.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val lapply_tac: - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?linear:bool -> ?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:HSql.dbd -> string -> ProofEngineTypes.tactic diff --git a/matita/components/tactics/hashtbl_equiv.ml b/matita/components/tactics/hashtbl_equiv.ml deleted file mode 100644 index 86448268c..000000000 --- a/matita/components/tactics/hashtbl_equiv.ml +++ /dev/null @@ -1,190 +0,0 @@ -(* Copyright (C) 2000-2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(*********************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Andrea Asperti *) -(* 8/09/2004 *) -(* *) -(* *) -(*********************************************************************) - -(* $Id$ *) - -(* the file contains an hash table of objects of the library - equivalent to some object in the standard subset; it is - mostly used to filter useless cases in auto *) - - -let equivalent_objects = -(* finte costanti; i.e. costanti senza corpo *) -[UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Ack0.con"(*,"finte costanti"*); - UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Ac10.con"(*,"finte costanti"*); - UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Ack2.con"(*,"finte costanti"*) - ]@ -(* inutili mostri *) -[UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Resg0.con"(*,"useless monster"*); - UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/Resg1.con"(*,"useless monster"*); - UriManager.uri_of_string "cic:/Rocq/DEMOS/Demo_AutoRewrite/ResAck0.con"(*,"useless monster"*) - ]@ -(* istanze *) - (UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_S.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal.con"*)):: -[ -UriManager.uri_of_string "cic:/Paris/ZF/src/useful/lem_iff_sym.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/iff_sym.con"*); -UriManager.uri_of_string "cic:/Lyon/AUTOMATA/Ensf_types/False_imp_P.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/False_ind.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/plus_O_r.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/Rfunctions/sum_f_R0_triangle.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/PartSum/Rabs_triang_gen.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Bertrand/Misc/eq_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_reg_l.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/deMorgan_not_and.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/or_not_and.con"*); -UriManager.uri_of_string "cic:/Rocq/DEMOS/Sorting/diff_true_false.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/diff_true_false.con"*); -UriManager.uri_of_string "cic:/CoRN/metrics/CMetricSpaces/nz.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Max/le_max_l.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/Decidable/not_or.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_or_and.con"*); -UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_not_equal.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_not_eq.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/R_sqrt/sqrt_sqrt.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/R_sqrt/sqrt_def.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/eps2_Rgt_R0_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/eps2_Rgt_R0.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/Eqdep_dec/eqT2eq.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Eqdep_dec/eq2eqT.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/R_sqr/Rsqr_eq_0.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rsqr_0_uniq.con"*); -UriManager.uri_of_string "cic:/Rocq/THREE_GAP/Nat_compl/en_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_10.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_pos.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps4_eps_subproof0.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps2_eps_subproof.con"*); -UriManager.uri_of_string "cic:/Coq/Arith/Le/le_refl.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/le.ind#xpointer(1/1/1)"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_n_n.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Le/le_refl.con"*); -UriManager.uri_of_string "cic:/Coq/ZArith/auxiliary/Zred_factor1.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zplus_diag_eq_mult_2.con"*); -UriManager.uri_of_string "cic:/Coq/Relations/Newman/caseRxy.con"(*,UriManager.uri_of_string "cic:/Coq/Relations/Newman/Ind_proof.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/S_plus_r.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/plus_n_Sm.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/Zmult_ab0a0b0.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_integral.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Algebra/Z_group/ax8.con"(*,UriManager.uri_of_string "cic:/Coq/NArith/BinPos/ZC2.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Algebra/Z_group/Zlt_reg_l.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_lt_compat_l.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/mult_neutr.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_1_l.con"*); -UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rlt_zero_1.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rlt_0_1.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/Classic.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/R_sqr/Rsqr_pos_lt.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rlt_0_sqr.con"*); -UriManager.uri_of_string "cic:/Rocq/THREE_GAP/Nat_compl/lt_minus2.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/ArithProp/lt_minus_O_lt.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/Rtrigo_def/sin_antisym.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rtrigo/sin_neg.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Functions_in_ZFC/Functions_in_ZFC/false_implies_everything.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/False_ind.con"*); -UriManager.uri_of_string "cic:/Coq/ring/Setoid_ring_normalize/index_eq_prop.con"(*,UriManager.uri_of_string "cic:/Coq/ring/Ring_normalize/index_eq_prop.con"*); -UriManager.uri_of_string "cic:/CoRN/algebra/Basics/le_pred.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Le/le_pred.con"*); -UriManager.uri_of_string "cic:/Lannion/continuations/FOUnify_cps/nat_complements/le_S_eqP.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare/le_le_S_eq.con"*); -UriManager.uri_of_string "cic:/Coq/Sorting/Permutation/permut_right.con"(*,UriManager.uri_of_string "cic:/Coq/Sorting/Permutation/permut_cons.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/Zlt_mult_l.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zmult_lt_compat_l.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rplus_lt_0_compat.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/DiscrR/Rplus_lt_pos.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zpower_1_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_1_r.con"*); -UriManager.uri_of_string "cic:/CoRN/fta/KeyLemma/lem_1c.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*); -UriManager.uri_of_string "cic:/Coq/omega/OmegaLemmas/OMEGA20.con"(*,UriManager.uri_of_string "cic:/Coq/omega/OmegaLemmas/OMEGA17.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/pair_2.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/injective_projections.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps4_eps_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rlimit/Rlt_eps2_eps_subproof.con"*); -UriManager.uri_of_string "cic:/CoRN/algebra/Basics/le_mult_right.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat_r.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zle_lt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_le_lt_compat.con"*); -UriManager.uri_of_string "cic:/Rocq/ARITH/Chinese/Nat_complements/lt_minus2.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/ArithProp/lt_minus_O_lt.con"*); -UriManager.uri_of_string "cic:/Rocq/THREE_GAP/Nat_compl/not_gt_le.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare_dec/not_gt.con"*); -UriManager.uri_of_string "cic:/Rocq/ARITH/Chinese/Nat_complements/mult_commut.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_comm.con"*); -UriManager.uri_of_string "cic:/CoRN/algebra/Basics/lt_mult_right.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_lt_compat_r.con"*); -UriManager.uri_of_string "cic:/Rocq/ARITH/Chinese/Nat_complements/mult_neutr.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_1_l.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_neg.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_non_eq.con"*); -UriManager.uri_of_string "cic:/Lyon/FIRING-SQUAD/bib/plus_S.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/plus_Sn_m.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Qhomographic_Qpositive_to_Qpositive/one_non_negative.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zle_0_1.con"*); -UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rle_zero_1.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rle_0_1.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/Diaconescu/proof_irrel.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/proof_irrelevance.con"*); -UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_equal.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/sym_eq.con"*); -UriManager.uri_of_string "cic:/Coq/IntMap/Mapiter/pair_sp.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/surjective_pairing.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/ProofIrrelevance/proof_irrelevance_cci.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/proof_irrelevance.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/deMorgan_or_not.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_and_or.con"*); -UriManager.uri_of_string "cic:/CoRN/model/structures/Zsec/Zplus_wd0.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zplus_eq_compat.con"*); -UriManager.uri_of_string "cic:/Coq/ZArith/auxiliary/Zred_factor6.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zplus_0_r_reverse.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/S_inj.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_add_S.con"*); -UriManager.uri_of_string "cic:/Coq/ZArith/Wf_Z/Z_of_nat_complete.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/IZN.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/Commutative_orb.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/orb_comm.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/PartSum/plus_sum.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Cauchy_prod/sum_plus.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Qpositive/minus_le.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*); -UriManager.uri_of_string "cic:/Lyon/FIRING-SQUAD/bib/plus_zero.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Cours-de-Coq/ex1_auto/not_not_converse.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/deMorgan_and_not.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_or_and.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/Commutative_andb.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/andb_comm.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/lt_minus2.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/ArithProp/lt_minus_O_lt.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/canonicite/Prelude0/Morgan_and_not.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/not_or_and.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/TrueP.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/FalseP.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zminus_eq.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zminus_eq.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Cours-de-Coq/ex1/not_not_converse.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/pair_1.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/surjective_pairing.con"*); -UriManager.uri_of_string "cic:/Orsay/Maths/divide/Zabs_ind.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_ind.con"*); -UriManager.uri_of_string "cic:/CoRN/algebra/Basics/Zmult_minus_distr_r.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_minus_distr_l.con"*); -UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rfourier_eqLR_to_le.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Req_le.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/Sn_eq_Sm_n_eq_m.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_add_S.con"*); -UriManager.uri_of_string "cic:/Coq/Init/Logic/trans_equal.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Logic/trans_eq.con"*); -UriManager.uri_of_string "cic:/Coq/omega/OmegaLemmas/OMEGA2.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_le_0_compat.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Bertrand/Raux/P_Rmin.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rpower/P_Rmin.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/MATHS/Z/Nat_complements/mult_commut.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_comm.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Huffman/Aux/le_minus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*); -UriManager.uri_of_string "cic:/Coq/Init/Peano/plus_O_n.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_l.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/Berardi/inv2.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Berardi/AC.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/SeqProp/not_Rlt.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Rnot_lt_ge.con"*); -UriManager.uri_of_string "cic:/Nancy/FOUnify/nat_complements/le_S_eqP.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare/le_le_S_eq.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_mult_l.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat_r.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/natZ/isnat_mult.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zmult_le_0_compat.con"*); -UriManager.uri_of_string "cic:/Coq/fourier/Fourier_util/Rfourier_eqRL_to_le.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/RIneq/Req_le_sym.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_mult.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_Zmult.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/plus_n_O.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); -UriManager.uri_of_string "cic:/Suresnes/BDD/rauzy/algorithme1/Prelude_BDT/excluded_middle.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/classic.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_mult_mult.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat.con"*); -UriManager.uri_of_string "cic:/Coq/Bool/Bool/Is_true_eq_true2.con"(*,UriManager.uri_of_string "cic:/Coq/Bool/Bool/Is_true_eq_left.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/natZ/isnat_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_le_0_compat.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/lt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_lt_compat.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/le_mult_r.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Mult/mult_le_compat_l.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Functions_in_ZFC/Functions_in_ZFC/excluded_middle.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/NNPP.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Algebra/Z_group/ax3.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zgt_pos_0.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zabs_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zabs/Zabs_triangle.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Buchberger/Buch/Sdep.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Datatypes/prod_ind.con"*); -UriManager.uri_of_string "cic:/Coq/Reals/PartSum/Rsum_abs.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/PartSum/Rabs_triang_gen.con"*); -UriManager.uri_of_string "cic:/Cachan/SMC/mu/minus_n_m_le_n.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/le_minus.con"*); -UriManager.uri_of_string "cic:/Marseille/GC/lib_arith/lib_S_pred/eqnm_eqSnSm.con"(*,UriManager.uri_of_string "cic:/Coq/Init/Peano/eq_S.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zpower_1_subproof_subproof.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/BinInt/Zmult_1_r.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/predminus1.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Minus/pred_of_minus.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Bertrand/Raux/Rpower_pow.con"(*,UriManager.uri_of_string "cic:/Coq/Reals/Rpower/Rpower_pow.con"*); -UriManager.uri_of_string "cic:/Lyon/FIRING-SQUAD/bib/lt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_lt_compat.con"*); -UriManager.uri_of_string "cic:/Eindhoven/POCKLINGTON/lemmas/Zlt_neq.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zlt_not_eq.con"*); -UriManager.uri_of_string "cic:/Coq/Arith/Lt/nat_total_order.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Compare_dec/not_eq.con"*); -UriManager.uri_of_string "cic:/Rocq/TreeAutomata/bases/plus_O_l.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_0_r.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/boolP.ind#xpointer(1/1/2)"(*,UriManager.uri_of_string "cic:/Coq/Logic/ClassicalFacts/boolP.ind#xpointer(1/1/1)"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zmult_pos_pos.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zmult_lt_O_compat.con"*); -UriManager.uri_of_string "cic:/Nijmegen/QArith/Zaux/Zlt_plus_plus.con"(*,UriManager.uri_of_string "cic:/Coq/ZArith/Zorder/Zplus_lt_compat.con"*); -UriManager.uri_of_string "cic:/Coq/Logic/Diaconescu/pred_ext_and_rel_choice_imp_EM.con"(*,UriManager.uri_of_string "cic:/Coq/Logic/Classical_Prop/classic.con"*); -UriManager.uri_of_string "cic:/Sophia-Antipolis/Rsa/MiscRsa/eq_plus.con"(*,UriManager.uri_of_string "cic:/Coq/Arith/Plus/plus_reg_l.con"*) -] -;; - -let equiv_table = Hashtbl.create 503 -;; - -let _ = List.iter (fun a -> Hashtbl.add equiv_table a "") equivalent_objects -;; - -let not_a_duplicate u = - try - ignore(Hashtbl.find equiv_table u); false - with - Not_found -> true -;; diff --git a/matita/components/tactics/hashtbl_equiv.mli b/matita/components/tactics/hashtbl_equiv.mli deleted file mode 100644 index d2608b862..000000000 --- a/matita/components/tactics/hashtbl_equiv.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* Copyright (C) 2000-2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(*********************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Andrea Asperti *) -(* 8/09/2004 *) -(* *) -(* *) -(*********************************************************************) - - -val not_a_duplicate : UriManager.uri -> bool - diff --git a/matita/components/tactics/history.ml b/matita/components/tactics/history.ml deleted file mode 100644 index 7559f367e..000000000 --- a/matita/components/tactics/history.ml +++ /dev/null @@ -1,86 +0,0 @@ -(* Copyright (C) 2004, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -exception History_failure - -class ['a] history size = - let unsome = function Some x -> x | None -> assert false in - object (self) - - val history_data = Array.create (size + 1) None - - val mutable history_hd = 0 (* rightmost index *) - val mutable history_cur = 0 (* current index *) - val mutable history_tl = 0 (* leftmost index *) - - method private is_empty = history_data.(history_cur) = None - - method push (status: 'a) = - if self#is_empty then - history_data.(history_cur) <- Some status - else begin - history_cur <- (history_cur + 1) mod size; - history_data.(history_cur) <- Some status; - history_hd <- history_cur; (* throw away fake future line *) - if history_hd = history_tl then (* tail overwritten *) - history_tl <- (history_tl + 1) mod size - end - - method undo = function - | 0 -> unsome history_data.(history_cur) - | steps when steps > 0 -> - let max_undo_steps = - if history_cur >= history_tl then - history_cur - history_tl - else - history_cur + (size - history_tl) - in - if steps > max_undo_steps then - raise History_failure; - history_cur <- history_cur - steps; - if history_cur < 0 then (* fix underflow *) - history_cur <- size + history_cur; - unsome history_data.(history_cur) - | steps (* when steps > 0 *) -> self#redo ~-steps - - method redo = function - | 0 -> unsome history_data.(history_cur) - | steps when steps > 0 -> - let max_redo_steps = - if history_hd >= history_cur then - history_hd - history_cur - else - history_hd + (size - history_cur) - in - if steps > max_redo_steps then - raise History_failure; - history_cur <- (history_cur + steps) mod size; - unsome history_data.(history_cur) - | steps (* when steps > 0 *) -> self#undo ~-steps - - end - diff --git a/matita/components/tactics/history.mli b/matita/components/tactics/history.mli deleted file mode 100644 index 86bad463f..000000000 --- a/matita/components/tactics/history.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2004, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -exception History_failure - -class ['a] history : - int -> - object - method push : 'a -> unit - method redo : int -> 'a - method undo : int -> 'a - end - diff --git a/matita/components/tactics/introductionTactics.ml b/matita/components/tactics/introductionTactics.ml deleted file mode 100644 index d8caf933b..000000000 --- a/matita/components/tactics/introductionTactics.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -let fake_constructor_tac ~n (proof, goal) = - let module C = Cic in - let module R = CicReduction in - let (_,metasenv,_subst,_,_, _) = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - match (R.whd context ty) with - (C.MutInd (uri, typeno, exp_named_subst)) - | (C.Appl ((C.MutInd (uri, typeno, exp_named_subst))::_)) -> - ProofEngineTypes.apply_tactic ( - PrimitiveTactics.apply_tac - ~term: (C.MutConstruct (uri, typeno, n, exp_named_subst))) - (proof, goal) - | _ -> raise (ProofEngineTypes.Fail (lazy "Constructor: failed")) -;; - -let constructor_tac ~n = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n) - -let exists_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:1) ;; -let split_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:1) ;; -let left_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:1) ;; -let right_tac = ProofEngineTypes.mk_tactic (fake_constructor_tac ~n:2) ;; - diff --git a/matita/components/tactics/introductionTactics.mli b/matita/components/tactics/introductionTactics.mli deleted file mode 100644 index c3a12720b..000000000 --- a/matita/components/tactics/introductionTactics.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val constructor_tac: n:int -> ProofEngineTypes.tactic - -val exists_tac: ProofEngineTypes.tactic -val split_tac: ProofEngineTypes.tactic -val left_tac: ProofEngineTypes.tactic -val right_tac: ProofEngineTypes.tactic diff --git a/matita/components/tactics/inversion.ml b/matita/components/tactics/inversion.ml deleted file mode 100644 index fa4b71178..000000000 --- a/matita/components/tactics/inversion.ml +++ /dev/null @@ -1,382 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. -* - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -exception TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple -exception NotAnInductiveTypeToEliminate - -let debug = false;; -let debug_print = - fun msg -> if debug then prerr_endline (Lazy.force msg) else () - - -let inside_obj = function - | Cic.InductiveDefinition (type_list,params, nleft, _) -> - (type_list,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") - -(* returns DX1 = DX1 -> ... DXn=DXn -> GOALTY *) -let rec foo_cut nleft parameters parameters_ty body uri_of_eq selections = - if nleft > 0 - then - foo_cut (nleft-1) (List.tl parameters) (List.tl parameters_ty) body - uri_of_eq selections - else - match parameters,selections with - | hd::tl, x::xs when x -> - Cic.Prod ( - Cic.Anonymous, - Cic.Appl[Cic.MutInd (uri_of_eq ,0,[]); - (List.hd parameters_ty) ; hd; hd], - foo_cut nleft (List.map (CicSubstitution.lift 1) tl) - (List.map (CicSubstitution.lift 1) (List.tl parameters_ty)) - (CicSubstitution.lift 1 body) uri_of_eq xs) - | hd::tl,x::xs -> - foo_cut nleft tl (List.tl parameters_ty) body uri_of_eq xs - | [],[] -> body - | _ -> raise (Invalid_argument "inverter: the selection doesn't match the arity of the specified inductive type") -;; - -(* from a complex Cic.Prod term, return the list of its components *) -let rec get_sort_type term = - match term with - | Cic.Prod (_,src,tgt) -> (get_sort_type 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) - | _ -> [] -;; - -(* returns the term to apply*) -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; - (* apply i_ind ? ... ? H *) - Cic.Appl ([Cic.Const(uri,[])] @ !a @ [Cic.Rel 1]) -;; - - -(* induction/inversion, abbastanza semplicemente, consiste nel generare i prod - * delle uguaglianze corrispondenti ai soli parametri destri appartenenti all'insieme S. - * Attenzione al caso base: cos'e` replace_lifting? - * S = {} e` il principio di induzione - * S = insieme_dei_destri e` il principio di inversione *) -let rec foo_prod nright right_param_tys rightparameters l2 base_rel goalty - uri_of_eq rightparameters_ termty isSetType term selections selections_ = - match right_param_tys, selections with - | hd::tl, x::xs when x -> Cic.Prod ( - Cic.Anonymous, - Cic.Appl - [Cic.MutInd(uri_of_eq,0,[]); hd; (List.hd rightparameters); - Cic.Rel base_rel], - foo_prod (nright-1) - (List.map (CicSubstitution.lift 1) tl) - (List.map (CicSubstitution.lift 1) (List.tl rightparameters)) - (List.map (CicSubstitution.lift 1) l2) - base_rel (CicSubstitution.lift 1 goalty) uri_of_eq - (List.map (CicSubstitution.lift 1) rightparameters_) - (CicSubstitution.lift 1 termty) - isSetType (CicSubstitution.lift 1 term)) xs selections_ - | hd::tl, x::xs -> - foo_prod (nright-1) tl (List.tl rightparameters) l2 - (base_rel-1) goalty uri_of_eq rightparameters_ termty - isSetType term xs selections_ - | [],[] -> - ProofEngineReduction.replace_lifting - ~equality:(fun _ -> CicUtil.alpha_equivalence) - ~context:[] - ~what: (if isSetType - then rightparameters_ @ [term] - else rightparameters_ ) - ~with_what: (List.map (CicSubstitution.lift (-1)) l2) - ~where:goalty - | _ -> raise (Invalid_argument "inverter: the selection doesn't match the arity of the specified inductive type") -(* the same subterm of goalty could be simultaneously sx and dx!*) -;; - -(* induction/inversion, abbastanza semplicemente, consiste nel generare i lambda - * soltanto per i parametri destri appartenenti all'insieme S. - * Warning: non ne sono piu` cosi` sicuro... - * S = {} e` il principio di induzione - * S = insieme_dei_destri e` il principio di inversione *) -let rec foo_lambda nright right_param_tys nright_ right_param_tys_ - rightparameters created_vars base_rel goalty uri_of_eq rightparameters_ - termty isSetType term selections = - match right_param_tys with - | hd::tl -> Cic.Lambda ( - (Cic.Name ("lambda" ^ (string_of_int nright))), - hd, (* type *) - foo_lambda (nright-1) - (List.map (CicSubstitution.lift 1) tl) nright_ - (List.map (CicSubstitution.lift 1) right_param_tys_) - (List.map (CicSubstitution.lift 1) rightparameters) - (List.map (CicSubstitution.lift 1) (created_vars @ [Cic.Rel 1])) - base_rel (CicSubstitution.lift 1 goalty) uri_of_eq - (List.map (CicSubstitution.lift 1) rightparameters_) - (CicSubstitution.lift 1 termty) isSetType - (CicSubstitution.lift 1 term)) selections - | [] when isSetType -> Cic.Lambda ( - (Cic.Name ("lambda" ^ (string_of_int nright))), - (ProofEngineReduction.replace_lifting - ~equality:(fun _ -> CicUtil.alpha_equivalence) - ~context:[] - ~what: (rightparameters_ ) - ~with_what: (List.map (CicSubstitution.lift (-1)) created_vars) - ~where:termty), (* type of H with replaced right parameters *) - foo_prod nright_ (List.map (CicSubstitution.lift 1) right_param_tys_) - (List.map (CicSubstitution.lift 1) rightparameters) - (List.map (CicSubstitution.lift 1) (created_vars @ [Cic.Rel 1])) - (base_rel+1) (CicSubstitution.lift 1 goalty) uri_of_eq - (List.map (CicSubstitution.lift 1) rightparameters_) - (CicSubstitution.lift 1 termty) isSetType - (CicSubstitution.lift 1 term)) selections selections - | [] -> foo_prod nright_ right_param_tys_ rightparameters created_vars - base_rel goalty uri_of_eq rightparameters_ - termty isSetType term selections selections -;; - -let isSetType paramty = ((Pervasives.compare - (get_sort_type paramty) - (Cic.Sort Cic.Prop)) != 0) - -exception EqualityNotDefinedYet -let private_inversion_tac ~term selections = - 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 private_inversion_tac ~term (proof, goal) = - - (*DEBUG*) debug_print (lazy ("private inversion begins")); - let _,metasenv,_subst,_,_, _ = proof in - let uri_of_eq = - match LibraryObjects.eq_URI () with - None -> raise EqualityNotDefinedYet - | Some uri -> uri - in - let (_,context,goalty) = CicUtil.lookup_meta goal metasenv in - let termty,_ = T.type_of_aux' metasenv context term CicUniv.oblivion_ugraph in - let uri = baseuri_of_term termty in - let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri 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 buri = UriManager.buri_of_uri uri in - let name,nleft,paramty,cons_list = - match o with - C.InductiveDefinition (tys,_,nleft,_) -> - let (name,_,paramty,cons_list) = List.nth tys typeno in - (name,nleft,paramty,cons_list) - |_ -> assert false - in - let eliminator_uri = - UriManager.uri_of_string (buri ^ "/" ^ name ^ "_ind" ^ ".con") - in - let parameters = (List.tl (term_to_list termty)) in - let parameters_tys = - (List.map - (fun t -> ( - match (T.type_of_aux' metasenv context t CicUniv.oblivion_ugraph) with - (term,graph) -> term)) - parameters) - in - let consno = List.length cons_list in - let nright= ((List.length parameters)- nleft) in - let isSetType = isSetType paramty in - let cut_term = foo_cut nleft parameters - parameters_tys goalty uri_of_eq selections in - (*DEBUG*) debug_print (lazy ("cut term " ^ CicPp.ppterm cut_term)); - debug_print (lazy ("CONTEXT before apply HCUT: " ^ - (CicMetaSubst.ppcontext ~metasenv [] context ))); - debug_print (lazy ("termty " ^ CicPp.ppterm termty)); - (* cut DXn=DXn \to GOAL *) - let proof1,gl1 = PET.apply_tactic (P.cut_tac cut_term) (proof,goal) in - (* apply Hcut ; reflexivity *) - 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 - (*DEBUG*) debug_print (lazy ("after apply HCUT;reflexivity - in private inversion")); - (* apply (ledx_ind( lambda x. lambda y, ...)) *) - let t1,metasenv,_subst,t3,t4, attrs = proof2 in - let goal2 = List.hd (List.tl gl1) in - let (_,context,g2ty) = CicUtil.lookup_meta goal2 metasenv in - (* rightparameters type list *) - let rightparam_ty_l = (cut_first nleft parameters_tys) in - (* rightparameters list *) - let rightparameters= cut_first nleft parameters in - debug_print - (lazy ("Right param: " ^ (CicPp.ppterm (Cic.Appl rightparameters)))); - let lambda_t = foo_lambda nright rightparam_ty_l nright rightparam_ty_l - rightparameters [] nright goalty uri_of_eq rightparameters termty isSetType - term selections 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 goalty))); - debug_print - (lazy ("Right param: " ^ (CicPp.ppterm (Cic.Appl rightparameters)))); - debug_print (lazy ("CONTEXT before refinement: " ^ - (CicMetaSubst.ppcontext ~metasenv [] context ))); - (*DEBUG*) debug_print (lazy ("private inversion: term before refinement: " ^ - CicPp.ppterm t)); - let (ref_t,_,metasenv'',_) = CicRefine.type_of_aux' metasenv context t - CicUniv.oblivion_ugraph - in - (*DEBUG*) debug_print (lazy ("private inversion: termine after refinement: " - ^ CicPp.ppterm ref_t)); - let proof2 = (t1,metasenv'',_subst,t3,t4, attrs) in - let my_apply_tac = - let my_apply_tac status = - let proof,goals = - ProofEngineTypes.apply_tactic (P.apply_tac ref_t) status in - let patched_new_goals = - let (_,metasenv''',_subst,_,_, _) = proof in - let new_goals = ProofEngineHelpers.compare_metasenvs - ~oldmetasenv:metasenv ~newmetasenv:metasenv'' - in - List.filter (function i -> List.exists (function (j,_,_) -> j=i) - metasenv''') new_goals @ goals - in - proof,patched_new_goals - in - ProofEngineTypes.mk_tactic my_apply_tac - in - let proof3,gl3 = - PET.apply_tactic - (Tacticals.then_ - ~start:my_apply_tac - ~continuation: - (ReductionTactics.simpl_tac (ProofEngineTypes.conclusion_pattern(None)))) - (proof2,goal2) - in - - (proof3, gl3) -in -ProofEngineTypes.mk_tactic (private_inversion_tac ~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 inversion_tac ~term (proof, goal) = - (*DEBUG*) debug_print (lazy ("inversion begins")); - let _,metasenv,_subst,_,_, _ = proof in - let (_,context,goalty) = CicUtil.lookup_meta goal metasenv in - let termty,_ = T.type_of_aux' metasenv context term CicUniv.oblivion_ugraph in - let uri, typeno = - match termty with - | Cic.MutInd (uri,typeno,_) - | Cic.Appl(Cic.MutInd (uri,typeno,_)::_) -> uri,typeno - | _ -> assert false - in - (* let uri = baseuri_of_term termty in *) - let obj,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in - let name,nleft,arity,cons_list = - match obj with - Cic.InductiveDefinition (tys,_,nleft,_) -> - let (name,_,arity,cons_list) = List.nth tys typeno in - (name,nleft,arity,cons_list) - |_ -> assert false - in - let buri = UriManager.buri_of_uri uri in - let inversor_uri = - UriManager.uri_of_string (buri ^ "/" ^ name ^ "_inv" ^ ".con") in - (* arity length = number of parameters plus 1 *) - let arity_length = (List.length (term_to_list termty)) in - (* Check the existence of any right parameter. *) - assert (arity_length > (nleft + 1)); - let appl_term arity_consno uri = - let l = [] in - let a = ref l in - for n = 1 to arity_consno do - a := (Cic.Implicit None)::(!a) - done; - (* apply i_inv ? ...? H). *) - Cic.Appl ([Cic.Const(uri,[])] @ !a @ [term]) - in - let t = appl_term (arity_length + (List.length cons_list)) inversor_uri in - let (t1,metasenv,_subst,t3,t4, attrs) = proof in - let (ref_t,_,metasenv'',_) = CicRefine.type_of_aux' metasenv context t - CicUniv.oblivion_ugraph - in - let proof = (t1,metasenv'',_subst,t3,t4, attrs) in - let proof3,gl3 = - ProofEngineTypes.apply_tactic (P.apply_tac ref_t) (proof,goal) in - let patched_new_goals = - let (_,metasenv''',_subst,_,_, _) = proof3 in - let new_goals = ProofEngineHelpers.compare_metasenvs - ~oldmetasenv:metasenv ~newmetasenv:metasenv'' - in - List.filter (function i -> List.exists (function (j,_,_) -> j=i) - metasenv''') new_goals @ gl3 - in - (proof3, patched_new_goals) - in -ProofEngineTypes.mk_tactic (inversion_tac ~term) -;; diff --git a/matita/components/tactics/inversion.mli b/matita/components/tactics/inversion.mli deleted file mode 100644 index 46cf97ed9..000000000 --- a/matita/components/tactics/inversion.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val isSetType: Cic.term -> bool -exception EqualityNotDefinedYet (* raised by private_inversion_tac only *) -val private_inversion_tac: term: Cic.term -> bool list -> ProofEngineTypes.tactic -val inversion_tac: term: Cic.term -> ProofEngineTypes.tactic diff --git a/matita/components/tactics/inversion_principle.ml b/matita/components/tactics/inversion_principle.ml deleted file mode 100644 index 3229a261b..000000000 --- a/matita/components/tactics/inversion_principle.ml +++ /dev/null @@ -1,253 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -let debug = false;; -let debug_print = - fun msg -> if debug then prerr_endline (Lazy.force msg) else () - -(* cuts away the last element of a list 'l' *) -let rec cut_last l = - match l with - | hd::tl when tl != [] -> hd:: (cut_last tl) - | _ -> [] -;; - -(* cuts away the first 'n' elements of a list 'l' *) -let rec cut_first n l = - if n>0 then - match l with - | hd::tl -> cut_first (n-1) tl - | [] -> [] - else l -;; - -(* returns the first 'n' elements of a list 'l' *) -let rec takefirst n l = - if n > 0 then - match l with - hd::tl when n > 0 -> hd:: takefirst (n-1) tl - | _ -> assert false - else [] -;; - -(* from a complex Cic.Prod term, returns the list of its components *) -let rec list_of_prod term = - match term with - | Cic.Prod (_,src,tgt) -> src::(list_of_prod tgt) - | _ -> [term] -;; - -let rec build_metas sort cons_list created_vars right_created_vars prop - uri typeno = - match cons_list with - | hd::tl -> - Cic.Prod( - Cic.Anonymous, - Cic.Implicit None, - build_metas sort tl - (List.map (CicSubstitution.lift 1) created_vars) - (List.map (CicSubstitution.lift 1) right_created_vars) - (List.map (CicSubstitution.lift 1) prop) uri typeno) - | [] -> - Cic.Prod( - Cic.Name("H"), (*new name?*) - Cic.Appl([Cic.MutInd(uri, typeno, [])] @ created_vars), - Cic.Appl (( (List.map (CicSubstitution.lift 1) prop) @ - (List.map (CicSubstitution.lift 1 ) right_created_vars) @ - (if Inversion.isSetType sort then [Cic.Rel 1] else [])(*H*)) - )) -;; - -(* computes the type of the abstract P *) -let rec get_prop_arity sort rightparam_tys(*only to name m's*) created_vars_ty - local_rvars left_created_vars nleft uri typeno = - match (created_vars_ty) with - hd::tl when (nleft > 0) -> - get_prop_arity sort rightparam_tys tl local_rvars left_created_vars - (nleft-1) uri typeno - | hd::tl -> - Cic.Prod( - Cic.Name("m" ^ string_of_int(List.length rightparam_tys) ), - hd, - get_prop_arity sort (List.tl rightparam_tys) - (List.map (CicSubstitution.lift 1) tl) - (List.map (CicSubstitution.lift 1) (local_rvars @ [Cic.Rel 1])) - (List.map (CicSubstitution.lift 1) left_created_vars) nleft uri typeno - ) - | [] -> - if Inversion.isSetType sort then - Cic.Prod(Cic.Anonymous, - Cic.Appl([Cic.MutInd(uri, typeno, [])] - @ (List.map (CicSubstitution.lift (-1)) left_created_vars) - @ (List.map (CicSubstitution.lift(-1)) local_rvars) ), - Cic.Sort(Cic.Prop)) - else - Cic.Sort Cic.Prop -;; - -(* created vars is empty at the beginning *) -let rec build_theorem rightparam_tys arity_l (*arity_l only to name p's*) - arity cons_list created_vars created_vars_ty nleft - uri typeno = - match (arity) with - Cic.Prod(_,src,tgt) -> - Cic.Prod( - Cic.Name("p" ^ string_of_int(List.length arity_l)), - src, - build_theorem rightparam_tys - (List.tl arity_l) tgt cons_list - (List.map (CicSubstitution.lift 1) (created_vars @ [Cic.Rel 1])) - (List.map (CicSubstitution.lift 1) (created_vars_ty @ [src])) - nleft uri typeno) - | sort -> - Cic.Prod(Cic.Name("P"), - get_prop_arity sort rightparam_tys created_vars_ty [](*local vars*) - (takefirst nleft created_vars) (*left_created_vars*) nleft uri typeno, - build_metas sort cons_list created_vars (cut_first nleft created_vars) - [(Cic.Rel 1)] uri typeno ) -;; - -let build_one typeno inversor_uri indty_uri nleft arity cons_list selections = - (*check if there are right parameters, else return void*) - if List.length (list_of_prod arity) = (nleft + 1) then - None - else - try - let arity_l = cut_last (list_of_prod arity) in - let rightparam_tys = cut_first nleft arity_l in - let theorem = build_theorem rightparam_tys arity_l arity cons_list - [](*created_vars*) [](*created_vars_ty*) nleft indty_uri typeno in - debug_print - (lazy ("theorem prima di refine: " ^ (CicPp.ppterm theorem))); - let (ref_theorem,_,metasenv,_) = - CicRefine.type_of_aux' [] [] theorem CicUniv.oblivion_ugraph in - (*DEBUG*) debug_print - (lazy ("theorem dopo refine: " ^ (CicPp.ppterm ref_theorem))); - let goal = CicMkImplicit.new_meta metasenv [] in - let metasenv' = (goal,[],ref_theorem)::metasenv in - let attrs = [`Class (`InversionPrinciple); `Generated] in - let _subst = [] in - let proof= - Some inversor_uri,metasenv',_subst, - lazy (Cic.Meta(goal,[])),ref_theorem, attrs in - let _,applies = - List.fold_right - (fun _ (i,applies) -> - i+1,PrimitiveTactics.apply_tac (Cic.Rel i)::applies - ) cons_list (2,[]) in - let proof1,gl1 = - ProofEngineTypes.apply_tactic - (Tacticals.then_ - ~start:(PrimitiveTactics.intros_tac ()) - (*if the number of applies is 1, we cannot use - thens, but then_*) - ~continuation: - (match List.length applies with - 0 -> Inversion.private_inversion_tac (Cic.Rel 1) selections - | 1 -> - Tacticals.then_ - ~start:(Inversion.private_inversion_tac (Cic.Rel 1) selections) - ~continuation:(PrimitiveTactics.apply_tac (Cic.Rel 2)) - | _ -> - Tacticals.thens - ~start:(Inversion.private_inversion_tac (Cic.Rel 1) selections) - ~continuations:applies)) - (proof,goal) in - let _,metasenv,_subst,bo,ty, attrs = proof1 in - assert (metasenv = []); - Some - (inversor_uri, - Cic.Constant - (UriManager.name_of_uri inversor_uri,Some (Lazy.force bo),ty,[],[])) - with - Inversion.EqualityNotDefinedYet -> - HLog.warn "No default equality, no inversion principle"; - None - | CicRefine.RefineFailure ls -> - HLog.warn - ("CicRefine.RefineFailure during generation of inversion principle: " ^ - Lazy.force ls) ; - None - | CicRefine.Uncertain ls -> - HLog.warn - ("CicRefine.Uncertain during generation of inversion principle: " ^ - Lazy.force ls) ; - None - | CicRefine.AssertFailure ls -> - HLog.warn - ("CicRefine.AssertFailure during generation of inversion principle: " ^ - Lazy.force ls) ; - None -;; - -let build_inverter ~add_obj status u indty_uri params = - let indty_uri, indty_no, _ = UriManager.ind_uri_split indty_uri in - let indty_no = match indty_no with None -> raise (Invalid_argument "not an inductive type")| Some n -> n in - let indty, univ = CicEnvironment.get_cooked_obj CicUniv.empty_ugraph indty_uri - in - match indty with - | Cic.InductiveDefinition (tys,_,nleft,attrs) -> - let _,inductive,_,_ = List.hd tys in - if not inductive then raise (Invalid_argument "not an inductive type") - else - let name,_,arity,cons_list = List.nth tys (indty_no-1) in - (match build_one (indty_no-1) u indty_uri nleft arity cons_list params with - | None -> status,[] - | Some (uri, obj) -> - let status, added = add_obj uri obj status in - status, uri::added) - | _ -> assert false -;; - -let build_inversion ~add_obj ~add_coercion uri obj = - match obj with - | Cic.InductiveDefinition (tys,_,nleft,attrs) -> - let _,inductive,_,_ = List.hd tys in - if not inductive then [] - else - let counter = ref (List.length tys) in - let all_inverters = - List.fold_right - (fun (name,_,arity,cons_list) res -> - let arity_l = cut_last (list_of_prod arity) in - let rightparam_tys = cut_first nleft arity_l in - let params = HExtlib.mk_list true (List.length rightparam_tys) in - let buri = UriManager.buri_of_uri uri in - let inversor_uri = - UriManager.uri_of_string (buri ^ "/" ^ name ^ "_inv" ^ ".con") in - counter := !counter-1; - match build_one !counter inversor_uri uri nleft arity cons_list params with - None -> res - | Some inv -> inv::res - ) tys [] - in - List.fold_left - (fun lemmas (uri,obj) -> add_obj uri obj @ uri :: lemmas - ) [] all_inverters - | _ -> [] -;; - -let init () = - LibrarySync.add_object_declaration_hook build_inversion;; diff --git a/matita/components/tactics/inversion_principle.mli b/matita/components/tactics/inversion_principle.mli deleted file mode 100644 index 5ceec20a4..000000000 --- a/matita/components/tactics/inversion_principle.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id: primitiveTactics.ml 9014 2008-09-26 08:03:47Z tassi $ *) -val init: unit -> unit -val build_inverter: add_obj:(UriManager.uri -> Cic.obj -> 'b -> 'b * UriManager.uri list) -> - 'b -> UriManager.uri -> UriManager.uri -> bool list -> - 'b * UriManager.uri list diff --git a/matita/components/tactics/metadataQuery.ml b/matita/components/tactics/metadataQuery.ml deleted file mode 100644 index 6db568cb4..000000000 --- a/matita/components/tactics/metadataQuery.ml +++ /dev/null @@ -1,530 +0,0 @@ -(* Copyright (C) 2004, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -open Printf - -let nonvar uri = not (UriManager.uri_is_var uri) - -module Constr = MetadataConstraints - -exception Goal_is_not_an_equation - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) - -let ( ** ) x y = int_of_float ((float_of_int x) ** (float_of_int y)) - -let signature_of_hypothesis context metasenv = - let set, _ = - List.fold_right - (fun hyp (set,current_ctx) -> - match hyp with - | None -> set, hyp::current_ctx - | Some (_, Cic.Decl t) -> - Constr.UriManagerSet.union set (Constr.constants_of t), - hyp::current_ctx - | Some (_, Cic.Def (t, _)) -> - try - let ty,_ = - CicTypeChecker.type_of_aux' - metasenv current_ctx t CicUniv.oblivion_ugraph - in - let sort,_ = - CicTypeChecker.type_of_aux' - metasenv current_ctx ty CicUniv.oblivion_ugraph - in - let set = Constr.UriManagerSet.union set(Constr.constants_of ty)in - match sort with - | Cic.Sort Cic.Prop -> set, hyp::current_ctx - | _ -> Constr.UriManagerSet.union set (Constr.constants_of t), - hyp::current_ctx - with - | CicTypeChecker.TypeCheckerFailure _ -> set, hyp::current_ctx) - context (Constr.UriManagerSet.empty,[]) - in - set -;; - -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, _subst, _,_, _ = 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.oblivion_ugraph - in - let ty_sort2,_ = - CicTypeChecker.type_of_aux' metasenv ey2 ty2 CicUniv.oblivion_ugraph - in - let prop1 = - let b,_ = - CicReduction.are_convertible - ey1 (Cic.Sort Cic.Prop) ty_sort1 CicUniv.oblivion_ugraph - in - if b then 0 - else 1 - in - let prop2 = - let b,_ = - CicReduction.are_convertible - ey2 (Cic.Sort Cic.Prop) ty_sort2 CicUniv.oblivion_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.oblivion_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.oblivion_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 -(* prerr_endline ("adding " ^ - * (UriManager.string_of_uri curi)); *) - 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' - -(* used only by te old auto *) -let signature_of_goal ~(dbd:HSql.dbd) ((proof, goal) as _status) = - let (_, metasenv, _subst, _, _, _) = 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 metasenv 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 is_predicate u = - let ty, _ = - try CicTypeChecker.type_of_aux' [] [] - (CicUtil.term_of_uri u) CicUniv.oblivion_ugraph - with CicTypeChecker.TypeCheckerFailure _ -> assert false - in - let rec check_last_pi = function - | Cic.Prod (_,_,tgt) -> check_last_pi tgt - | Cic.Sort Cic.Prop -> true - | _ -> false - in - check_last_pi ty -;; - -let only constants uri = - prerr_endline (UriManager.string_of_uri uri); - let t = CicUtil.term_of_uri uri in (* FIXME: write ty_of_term *) - let ty,_ = CicTypeChecker.type_of_aux' [] [] t CicUniv.oblivion_ugraph in - let consts = Constr.constants_of ty in -(* - prerr_endline ("XXX " ^ UriManager.string_of_uri uri); - Constr.UriManagerSet.iter (fun u -> prerr_endline (" - " ^ - UriManager.string_of_uri u)) consts; - Constr.UriManagerSet.iter (fun u -> prerr_endline (" + " ^ - UriManager.string_of_uri u)) constants;*) - Constr.UriManagerSet.subset consts constants -;; - -let rec types_of_equality = function - | Cic.Appl [Cic.MutInd (uri, _, _); ty; _; _] - when (LibraryObjects.is_eq_URI uri) -> - let uri_set = Constr.constants_of ty in - if Constr.UriManagerSet.equal uri_set Constr.UriManagerSet.empty then - Constr.SetSet.empty - else Constr.SetSet.singleton uri_set - | Cic.Prod (_, s, t) -> - Constr.SetSet.union (types_of_equality s) (types_of_equality t) - | _ -> Constr.SetSet.empty -;; - -let types_for_equality metasenv goal = - let (_, context, ty) = CicUtil.lookup_meta goal metasenv in - let all = types_of_equality ty in - let _, all = - List.fold_left - (fun (i,acc) _ -> - let ty, _ = - CicTypeChecker.type_of_aux' - metasenv context (Cic.Rel i) CicUniv.oblivion_ugraph in - let newty = types_of_equality ty in - (i+1,Constr.SetSet.union newty acc)) - (1,all) context - in all -;; - -let signature_of metasenv goal = - let (_, context, ty) = CicUtil.lookup_meta goal metasenv in - let ty_set = Constr.constants_of ty in - let hyp_set = signature_of_hypothesis context metasenv in - let set = Constr.UriManagerSet.union ty_set hyp_set in - close_with_types - (close_with_constructors (close_with_types set metasenv context) - metasenv context) - metasenv context - - -let universe_of_goal ~(dbd:HSql.dbd) apply_only metasenv goal = - let (_, context, ty) = CicUtil.lookup_meta goal metasenv in - let ty_set = Constr.constants_of ty in - let hyp_set = signature_of_hypothesis context metasenv in - let set = Constr.UriManagerSet.union ty_set hyp_set in - let all_constants_closed = close_with_types set metasenv context in - (* we split predicates from the rest *) - let predicates, rest = - Constr.UriManagerSet.partition is_predicate all_constants_closed - in - let uris = - Constr.UriManagerSet.fold - (fun u acc -> - debug_print (lazy ("processing "^(UriManager.string_of_uri u))); - let set_for_sigmatch = - Constr.UriManagerSet.remove u all_constants_closed in - if LibraryObjects.is_eq_URI (UriManager.strip_xpointer u) then - (* equality has a special treatment *) - (debug_print (lazy "special treatment"); - let tfe = - Constr.SetSet.elements (types_for_equality metasenv goal) - in - List.fold_left - (fun acc l -> - let tyl = Constr.UriManagerSet.elements l in - debug_print (lazy ("tyl: "^(String.concat "\n" - (List.map UriManager.string_of_uri tyl)))); - let set_for_sigmatch = - Constr.UriManagerSet.diff set_for_sigmatch l in - let uris = - sigmatch ~dbd ~facts:false ~where:`Statement - (Some (u,tyl),set_for_sigmatch) in - acc @ uris) - acc tfe) - else - (debug_print (lazy "normal treatment"); - let uris = - sigmatch ~dbd ~facts:false ~where:`Statement - (Some (u,[]),set_for_sigmatch) - in - acc @ uris)) - predicates [] - 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 - if apply_only then - List.filter (only all_constants_closed) uris - else uris -;; - -let filter_out_predicate set ctx menv = - Constr.UriManagerSet.filter (fun u -> not (is_predicate u)) set -;; - -let equations_for_goal ~(dbd:HSql.dbd) ?signature ((proof, goal) as _status) = -(* - let to_string set = - "{\n" ^ - (String.concat "\n" - (Constr.UriManagerSet.fold - (fun u l -> (" "^UriManager.string_of_uri u)::l) set [])) - ^ "\n}" - in -*) - let (_, metasenv, _subst, _, _, _) = proof in - let (_, context, ty) = CicUtil.lookup_meta goal metasenv in - let main, sig_constants = - match signature with - | None -> Constr.signature_of ty - | Some s -> s - 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 l = - let eq_URI = - match LibraryObjects.eq_URI () with - None -> None - | Some s -> - Some - (UriManager.uri_of_string - (UriManager.string_of_uri s ^ "#xpointer(1/1)")) - in - match eq_URI,main with - | Some eq_URI, Some (m, l) when UriManager.eq m eq_URI -> m::l - | _ -> [] - in - (*Printf.printf "\nSome (m, l): %s, [%s]\n\n" - (UriManager.string_of_uri (List.hd l)) - (String.concat "; " (List.map UriManager.string_of_uri (List.tl l))); - *) - (* if m == UriManager.uri_of_string HelmLibraryObjects.Logic.eq_XURI then ( *) - let set = signature_of_hypothesis context metasenv in - (* Printf.printf "\nsignature_of_hypothesis: %s\n\n" (to_string set); *) - let set = Constr.UriManagerSet.union set sig_constants in - let set = filter_out_predicate set context metasenv 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_for_sigmatch = List.fold_right Constr.UriManagerSet.remove l set in - let uris = - sigmatch ~dbd ~facts:false ~where:`Statement (main,set_for_sigmatch) in - let uris = List.filter nonvar (List.map snd uris) in - let uris = List.filter Hashtbl_equiv.not_a_duplicate uris in - let set = List.fold_right Constr.UriManagerSet.add l set in - let uris = List.filter (only set) uris in - uris - (* ) *) - (* else raise Goal_is_not_an_equation *) - -let experimental_hint - ~(dbd:HSql.dbd) ?(facts=false) ?signature ((proof, goal) as status) = - let (_, metasenv, _subst, _, _, _) = 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 metasenv) - 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.oblivion_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:HSql.dbd) ?(facts=false) ?signature ~universe - ((proof, goal) as status) -= - let (_, metasenv, _subst, _, _, _) = proof in - let (_, context, ty) = CicUtil.lookup_meta goal metasenv in - let (uris, (main, sig_constants)) = - match signature with - | Some signature -> - (sigmatch ~dbd ~facts signature, signature) - | None -> - (cmatch' ~dbd ~facts ty, Constr.signature_of ty) in - let universe = - List.fold_left - (fun res u -> Constr.UriManagerSet.add u res) - Constr.UriManagerSet.empty universe in - let uris = - List.fold_left - (fun res (_,u) -> Constr.UriManagerSet.add u res) - Constr.UriManagerSet.empty uris in - let uris = Constr.UriManagerSet.inter uris universe in - let uris = Constr.UriManagerSet.elements uris in - let rec aux = function - | [] -> [] - | uri :: tl -> - (let status' = - try - let (subst,(proof, goal_list)) = - (* debug_print (lazy ("STO APPLICANDO" ^ uri)); *) - apply_tac_verbose - ~term:(CicUtil.term_of_uri uri) - status - in - let goal_list = - List.stable_sort (compare_goal_list proof) goal_list - in - Some (uri, (subst,(proof, goal_list))) - with ProofEngineTypes.Fail _ -> None - in - match status' with - | None -> aux tl - | Some status' -> status' :: aux tl) - in - List.stable_sort - (fun (_,(_, (_, goals1))) (_,(_, (_, goals2))) -> - Pervasives.compare (List.length goals1) (List.length goals2)) - (aux uris) - diff --git a/matita/components/tactics/metadataQuery.mli b/matita/components/tactics/metadataQuery.mli deleted file mode 100644 index f8559c886..000000000 --- a/matita/components/tactics/metadataQuery.mli +++ /dev/null @@ -1,82 +0,0 @@ -(* Copyright (C) 2004, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - - (** @param vars if set variables (".var" URIs) are considered. Defaults to - * false - * @param pat shell like pattern matching over object names, a string where "*" - * is interpreted as 0 or more characters and "?" as exactly one character *) - -(* used only by the old auto *) -val signature_of_goal: - dbd:HSql.dbd -> ProofEngineTypes.status -> - UriManager.uri list - -val signature_of: - Cic.metasenv -> - ProofEngineTypes.goal -> - MetadataConstraints.UriManagerSet.t - -val signature_of_hypothesis: - Cic.hypothesis list -> - Cic.metasenv -> - MetadataConstraints.UriManagerSet.t - -val close_with_types: - MetadataConstraints.UriManagerSet.t -> - Cic.metasenv -> - Cic.context -> - MetadataConstraints.UriManagerSet.t - -val universe_of_goal: - dbd:HSql.dbd -> - bool -> (* apply only or not *) - Cic.metasenv -> - ProofEngineTypes.goal -> - UriManager.uri list - -val equations_for_goal: - dbd:HSql.dbd -> - ?signature:MetadataConstraints.term_signature -> - ProofEngineTypes.status -> UriManager.uri list - -val experimental_hint: - dbd:HSql.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:HSql.dbd -> - ?facts:bool -> - ?signature:MetadataConstraints.term_signature -> - universe:UriManager.uri list -> - ProofEngineTypes.status -> - (UriManager.uri * - ((Cic.term -> Cic.term) * - (ProofEngineTypes.proof * ProofEngineTypes.goal list))) list - diff --git a/matita/components/tactics/negationTactics.ml b/matita/components/tactics/negationTactics.ml deleted file mode 100644 index 287ec4dfe..000000000 --- a/matita/components/tactics/negationTactics.ml +++ /dev/null @@ -1,97 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -let absurd_tac ~term = - let absurd_tac ~term status = - let (proof, goal) = status in - let module C = Cic in - let module U = UriManager in - let module P = PrimitiveTactics in - let _,metasenv,_subst,_,_, _ = proof in - let _,context,ty = CicUtil.lookup_meta goal metasenv in - let absurd_URI = - match LibraryObjects.absurd_URI () with - Some uri -> uri - | None -> raise (ProofEngineTypes.Fail (lazy "You need to register the default \"absurd\" theorem first. Please use the \"default\" command")) - in - let ty_term,_ = - CicTypeChecker.type_of_aux' metasenv context term CicUniv.oblivion_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 (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 - let false_URI = - match LibraryObjects.false_URI () with - Some uri -> uri - | None -> raise (ProofEngineTypes.Fail (lazy "You need to register the default \"false\" definition first. Please use the \"default\" command")) - in - try - ProofEngineTypes.apply_tactic ( - T.then_ - ~start:(P.intros_tac ()) - ~continuation:( - T.then_ - ~start: - (EliminationTactics.elim_type_tac (C.MutInd (false_URI, 0, []))) - ~continuation: VariousTactics.assumption_tac)) - status - with - ProofEngineTypes.Fail msg when Lazy.force msg = "Assumption: No such assumption" -> raise (ProofEngineTypes.Fail (lazy "Contradiction: No such assumption")) - (* sarebbe piu' elegante se Assumtion sollevasse un'eccezione tutta sua che questa cattura, magari con l'aiuto di try_tactics *) - in - ProofEngineTypes.mk_tactic contradiction_tac -;; - -(* Questa era in fourierR.ml -(* !!!!! fix !!!!!!!!!! *) -let contradiction_tac (proof,goal)= - Tacticals.then_ - ~start:(PrimitiveTactics.intros_tac ~name:"bo?" ) (*inutile sia questo che quello prima della chiamata*) - ~continuation:(Tacticals.then_ - ~start:(VariousTactics.elim_type_tac ~term:_False) - ~continuation:(assumption_tac)) - (proof,goal) -;; -*) - - diff --git a/matita/components/tactics/negationTactics.mli b/matita/components/tactics/negationTactics.mli deleted file mode 100644 index bfa3e8d5d..000000000 --- a/matita/components/tactics/negationTactics.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val absurd_tac: term:Cic.term -> ProofEngineTypes.tactic -val contradiction_tac: ProofEngineTypes.tactic - diff --git a/matita/components/tactics/paramodulation/.depend b/matita/components/tactics/paramodulation/.depend deleted file mode 100644 index e69de29bb..000000000 diff --git a/matita/components/tactics/paramodulation/Makefile b/matita/components/tactics/paramodulation/Makefile deleted file mode 100644 index 2f3afa5ab..000000000 --- a/matita/components/tactics/paramodulation/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -all: - @make -C .. $@ - -%: - @make -C .. $@ - diff --git a/matita/components/tactics/paramodulation/README b/matita/components/tactics/paramodulation/README deleted file mode 100644 index bf484ae16..000000000 --- a/matita/components/tactics/paramodulation/README +++ /dev/null @@ -1,45 +0,0 @@ -make saturate per compilare l'eseguibile da riga di comando (make saturate.opt per la versione ottimizzata) - -./saturate -h per vedere una lista di parametri: - -./saturate: unknown option `-h'. -Usage: - -full Enable full mode - -f Enable/disable full-reduction strategy (default: enabled) - -r Weight-Age equality selection ratio (default: 4) - -s symbols-based selection ratio (relative to the weight ratio, default: 0) - -c Configuration file (for the db connection) - -o Term ordering. Possible values are: - kbo: Knuth-Bendix ordering - nr-kbo: Non-recursive variant of kbo (default) - lpo: Lexicographic path ordering - -l Time limit in seconds (default: no limit) - -w Maximal width (default: 3) - -d Maximal depth (default: 3) - -retrieve retrieve only - -help Display this list of options - --help Display this list of options - - -./saturate -l 10 -demod-equalities - -dove -l 10 e` il timeout in secondi. - -Il programma legge da standard input il teorema, per esempio - -\forall n:nat.n + n = 2 * n -\forall n:R.n + n = 2 * n -\forall n:R.n+n=n+n - -l'input termina con una riga vuota (quindi basta un doppio invio alla fine) - -In output, oltre ai vari messaggi di debug, vengono stampati gli insiemi -active e passive alla fine dell'esecuzione. Consiglio di redirigere l'output -su file, per esempio usando tee: - -./saturate -l 10 -demod-equalities | tee output.txt - -Il formato di stampa e` quello per gli oggetti di tipo equality (usa la -funzione Inference.string_of_equality) - - diff --git a/matita/components/tactics/paramodulation/equality.ml b/matita/components/tactics/paramodulation/equality.ml deleted file mode 100644 index 2bf3600f2..000000000 --- a/matita/components/tactics/paramodulation/equality.ml +++ /dev/null @@ -1,1379 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* let _profiler = <:profiler<_profiler>>;; *) - -(* $Id: inference.ml 6245 2006-04-05 12:07:51Z tassi $ *) - -type rule = SuperpositionRight | SuperpositionLeft | Demodulation -type uncomparable = int -> int - -type equality = - uncomparable * (* trick to break structural equality *) - int * (* weight *) - proof * - (Cic.term * (* type *) - Cic.term * (* left side *) - Cic.term * (* right side *) - Utils.comparison) * (* ordering *) - Cic.metasenv * (* environment for metas *) - int (* id *) -and proof = - | Exact of Cic.term - | Step of Subst.substitution * (rule * int*(Utils.pos*int)* Cic.term) - (* subst, (rule,eq1, eq2,predicate) *) -and goal_proof = (rule * Utils.pos * int * Subst.substitution * Cic.term) list -;; -(* the hashtbl eq_id -> proof, max_eq_id *) -module IntOt = struct type t = int let compare = Pervasives.compare end -module M = Map.Make(IntOt) -type equality_bag = equality M.t * int - -type goal = goal_proof * Cic.metasenv * Cic.term - -(* globals *) -let mk_equality_bag () = M.empty, 10000 ;; - -let freshid (m,i) = (m,i+1), i+1 ;; - -let add_to_bag (id_to_eq,i) id eq = M.add id eq id_to_eq,i ;; - -let uncomparable = fun _ -> 0 - -let mk_equality bag (weight,p,(ty,l,r,o),m) = - let bag, id = freshid bag in - let eq = (uncomparable,weight,p,(ty,l,r,o),m,id) in - let bag = add_to_bag bag id eq in - bag, eq -;; - -let mk_tmp_equality (weight,(ty,l,r,o),m) = - let id = -1 in - uncomparable,weight,Exact (Cic.Implicit None),(ty,l,r,o),m,id -;; - - -let open_equality (_,weight,proof,(ty,l,r,o),m,id) = - (weight,proof,(ty,l,r,o),m,id) - -let id_of e = - let _,_,_,_,id = open_equality e in id -;; - - -let string_of_rule = function - | SuperpositionRight -> "SupR" - | SuperpositionLeft -> "SupL" - | Demodulation -> "Demod" -;; - -let string_of_equality ?env eq = - match env with - | None -> - let w, _, (ty, left, right, o), m , id = open_equality eq in - Printf.sprintf "Id: %d, Weight: %d, {%s}: %s =(%s) %s [%s]" - id w (CicPp.ppterm ty) - (CicPp.ppterm left) - (Utils.string_of_comparison o) (CicPp.ppterm right) - (String.concat ", " (List.map (fun (i,_,_) -> string_of_int i) m)) -(* "..." *) - | Some (_, context, _) -> - let names = Utils.names_of_context context in - let w, _, (ty, left, right, o), m , id = open_equality eq in - Printf.sprintf "Id: %d, Weight: %d, {%s}: %s =(%s) %s [%s]" - id w (CicPp.pp ty names) - (CicPp.pp left names) (Utils.string_of_comparison o) - (CicPp.pp right names) - (String.concat ", " (List.map (fun (i,_,_) -> string_of_int i) m)) -(* "..." *) -;; - -let compare (_,_,_,s1,_,_) (_,_,_,s2,_,_) = - Pervasives.compare s1 s2 -;; - -let rec max_weight_in_proof ((id_to_eq,_) as bag) current = - function - | Exact _ -> current - | Step (_, (_,id1,(_,id2),_)) -> - let eq1 = M.find id1 id_to_eq in - let eq2 = M.find id2 id_to_eq in - let (w1,p1,(_,_,_,_),_,_) = open_equality eq1 in - let (w2,p2,(_,_,_,_),_,_) = open_equality eq2 in - let current = max current w1 in - let current = max_weight_in_proof bag current p1 in - let current = max current w2 in - max_weight_in_proof bag current p2 - -let max_weight_in_goal_proof ((id_to_eq,_) as bag) = - List.fold_left - (fun current (_,_,id,_,_) -> - let eq = M.find id id_to_eq in - let (w,p,(_,_,_,_),_,_) = open_equality eq in - let current = max current w in - max_weight_in_proof bag current p) - -let max_weight bag goal_proof proof = - let current = max_weight_in_proof bag 0 proof in - max_weight_in_goal_proof bag current goal_proof - -let proof_of_id (id_to_eq,_) id = - try - let (_,p,(_,l,r,_),_,_) = open_equality (M.find id id_to_eq) in - p,l,r - with - Not_found -> - prerr_endline ("Unable to find the proof of " ^ string_of_int id); - assert false -;; - -let is_in (id_to_eq,_) id = - M.mem id id_to_eq -;; - - -let string_of_proof ?(names=[]) bag p gp = - let str_of_pos = function - | Utils.Left -> "left" - | Utils.Right -> "right" - in - let fst3 (x,_,_) = x in - let rec aux margin name = - let prefix = String.make margin ' ' ^ name ^ ": " in function - | Exact t -> - Printf.sprintf "%sExact (%s)\n" - prefix (CicPp.pp t names) - | Step (subst,(rule,eq1,(pos,eq2),pred)) -> - Printf.sprintf "%s%s(%s|%d with %d dir %s pred %s))\n" - prefix (string_of_rule rule) (Subst.ppsubst ~names subst) eq1 eq2 (str_of_pos pos) - (CicPp.pp pred names)^ - aux (margin+1) (Printf.sprintf "%d" eq1) (fst3 (proof_of_id bag eq1)) ^ - aux (margin+1) (Printf.sprintf "%d" eq2) (fst3 (proof_of_id bag eq2)) - in - aux 0 "" p ^ - String.concat "\n" - (List.map - (fun (r,pos,i,s,t) -> - (Printf.sprintf - "GOAL: %s %s %d %s %s\n" (string_of_rule r) - (str_of_pos pos) i (Subst.ppsubst ~names s) (CicPp.pp t names)) ^ - aux 1 (Printf.sprintf "%d " i) (fst3 (proof_of_id bag i))) - gp) -;; - -let rec depend ((id_to_eq,_) as bag) eq id seen = - let (_,p,(_,_,_,_),_,ideq) = open_equality eq in - if List.mem ideq seen then - false,seen - else - if id = ideq then - true,seen - else - match p with - | Exact _ -> false,seen - | Step (_,(_,id1,(_,id2),_)) -> - let seen = ideq::seen in - let eq1 = M.find id1 id_to_eq in - let eq2 = M.find id2 id_to_eq in - let b1,seen = depend bag eq1 id seen in - if b1 then b1,seen else depend bag eq2 id seen -;; - -let depend bag eq id = fst (depend bag eq id []);; - -let ppsubst = Subst.ppsubst ~names:[];; - -(* returns an explicit named subst and a list of arguments for sym_eq_URI *) -let build_ens uri termlist = - let obj, _ = CicEnvironment.get_obj CicUniv.empty_ugraph 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 mk_sym uri ty t1 t2 p = - let ens, args = build_ens uri [ty;t1;t2;p] in - Cic.Appl (Cic.Const(uri, ens) :: args) -;; - -let mk_trans uri ty t1 t2 t3 p12 p23 = - let ens, args = build_ens uri [ty;t1;t2;t3;p12;p23] in - Cic.Appl (Cic.Const (uri, ens) :: args) -;; - -let mk_eq_ind uri ty what pred p1 other p2 = - let ens, args = build_ens uri [ty; what; pred; p1; other; p2] in - Cic.Appl (Cic.Const (uri, ens) :: args) -;; - -let p_of_sym ens tl = - let args = List.map snd ens @ tl in - match args with - | [_;_;_;p] -> p - | _ -> assert false -;; - -let open_trans ens tl = - let args = List.map snd ens @ tl in - match args with - | [ty;l;m;r;p1;p2] -> ty,l,m,r,p1,p2 - | _ -> assert false -;; - -let open_sym ens tl = - let args = List.map snd ens @ tl in - match args with - | [ty;l;r;p] -> ty,l,r,p - | _ -> assert false -;; - -let open_eq_ind args = - match args with - | [ty;l;pred;pl;r;pleqr] -> ty,l,pred,pl,r,pleqr - | _ -> assert false -;; - -let open_pred pred = - match pred with - | Cic.Lambda (_,_,(Cic.Appl [Cic.MutInd (uri, 0,_);ty;l;r])) - when LibraryObjects.is_eq_URI uri -> ty,uri,l,r - | _ -> Utils.debug_print (lazy (CicPp.ppterm pred)); assert false -;; - -let is_not_fixed t = - CicSubstitution.subst (Cic.Implicit None) t <> - CicSubstitution.subst (Cic.Rel 1) t -;; - -let canonical t context menv = - let remove_cycles t = - let is_transitive = - function - Cic.Appl (Cic.Const (uri_trans,_)::_) - when LibraryObjects.is_trans_eq_URI uri_trans -> - true - | _ -> false in - let rec collect = - function - Cic.Appl (Cic.Const (uri_trans,ens)::tl) - when LibraryObjects.is_trans_eq_URI uri_trans -> - let ty,l,m,r,p1,p2 = open_trans ens tl in - (if is_transitive p1 then fst (collect p1) else [l,p1]) @ - (if is_transitive p2 then fst (collect p2) else [m,p2]), - (r, uri_trans, ty) - | t -> assert false in - let rec cut_to_last_duplicate l acc = - function - [] -> List.rev acc - | (l',p)::tl when l=l' -> -if acc <> [] then -Utils.debug_print (lazy ("!!! RISPARMIO " ^ string_of_int (List.length acc) ^ " PASSI")); - cut_to_last_duplicate l [l',p] tl - | (l',p)::tl -> - cut_to_last_duplicate l ((l',p)::acc) tl - in - let rec rebuild = - function - (l,_)::_::_ as steps, ((r,uri_trans,ty) as last) -> - (match cut_to_last_duplicate l [] steps with - (l,p1)::((m,_)::_::_ as tl) -> - mk_trans uri_trans ty l m r p1 (rebuild (tl,last)) - | [l,p1 ; m,p2] -> mk_trans uri_trans ty l m r p1 p2 - | [l,p1] -> p1 - | [] -> assert false) - | _ -> assert false - in - if is_transitive t then - rebuild (collect t) - else - t - in - let rec remove_refl t = - match t with - | Cic.Appl (((Cic.Const(uri_trans,ens))::tl) as args) - when LibraryObjects.is_trans_eq_URI uri_trans -> - let ty,l,m,r,p1,p2 = open_trans ens tl in - (match p1,p2 with - | Cic.Appl [Cic.MutConstruct (uri, 0, 1,_);_;_],p2 -> - remove_refl p2 - | p1,Cic.Appl [Cic.MutConstruct (uri, 0, 1,_);_;_] -> - remove_refl p1 - | _ -> Cic.Appl (List.map remove_refl args)) - | Cic.Appl l -> Cic.Appl (List.map remove_refl l) - | Cic.LetIn (name,bo,ty,rest) -> - Cic.LetIn (name,remove_refl bo,remove_refl ty,remove_refl rest) - | _ -> t - in - let rec canonical_trough_lambda context = function - | Cic.Lambda(name,ty,bo) -> - let context' = (Some (name,Cic.Decl ty))::context in - Cic.Lambda(name,ty,canonical_trough_lambda context' bo) - | t -> canonical context t - - and canonical context t = - match t with - | Cic.LetIn(name,bo,ty,rest) -> - let bo = canonical_trough_lambda context bo in - let ty = canonical_trough_lambda context ty in - let context' = (Some (name,Cic.Def (bo,ty)))::context in - Cic.LetIn(name,bo,ty,canonical context' rest) - | Cic.Appl (((Cic.Const(uri_sym,ens))::tl) as args) - when LibraryObjects.is_sym_eq_URI uri_sym -> - (match p_of_sym ens tl with - | Cic.Appl ((Cic.Const(uri,ens))::tl) - when LibraryObjects.is_sym_eq_URI uri -> - canonical context (p_of_sym ens tl) - | Cic.Appl ((Cic.Const(uri_trans,ens))::tl) - when LibraryObjects.is_trans_eq_URI uri_trans -> - let ty,l,m,r,p1,p2 = open_trans ens tl in - mk_trans uri_trans ty r m l - (canonical context (mk_sym uri_sym ty m r p2)) - (canonical context (mk_sym uri_sym ty l m p1)) - | Cic.Appl (([Cic.Const(uri_feq,ens);ty1;ty2;f;x;y;p])) - when LibraryObjects.is_eq_f_URI uri_feq -> - let eq = LibraryObjects.eq_URI_of_eq_f_URI uri_feq in - let eq_f_sym = - Cic.Const (LibraryObjects.eq_f_sym_URI ~eq, []) - in - let rc = Cic.Appl [eq_f_sym;ty1;ty2;f;x;y;p] in - Utils.debug_print (lazy ("CANONICAL " ^ CicPp.ppterm rc)); - rc - | Cic.Appl [Cic.MutConstruct (uri, 0, 1,_);_;_] as t - when LibraryObjects.is_eq_URI uri -> t - | _ -> Cic.Appl (List.map (canonical context) args)) - | Cic.Appl l -> Cic.Appl (List.map (canonical context) l) - | _ -> t - in - remove_cycles (remove_refl (canonical context t)) -;; - -let compose_contexts ctx1 ctx2 = - ProofEngineReduction.replace_lifting - ~equality:(fun _ ->(=)) ~context:[] ~what:[Cic.Implicit(Some `Hole)] ~with_what:[ctx2] ~where:ctx1 -;; - -let put_in_ctx ctx t = - ProofEngineReduction.replace_lifting - ~equality:(fun _ -> (=)) ~context:[] ~what:[Cic.Implicit (Some `Hole)] ~with_what:[t] ~where:ctx -;; - -let mk_eq uri ty l r = - let ens, args = build_ens uri [ty; l; r] in - Cic.Appl (Cic.MutInd(uri,0,ens) :: args) -;; - -let mk_refl uri ty t = - let ens, args = build_ens uri [ty; t] in - Cic.Appl (Cic.MutConstruct(uri,0,1,ens) :: args) -;; - -let open_eq = function - | Cic.Appl [Cic.MutInd(uri,0,[]);ty;l;r] when LibraryObjects.is_eq_URI uri -> - uri, ty, l ,r - | _ -> assert false -;; - -let mk_feq uri_feq ty ty1 left pred right t = - let ens, args = build_ens uri_feq [ty;ty1;pred;left;right;t] in - Cic.Appl (Cic.Const(uri_feq,ens) :: args) -;; - -let rec look_ahead aux = function - | Cic.Appl ((Cic.Const(uri_ind,ens))::tl) as t - when LibraryObjects.is_eq_ind_URI uri_ind || - LibraryObjects.is_eq_ind_r_URI uri_ind -> - let ty1,what,pred,p1,other,p2 = open_eq_ind tl in - let ty2,eq,lp,rp = open_pred pred in - let hole = Cic.Implicit (Some `Hole) in - let ty2 = CicSubstitution.subst hole ty2 in - aux ty1 (CicSubstitution.subst other lp) (CicSubstitution.subst other rp) hole ty2 t - | Cic.Lambda (n,s,t) -> Cic.Lambda (n,s,look_ahead aux t) - | t -> t -;; - -let contextualize uri ty left right t = - let hole = Cic.Implicit (Some `Hole) in - (* aux [uri] [ty] [left] [right] [ctx] [ctx_ty] [t] - * - * the parameters validate this invariant - * t: eq(uri) ty left right - * that is used only by the base case - * - * ctx is a term with an hole. Cic.Implicit(Some `Hole) is the empty context - * ctx_ty is the type of ctx - *) - let rec aux uri ty left right ctx_d ctx_ty t = - match t with - | Cic.Appl ((Cic.Const(uri_sym,ens))::tl) - when LibraryObjects.is_sym_eq_URI uri_sym -> - let ty,l,r,p = open_sym ens tl in - mk_sym uri_sym ty l r (aux uri ty l r ctx_d ctx_ty p) - | Cic.LetIn (name,body,bodyty,rest) -> - Cic.LetIn - (name,look_ahead (aux uri) body, bodyty, - aux uri ty left right ctx_d ctx_ty rest) - | Cic.Appl ((Cic.Const(uri_ind,ens))::tl) - when LibraryObjects.is_eq_ind_URI uri_ind || - LibraryObjects.is_eq_ind_r_URI uri_ind -> - let ty1,what,pred,p1,other,p2 = open_eq_ind tl in - let ty2,eq,lp,rp = open_pred pred in - let uri_trans = LibraryObjects.trans_eq_URI ~eq:uri in - let uri_sym = LibraryObjects.sym_eq_URI ~eq:uri in - let is_not_fixed_lp = is_not_fixed lp in - let avoid_eq_ind = LibraryObjects.is_eq_ind_URI uri_ind in - (* extract the context and the fixed term from the predicate *) - let m, ctx_c, ty2 = - let m, ctx_c = if is_not_fixed_lp then rp,lp else lp,rp in - (* they were under a lambda *) - let m = CicSubstitution.subst hole m in - let ctx_c = CicSubstitution.subst hole ctx_c in - let ty2 = CicSubstitution.subst hole ty2 in - m, ctx_c, ty2 - in - (* create the compound context and put the terms under it *) - let ctx_dc = compose_contexts ctx_d ctx_c in - let dc_what = put_in_ctx ctx_dc what in - let dc_other = put_in_ctx ctx_dc other in - (* m is already in ctx_c so it is put in ctx_d only *) - let d_m = put_in_ctx ctx_d m in - (* we also need what in ctx_c *) - let c_what = put_in_ctx ctx_c what in - (* now put the proofs in the compound context *) - let p1 = (* p1: dc_what = d_m *) - if is_not_fixed_lp then - aux uri ty2 c_what m ctx_d ctx_ty p1 - else - mk_sym uri_sym ctx_ty d_m dc_what - (aux uri ty2 m c_what ctx_d ctx_ty p1) - in - let p2 = (* p2: dc_other = dc_what *) - if avoid_eq_ind then - mk_sym uri_sym ctx_ty dc_what dc_other - (aux uri ty1 what other ctx_dc ctx_ty p2) - else - aux uri ty1 other what ctx_dc ctx_ty p2 - in - (* if pred = \x.C[x]=m --> t : C[other]=m --> trans other what m - if pred = \x.m=C[x] --> t : m=C[other] --> trans m what other *) - let a,b,c,paeqb,pbeqc = - if is_not_fixed_lp then - dc_other,dc_what,d_m,p2,p1 - else - d_m,dc_what,dc_other, - (mk_sym uri_sym ctx_ty dc_what d_m p1), - (mk_sym uri_sym ctx_ty dc_other dc_what p2) - in - mk_trans uri_trans ctx_ty a b c paeqb pbeqc - | t when ctx_d = hole -> t - | t -> -(* let uri_sym = LibraryObjects.sym_eq_URI ~eq:uri in *) -(* let uri_ind = LibraryObjects.eq_ind_URI ~eq:uri in *) - - let uri_feq = LibraryObjects.eq_f_URI ~eq:uri in - let pred = -(* let r = CicSubstitution.lift 1 (put_in_ctx ctx_d left) in *) - let l = - let ctx_d = CicSubstitution.lift 1 ctx_d in - put_in_ctx ctx_d (Cic.Rel 1) - in -(* let lty = CicSubstitution.lift 1 ctx_ty in *) -(* Cic.Lambda (Cic.Name "foo",ty,(mk_eq uri lty l r)) *) - Cic.Lambda (Cic.Name "foo",ty,l) - in -(* let d_left = put_in_ctx ctx_d left in *) -(* let d_right = put_in_ctx ctx_d right in *) -(* let refl_eq = mk_refl uri ctx_ty d_left in *) -(* mk_sym uri_sym ctx_ty d_right d_left *) -(* (mk_eq_ind uri_ind ty left pred refl_eq right t) *) - (mk_feq uri_feq ty ctx_ty left pred right t) - in - aux uri ty left right hole ty t -;; - -let contextualize_rewrites t ty = - let eq,ty,l,r = open_eq ty in - contextualize eq ty l r t -;; - -let add_subst subst = - function - | Exact t -> Exact (Subst.apply_subst subst t) - | Step (s,(rule, id1, (pos,id2), pred)) -> - Step (Subst.concat subst s,(rule, id1, (pos,id2), pred)) -;; - -let build_proof_step eq lift subst p1 p2 pos l r pred = - let p1 = Subst.apply_subst_lift lift subst p1 in - let p2 = Subst.apply_subst_lift lift subst p2 in - let l = CicSubstitution.lift lift l in - let l = Subst.apply_subst_lift lift subst l in - let r = CicSubstitution.lift lift r in - let r = Subst.apply_subst_lift lift subst r in - let pred = CicSubstitution.lift lift pred in - let pred = Subst.apply_subst_lift lift subst pred in - let ty,body = - match pred with - | Cic.Lambda (_,ty,body) -> ty,body - | _ -> assert false - in - let what, other = - if pos = Utils.Left then l,r else r,l - in - let p = - match pos with - | Utils.Left -> - mk_eq_ind (LibraryObjects.eq_ind_URI ~eq) ty what pred p1 other p2 - | Utils.Right -> - mk_eq_ind (LibraryObjects.eq_ind_r_URI ~eq) ty what pred p1 other p2 - in - p -;; - -let parametrize_proof p l r = - let uniq l = HExtlib.list_uniq (List.sort (fun (i,_) (j,_) -> Pervasives.compare i j) l) in - let mot = CicUtil.metas_of_term_set in - let parameters = uniq (mot p @ mot l @ mot r) in - (* ?if they are under a lambda? *) -(* - let parameters = - HExtlib.list_uniq (List.sort Pervasives.compare parameters) - in -*) - (* resorts l such that *hopefully* dependencies can be inferred *) - let guess_dependency p l = - match p with - | Cic.Appl ((Cic.Const(uri_ind,ens))::tl) - when LibraryObjects.is_eq_ind_URI uri_ind || - LibraryObjects.is_eq_ind_r_URI uri_ind -> - let ty,_,_,_,_,_ = open_eq_ind tl in - let metas = CicUtil.metas_of_term ty in - let nondep, dep = - List.partition (fun (i,_) -> List.exists (fun (j,_) -> j=i) metas) l - in - nondep@dep - | _ -> l - in - let parameters = guess_dependency p parameters in - let what = List.map (fun (i,l) -> Cic.Meta (i,l)) parameters in - let with_what, lift_no = - List.fold_right (fun _ (acc,n) -> ((Cic.Rel n)::acc),n+1) what ([],1) - in - let p = CicSubstitution.lift (lift_no-1) p in - let p = - ProofEngineReduction.replace_lifting - ~equality:(fun _ t1 t2 -> - match t1,t2 with Cic.Meta (i,_),Cic.Meta(j,_) -> i=j | _ -> false) - ~context:[] - ~what ~with_what ~where:p - in - let ty_of_m _ = Cic.Implicit (Some `Type) in - let args, proof,_ = - List.fold_left - (fun (instance,p,n) m -> - (instance@[m], - Cic.Lambda - (Cic.Name ("X"^string_of_int n), - CicSubstitution.lift (lift_no - n - 1) (ty_of_m m), - p), - n+1)) - ([Cic.Rel 1],p,1) - what - in - let instance = match args with | [x] -> x | _ -> Cic.Appl args in - proof, instance -;; - -let wfo bag goalproof proof id = - let rec aux acc id = - let p,_,_ = proof_of_id bag id in - match p with - | Exact _ -> if (List.mem id acc) then acc else id :: acc - | Step (_,(_,id1, (_,id2), _)) -> - let acc = if not (List.mem id1 acc) then aux acc id1 else acc in - let acc = if not (List.mem id2 acc) then aux acc id2 else acc in - id :: acc - in - let acc = - match proof with - | Exact _ -> [id] - | Step (_,(_,id1, (_,id2), _)) -> aux (aux [id] id1) id2 - in - List.fold_left (fun acc (_,_,id,_,_) -> aux acc id) acc goalproof -;; - -let string_of_id (id_to_eq,_) names id = - if id = 0 then "" else - try - let (_,p,(t,l,r,_),m,_) = open_equality (M.find id id_to_eq) in - match p with - | Exact t -> - Printf.sprintf "%d = %s: %s = %s [%s]" id - (CicPp.pp t names) (CicPp.pp l names) (CicPp.pp r names) -(* "..." *) - (String.concat ", " (List.map (fun (i,_,_) -> string_of_int i) m)) - | Step (_,(step,id1, (dir,id2), p) ) -> - Printf.sprintf "%6d: %s %6d %6d %s =(%s) %s [%s]" id - (string_of_rule step) - id1 id2 (CicPp.pp l names) (CicPp.pp t names) (CicPp.pp r names) - (String.concat ", " (List.map (fun (i,_,_) -> string_of_int i) m)) - (*"..."*) - with - Not_found -> assert false - -let pp_proof bag names goalproof proof subst id initial_goal = - String.concat "\n" (List.map (string_of_id bag names) (wfo bag goalproof proof id)) ^ - "\ngoal:\n " ^ - (String.concat "\n " - (fst (List.fold_right - (fun (r,pos,i,s,pred) (acc,g) -> - let _,_,left,right = open_eq g in - let ty = - match pos with - | Utils.Left -> CicReduction.head_beta_reduce (Cic.Appl[pred;right]) - | Utils.Right -> CicReduction.head_beta_reduce (Cic.Appl[pred;left]) - in - let ty = Subst.apply_subst s ty in - ("("^ string_of_rule r ^ " " ^ string_of_int i^") -> " - ^ CicPp.pp ty names) :: acc,ty) goalproof ([],initial_goal)))) ^ - "\nand then subsumed by " ^ string_of_int id ^ " when " ^ Subst.ppsubst subst -;; - -let rec find_deps bag m i = - if M.mem i m then m - else - let p,_,_ = proof_of_id bag i in - match p with - | Exact _ -> M.add i [] m - | Step (_,(_,id1,(_,id2),_)) -> - let m = find_deps bag m id1 in - let m = find_deps bag m id2 in - (* without the uniq there is a stack overflow doing concatenation *) - let xxx = [id1;id2] @ M.find id1 m @ M.find id2 m in - let xxx = HExtlib.list_uniq (List.sort Pervasives.compare xxx) in - M.add i xxx m -;; - -let topological_sort bag l = - (* build the partial order relation *) - let m = List.fold_left (fun m i -> find_deps bag m i) M.empty l in - let m = (* keep only deps inside l *) - List.fold_left - (fun m' i -> - M.add i (List.filter (fun x -> List.mem x l) (M.find i m)) m') - M.empty l - in - let m = M.map (fun x -> Some x) m in - (* utils *) - let keys m = M.fold (fun i _ acc -> i::acc) m [] in - let split l m = List.filter (fun i -> M.find i m = Some []) l in - let purge l m = - M.mapi - (fun k v -> if List.mem k l then None else - match v with - | None -> None - | Some ll -> Some (List.filter (fun i -> not (List.mem i l)) ll)) - m - in - let rec aux m res = - let keys = keys m in - let ok = split keys m in - let m = purge ok m in - let res = ok @ res in - if ok = [] then res else aux m res - in - let rc = List.rev (aux m []) in - rc -;; - -(* returns the list of ids that should be factorized *) -let get_duplicate_step_in_wfo bag l p = - let ol = List.rev l in - let h = Hashtbl.create 13 in - (* NOTE: here the n parameter is an approximation of the dependency - between equations. To do things seriously we should maintain a - dependency graph. This approximation is not perfect. *) - let add i = - let p,_,_ = proof_of_id bag i in - match p with - | Exact _ -> true - | _ -> - try - let no = Hashtbl.find h i in - Hashtbl.replace h i (no+1); - false - with Not_found -> Hashtbl.add h i 1;true - in - let rec aux = function - | Exact _ -> () - | Step (_,(_,i1,(_,i2),_)) -> - let go_on_1 = add i1 in - let go_on_2 = add i2 in - if go_on_1 then aux (let p,_,_ = proof_of_id bag i1 in p); - if go_on_2 then aux (let p,_,_ = proof_of_id bag i2 in p) - in - aux p; - List.iter - (fun (_,_,id,_,_) -> aux (let p,_,_ = proof_of_id bag id in p)) - ol; - (* now h is complete *) - let proofs = Hashtbl.fold (fun k count acc-> (k,count)::acc) h [] in - let proofs = List.filter (fun (_,c) -> c > 1) proofs in - let res = topological_sort bag (List.map (fun (i,_) -> i) proofs) in - res -;; - -let build_proof_term bag eq h lift proof = - let proof_of_id aux id = - let p,l,r = proof_of_id bag id in - try List.assoc id h,l,r with Not_found -> aux p, l, r - in - let rec aux = function - | Exact term -> - CicSubstitution.lift lift term - | Step (subst,(rule, id1, (pos,id2), pred)) -> - let p1,_,_ = proof_of_id aux id1 in - let p2,l,r = proof_of_id aux id2 in - let varname = - match rule with - | SuperpositionRight -> Cic.Name ("SupR" ^ Utils.string_of_pos pos) - | Demodulation -> Cic.Name ("DemEq"^ Utils.string_of_pos pos) - | _ -> assert false - in - let pred = - match pred with - | Cic.Lambda (_,a,b) -> Cic.Lambda (varname,a,b) - | _ -> assert false - in - let p = build_proof_step eq lift subst p1 p2 pos l r pred in -(* let cond = (not (List.mem 302 (Utils.metas_of_term p)) || id1 = 8 || id1 = 132) in - if not cond then - prerr_endline ("ERROR " ^ string_of_int id1 ^ " " ^ string_of_int id2); - assert cond;*) - p - in - aux proof -;; - -let build_goal_proof ?(contextualize=true) ?(forward=false) bag eq l initial ty se context menv = - let se = List.map (fun i -> Cic.Meta (i,[])) se in - let lets = get_duplicate_step_in_wfo bag l initial in - let letsno = List.length lets in - let l = if forward then List.rev l else l in - let lift_list l = List.map (fun (i,t) -> i,CicSubstitution.lift 1 t) l in - let lets,_,h = - List.fold_left - (fun (acc,n,h) id -> - let p,l,r = proof_of_id bag id in - let cic = build_proof_term bag eq h n p in - let real_cic,instance = - parametrize_proof cic l r - in - let h = (id, instance)::lift_list h in - acc@[id,real_cic],n+1,h) - ([],0,[]) lets - in - let lets = - List.map (fun (id,cic) -> id,cic,Cic.Implicit (Some `Type)) lets - in - let proof,se = - let rec aux se current_proof = function - | [] -> current_proof,se - | (rule,pos,id,subst,pred)::tl -> - let p,l,r = proof_of_id bag id in - let p = build_proof_term bag eq h letsno p in - let pos = if forward then pos else - if pos = Utils.Left then Utils.Right else Utils.Left in - let varname = - match rule with - | SuperpositionLeft -> Cic.Name ("SupL" ^ Utils.string_of_pos pos) - | Demodulation -> Cic.Name ("DemG"^ Utils.string_of_pos pos) - | _ -> assert false - in - let pred = - match pred with - | Cic.Lambda (_,a,b) -> Cic.Lambda (varname,a,b) - | _ -> assert false - in - let proof = - build_proof_step eq letsno subst current_proof p pos l r pred - in - let proof,se = aux se proof tl in - Subst.apply_subst_lift letsno subst proof, - List.map (fun x -> Subst.apply_subst(*_lift letsno*) subst x) se - in - aux se (build_proof_term bag eq h letsno initial) l - in - let n,proof = - let initial = proof in - List.fold_right - (fun (id,cic,ty) (n,p) -> - n-1, - Cic.LetIn ( - Cic.Name ("H"^string_of_int id), - cic, - ty, - p)) - lets (letsno-1,initial) - in - let proof = - if contextualize - then contextualize_rewrites proof (CicSubstitution.lift letsno ty) - else proof in - canonical proof context menv, se -;; - -let refl_proof eq_uri ty term = - Cic.Appl [Cic.MutConstruct (eq_uri, 0, 1, []); ty; term] -;; - -let metas_of_proof bag p = - let eq = - match LibraryObjects.eq_URI () with - | Some u -> u - | None -> - raise - (ProofEngineTypes.Fail - (lazy "No default equality defined when calling metas_of_proof")) - in - let p = build_proof_term bag eq [] 0 p in - Utils.metas_of_term p -;; - -let remove_local_context eq = - let w, p, (ty, left, right, o), menv,id = open_equality eq in - let p = Utils.remove_local_context p in - let ty = Utils.remove_local_context ty in - let left = Utils.remove_local_context left in - let right = Utils.remove_local_context right in - w, p, (ty, left, right, o), menv, id -;; - -let relocate newmeta menv to_be_relocated = - let subst, newmetasenv, newmeta = - List.fold_right - (fun i (subst, metasenv, maxmeta) -> - let _,context,ty = CicUtil.lookup_meta i menv in - let irl = [] in - let newmeta = Cic.Meta(maxmeta,irl) in - let newsubst = Subst.buildsubst i context newmeta ty subst in - (* newsubst, (maxmeta,context,ty)::metasenv, maxmeta+1) *) - newsubst, (maxmeta,[],ty)::metasenv, maxmeta+1) - to_be_relocated (Subst.empty_subst, [], newmeta+1) - in - (* let subst = Subst.flatten_subst subst in *) - let menv = Subst.apply_subst_metasenv subst (menv @ newmetasenv) in - subst, menv, newmeta - -let fix_metas_goal (id_to_eq,newmeta) goal = - let (proof, menv, ty) = goal in - let to_be_relocated = List.map (fun i ,_,_ -> i) menv in - let subst, menv, newmeta = relocate newmeta menv to_be_relocated in - let ty = Subst.apply_subst subst ty in - let proof = - match proof with - | [] -> assert false (* is a nonsense to relocate the initial goal *) - | (r,pos,id,s,p) :: tl -> (r,pos,id,Subst.concat subst s,p) :: tl - in - (id_to_eq,newmeta+1),(proof, menv, ty) -;; - -let fix_metas (id_to_eq, newmeta) eq = - let w, p, (ty, left, right, o), menv,_ = open_equality eq in - let to_be_relocated = List.map (fun i ,_,_ -> i) menv in - let subst, metasenv, newmeta = relocate newmeta menv to_be_relocated in - let ty = Subst.apply_subst subst ty in - let left = Subst.apply_subst subst left in - let right = Subst.apply_subst subst right in - let fix_proof = function - | Exact p -> Exact (Subst.apply_subst subst p) - | Step (s,(r,id1,(pos,id2),pred)) -> - Step (Subst.concat s subst,(r,id1,(pos,id2), pred)) - in - let p = fix_proof p in - let bag = id_to_eq, newmeta in - let bag, e = mk_equality bag (w, p, (ty, left, right, o), metasenv) in - bag, e -;; - -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) when m1 = m2 -> table - | C.Meta (m1, tl1), C.Meta (m2, tl2) when m1 < m2 -> aux table t2 t1 - | 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 table_l,table_r - | 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) -> - let table = aux table s1 s2 in - aux table t1 t2 - | C.LetIn (_, s1, ty1, t1), C.LetIn (_, s2, ty2, t2) -> - let table = aux table s1 s2 in - let table = aux table ty1 ty2 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) = - Pervasives.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, _), _,_ = open_equality eq1 in - let _, _, (ty', left', right', _), _,_ = open_equality 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 meta_convertibility_subst t1 t2 menv = - if t1 = t2 then - Some([]) - else - try - let (l,_) = meta_convertibility_aux ([],[]) t1 t2 in - let subst = - List.map - (fun (x,y) -> - try - let (_,c,t) = CicUtil.lookup_meta x menv in - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable c in - (y,(c,Cic.Meta(x,irl),t)) - with CicUtil.Meta_not_found _ -> - try - let (_,c,t) = CicUtil.lookup_meta y menv in - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable c in - (x,(c,Cic.Meta(y,irl),t)) - with CicUtil.Meta_not_found _ -> assert false) l in - Some subst - with NotMetaConvertible -> - None -;; - -exception TermIsNotAnEquality;; - -let term_is_equality term = - match term with - | Cic.Appl [Cic.MutInd (uri, _, _); _; _; _] - when LibraryObjects.is_eq_URI uri -> true - | _ -> false -;; - -let equality_of_term bag proof term newmetas = - match term with - | Cic.Appl [Cic.MutInd (uri, _, _); ty; t1; t2] - when LibraryObjects.is_eq_URI uri -> - let o = !Utils.compare_terms t1 t2 in - let stat = (ty,t1,t2,o) in - let w = Utils.compute_equality_weight stat in - let bag, e = mk_equality bag (w, Exact proof, stat,newmetas) in - bag, e - | _ -> - raise TermIsNotAnEquality -;; - -let is_weak_identity eq = - let _,_,(_,left, right,_),_,_ = open_equality eq in - left = right - (* doing metaconv here is meaningless *) -;; - -let is_identity (_, context, ugraph) eq = - let _,_,(ty,left,right,_),menv,_ = open_equality eq in - (* doing metaconv here is meaningless *) - left = right -(* fst (CicReduction.are_convertible ~metasenv:menv context left right ugraph) - * *) -;; - - -let term_of_equality eq_uri equality = - let _, _, (ty, left, right, _), menv, _= open_equality equality in - let eq i = function Cic.Meta (j, _) -> i = j | _ -> false in - let argsno = List.length menv in - let t = - CicSubstitution.lift argsno - (Cic.Appl [Cic.MutInd (eq_uri, 0, []); ty; left; right]) - in - snd ( - List.fold_right - (fun (i,_,ty) (n, t) -> - let name = Cic.Name ("X" ^ (string_of_int n)) in - let ty = CicSubstitution.lift (n-1) ty 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))) - menv (argsno, t)) -;; - -let symmetric bag eq_ty l id uri m = - let eq = Cic.MutInd(uri,0,[]) in - let pred = - Cic.Lambda (Cic.Name "Sym",eq_ty, - Cic.Appl [CicSubstitution.lift 1 eq ; - CicSubstitution.lift 1 eq_ty; - Cic.Rel 1;CicSubstitution.lift 1 l]) - in - let prefl = - Exact (Cic.Appl - [Cic.MutConstruct(uri,0,1,[]);eq_ty;l]) - in - let bag, id1 = - let bag, eq = mk_equality bag (0,prefl,(eq_ty,l,l,Utils.Eq),m) in - let (_,_,_,_,id) = open_equality eq in - bag, id - in - bag, Step(Subst.empty_subst, - (Demodulation,id1,(Utils.Left,id),pred)) -;; - -module IntOT = struct - type t = int - let compare = Pervasives.compare -end - -module IntSet = Set.Make(IntOT);; - -let n_purged = ref 0;; - -let collect ((id_to_eq,maxmeta) as bag) alive1 alive2 alive3 = - let deps_of id = - let p,_,_ = proof_of_id bag id in - match p with - | Exact _ -> IntSet.empty - | Step (_,(_,id1,(_,id2),_)) -> - IntSet.add id1 (IntSet.add id2 IntSet.empty) - in - let rec close s = - let news = IntSet.fold (fun id s -> IntSet.union (deps_of id) s) s s in - if IntSet.equal news s then s else close news - in - let l_to_s s l = List.fold_left (fun s x -> IntSet.add x s) s l in - let alive_set = l_to_s (l_to_s (l_to_s IntSet.empty alive2) alive1) alive3 in - let closed_alive_set = close alive_set in - let to_purge = - M.fold - (fun k _ s -> - if not (IntSet.mem k closed_alive_set) then - k::s else s) id_to_eq [] - in - n_purged := !n_purged + List.length to_purge; - List.fold_right M.remove to_purge id_to_eq, maxmeta -;; - -let get_stats () = "" -(* - <:show> ^ - "# of purged eq by the collector: " ^ string_of_int !n_purged ^ "\n" -*) -;; - -let rec pp_proofterm name t context = - let rec skip_lambda tys ctx = function - | Cic.Lambda (n,s,t) -> skip_lambda (s::tys) ((Some n)::ctx) t - | t -> ctx,tys,t - in - let rename s name = - match name with - | Cic.Name s1 -> Cic.Name (s ^ s1) - | _ -> assert false - in - let rec skip_letin ctx = function - | Cic.LetIn (n,b,_,t) -> - pp_proofterm (Some (rename "Lemma " n)) b ctx:: - skip_letin ((Some n)::ctx) t - | t -> - let ppterm t = CicPp.pp t ctx in - let rec pp inner = function - | Cic.Appl [Cic.Const (uri,[]);_;l;m;r;p1;p2] - when Pcre.pmatch ~pat:"trans_eq" (UriManager.string_of_uri uri)-> - if not inner then - (" " ^ ppterm l) :: pp true p1 @ - [ " = " ^ ppterm m ] @ pp true p2 @ - [ " = " ^ ppterm r ] - else - pp true p1 @ - [ " = " ^ ppterm m ] @ pp true p2 - | Cic.Appl [Cic.Const (uri,[]);_;l;m;p] - when Pcre.pmatch ~pat:"sym_eq" (UriManager.string_of_uri uri)-> - pp true p - | Cic.Appl [Cic.Const (uri,[]);_;_;_;_;_;p] - when Pcre.pmatch ~pat:"eq_f" (UriManager.string_of_uri uri)-> - pp true p - | Cic.Appl [Cic.Const (uri,[]);_;_;_;_;_;p] - when Pcre.pmatch ~pat:"eq_OF_eq" (UriManager.string_of_uri uri)-> - pp true p - | Cic.Appl [Cic.MutConstruct (uri,_,_,[]);_;_;t;p] - when Pcre.pmatch ~pat:"ex.ind" (UriManager.string_of_uri uri)-> - [ "witness " ^ ppterm t ] @ pp true p - | Cic.Appl (t::_) ->[ " [by " ^ ppterm t ^ "]"] - | t ->[ " [by " ^ ppterm t ^ "]"] - in - let rec compat = function - | a::b::tl -> (b ^ a) :: compat tl - | h::[] -> [h] - | [] -> [] - in - let compat l = List.hd l :: compat (List.tl l) in - compat (pp false t) @ ["";""] - in - let names, tys, body = skip_lambda [] context t in - let ppname name = (match name with Some (Cic.Name s) -> s | _ -> "") in - ppname name ^ ":\n" ^ - (if context = [] then - let rec pp_l ctx = function - | (t,name)::tl -> - " " ^ ppname name ^ ": " ^ CicPp.pp t ctx ^ "\n" ^ - pp_l (name::ctx) tl - | [] -> "\n\n" - in - pp_l [] (List.rev (List.combine tys names)) - else "") - ^ - String.concat "\n" (skip_letin names body) -;; - -let pp_proofterm t = - "\n\n" ^ - pp_proofterm (Some (Cic.Name "Hypothesis")) t [] -;; - -let initial_nameset_list = [ - "x"; "y"; "z"; "t"; "u"; "v"; "a"; "b"; "c"; "d"; - "e"; "l"; "m"; "n"; "o"; "p"; "q"; "r"; -] - -module S = Set.Make(String) - -let initial_nameset = List.fold_right S.add initial_nameset_list S.empty, [];; - -let freshname (nameset, subst) term = - let m = CicUtil.metas_of_term term in - let nameset, subst = - List.fold_left - (fun (set,rc) (m,_) -> - if List.mem_assoc m rc then set,rc else - let name = S.choose set in - let set = S.remove name set in - set, - (m,Cic.Const(UriManager.uri_of_string - ("cic:/"^name^".con"),[]))::rc) - (nameset,subst) m - in - let term = - ProofEngineReduction.replace - ~equality:(fun i t -> match t with Cic.Meta (j,_) -> i=j| _ -> false) - ~what:(List.map fst subst) - ~with_what:(List.map snd subst) ~where:term - in - (nameset, subst), term -;; - -let remove_names_in_context (set,subst) names = - List.fold_left - (fun s n -> - match n with Some (Cic.Name n) -> S.remove n s | _ -> s) - set names, subst -;; - -let string_of_id2 (id_to_eq,_) names nameset id = - if id = 0 then "" else - try - let (_,_,(_,l,r,_),_,_) = open_equality (M.find id id_to_eq) in - let nameset, l = freshname nameset l in - let nameset, r = freshname nameset r in - Printf.sprintf "%s = %s" (CicPp.pp l names) (CicPp.pp r names) - with - Not_found -> assert false -;; - -let draw_proof bag names goal_proof proof id = - let b = Buffer.create 100 in - let fmt = Format.formatter_of_buffer b in - let sint = string_of_int in - let fst3 (x,_,_) = x in - let visited = ref [] in - let nameset = remove_names_in_context initial_nameset names in - let rec fact id = function - | Exact t -> - if not (List.mem id !visited) then - begin - visited := id :: !visited; - let nameset, t = freshname nameset t in - let t = CicPp.pp t names in - GraphvizPp.Dot.node (sint id) - ~attrs:["label",t^":"^string_of_id2 bag names nameset id; - "shape","rectangle"] fmt; - end - | Step (_,(_,id1,(_,id2),_)) -> - GraphvizPp.Dot.edge (sint id) (sint id1) fmt; - GraphvizPp.Dot.edge (sint id) (sint id2) fmt; - let p1,_,_ = proof_of_id bag id1 in - let p2,_,_ = proof_of_id bag id2 in - fact id1 p1; - fact id2 p2; - if not (List.mem id !visited); then - begin - visited := id :: !visited; - GraphvizPp.Dot.node (sint id) - ~attrs:["label",sint id^":"^string_of_id2 bag names nameset id; - "shape","ellipse"] fmt - end - in - let sleft acc (_,_,id,_,_) = - if acc != 0 then GraphvizPp.Dot.edge (sint acc) (sint id) fmt; - fact id (fst3 (proof_of_id bag id)); - id - in - GraphvizPp.Dot.header ~node_attrs:["fontsize","10"; ] fmt; - ignore(List.fold_left sleft id goal_proof); - GraphvizPp.Dot.trailer fmt; - let oc = open_out "/tmp/matita_paramod.dot" in - Buffer.output_buffer oc b; - close_out oc; - Utils.debug_print (lazy "dot!"); - ignore(Unix.system - "dot -Tps -o /tmp/matita_paramod.eps /tmp/matita_paramod.dot" -(* "cat /tmp/matita_paramod.dot| tred | dot -Tps -o /tmp/matita_paramod.eps" *) - ); - ignore(Unix.system "gv /tmp/matita_paramod.eps"); -;; - -let saturate_term (id_to_eq, maxmeta) metasenv subst context term = - let maxmeta = max maxmeta (CicMkImplicit.new_meta metasenv subst) in - let head, metasenv, args, newmeta = - TermUtil.saturate_term maxmeta metasenv context term 0 - in - (id_to_eq, newmeta), head, metasenv, args -;; - -let push_maxmeta (id_to_eq, maxmeta) m = id_to_eq, max maxmeta m ;; -let filter_metasenv_gt_maxmeta (_,maxmeta) = - List.filter (fun (j,_,_) -> j >= maxmeta) -;; -let maxmeta = snd;; diff --git a/matita/components/tactics/paramodulation/equality.mli b/matita/components/tactics/paramodulation/equality.mli deleted file mode 100644 index d60164689..000000000 --- a/matita/components/tactics/paramodulation/equality.mli +++ /dev/null @@ -1,170 +0,0 @@ -(* Copyright (C) 2006, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -type rule = SuperpositionRight | SuperpositionLeft | Demodulation - -(* every equality group has its own bag. the bag contains the infos necessary - * for building the proof. FIXME: should also contain maxmeta! *) -type equality_bag - -val mk_equality_bag: unit -> equality_bag - -type equality - -and proof = - Exact of Cic.term - | Step of Subst.substitution * (rule * int * (Utils.pos * int) * Cic.term) - -and goal_proof = (rule * Utils.pos * int * Subst.substitution * Cic.term) list - -type goal = goal_proof * Cic.metasenv * Cic.term - -val pp_proof: - equality_bag -> - (Cic.name option) list -> goal_proof -> proof -> Subst.substitution -> int -> - Cic.term -> string - -val draw_proof: - equality_bag -> - (Cic.name option) list -> goal_proof -> proof -> int -> unit - -val pp_proofterm: Cic.term -> string - -val mk_eq_ind : - UriManager.uri -> - Cic.term -> - Cic.term -> - Cic.term -> - Cic.term -> - Cic.term -> - Cic.term -> - Cic.term - -val mk_equality : - equality_bag -> int * proof * - (Cic.term * Cic.term * Cic.term * Utils.comparison) * - Cic.metasenv -> equality_bag * equality - -val mk_tmp_equality : - int * (Cic.term * Cic.term * Cic.term * Utils.comparison) * Cic.metasenv -> - equality - -val open_equality : - equality -> - int * proof * - (Cic.term * Cic.term * Cic.term * Utils.comparison) * - Cic.metasenv * int -val depend : equality_bag -> equality -> int -> bool -val compare : equality -> equality -> int -val max_weight_in_proof : equality_bag -> int -> proof -> int -val max_weight : equality_bag -> goal_proof -> proof -> int -val string_of_equality : - ?env:Utils.environment -> equality -> string -val string_of_proof : - ?names:(Cic.name option)list -> equality_bag -> proof -> goal_proof -> string -(* given a proof and a list of meta indexes we are interested in the - * instantiation gives back the cic proof and the list of instantiations *) -(* build_goal_proof [eq_URI] [goal_proof] [initial_proof] [ty] - * [ty] is the type of the goal *) -val build_goal_proof: - ?contextualize:bool -> - ?forward:bool -> - equality_bag -> - UriManager.uri -> goal_proof -> proof -> Cic.term-> int list -> - Cic.context -> Cic.metasenv -> - Cic.term * Cic.term list -val build_proof_term : - equality_bag -> - UriManager.uri -> (int * Cic.term) list -> int -> proof -> Cic.term -val refl_proof: UriManager.uri -> Cic.term -> Cic.term -> Cic.term -(** ensures that metavariables in equality are unique *) -val fix_metas_goal: equality_bag -> goal -> equality_bag * goal -val fix_metas: equality_bag -> equality -> equality_bag * equality -val metas_of_proof: equality_bag -> proof -> int list - -(* this should be used _only_ to apply (efficiently) this subst on the - * initial proof passed to build_goal_proof *) -val add_subst : Subst.substitution -> proof -> proof -exception TermIsNotAnEquality;; - -(** - raises TermIsNotAnEquality if term is not an equation. - The first Cic.term is a proof of the equation -*) -val equality_of_term: - equality_bag -> Cic.term -> Cic.term -> Cic.metasenv -> - equality_bag * equality - -(** - Re-builds the term corresponding to this equality -*) -val term_of_equality: UriManager.uri -> equality -> Cic.term -val term_is_equality: Cic.term -> bool - -val saturate_term : - equality_bag -> Cic.metasenv -> Cic.substitution -> Cic.context -> Cic.term -> - equality_bag * Cic.term * Cic.metasenv * Cic.term list - -val push_maxmeta : equality_bag -> int -> equality_bag -val maxmeta : equality_bag -> int -val filter_metasenv_gt_maxmeta: equality_bag -> Cic.metasenv -> Cic.metasenv - -(** 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 meta_convertibility_subst: - Cic.term -> Cic.term -> Cic.metasenv -> Cic.substitution option - -val is_weak_identity: equality -> bool -val is_identity: Utils.environment -> equality -> bool - -val is_in: equality_bag -> int -> bool - -(* symmetric [eq_ty] [l] [id] [uri] [m] - * - * given an equality (_,p,(_,[l],r,_),[m],[id]) of 'type' l=r - * returns the proof of the symmetric (r=l). - * - * [uri] is the uri of eq - * [eq_ty] the ty of the equality sides - *) -val symmetric: - equality_bag -> Cic.term -> Cic.term -> int -> UriManager.uri -> - Cic.metasenv -> equality_bag * proof - -(* takes 3 lists of alive ids (they are threated the same way, the type is - * funny just to not oblige you to concatenate them) and drops all the dead - * equalities *) -val collect: equality_bag -> int list -> int list -> int list -> equality_bag - -(* given an equality, returns the numerical id *) -val id_of: equality -> int - -(* profiling statistics *) -val get_stats: unit -> string - diff --git a/matita/components/tactics/paramodulation/equality_indexing.ml b/matita/components/tactics/paramodulation/equality_indexing.ml deleted file mode 100644 index 19aae0d29..000000000 --- a/matita/components/tactics/paramodulation/equality_indexing.ml +++ /dev/null @@ -1,130 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -module type EqualityIndex = - sig - module PosEqSet : Set.S with type elt = Utils.pos * Equality.equality - type t = Discrimination_tree.Make(Cic_indexable.CicIndexable)(PosEqSet).t - val empty : t - val retrieve_generalizations : t -> Cic.term -> PosEqSet.t - val retrieve_unifiables : t -> Cic.term -> PosEqSet.t - val init_index : unit -> unit - val remove_index : t -> Equality.equality -> t - val index : t -> Equality.equality -> t - val in_index : t -> Equality.equality -> bool - val iter : t -> (Cic_indexable.CicIndexable.constant_name Discrimination_tree.path -> PosEqSet.t -> unit) -> unit - end - -module DT = -struct - module OrderedPosEquality = struct - type t = Utils.pos * Equality.equality - let compare (p1,e1) (p2,e2) = - let rc = Pervasives.compare p1 p2 in - if rc = 0 then Equality.compare e1 e2 else rc - end - - module PosEqSet = Set.Make(OrderedPosEquality);; - - include Discrimination_tree.Make(Cic_indexable.CicIndexable)(PosEqSet) - - - (* DISCRIMINATION TREES *) - let init_index () = () ;; - - let remove_index tree equality = - let _, _, (_, l, r, ordering), _,_ = Equality.open_equality 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.open_equality 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.open_equality equality in - let meta_convertibility (pos,equality') = - Equality.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 * Equality.equality - let compare (p1,e1) (p2,e2) = - let rc = Pervasives.compare p1 p2 in - if rc = 0 then Equality.compare e1 e2 else rc - end - - module PosEqSet = Set.Make(OrderedPosEquality);; - - include Discrimination_tree.Make(Cic_indexable.CicIndexable)(PosEqSet) - - - (* DISCRIMINATION TREES *) - let init_index () = () ;; - - let remove_index tree equality = - let _, _, (_, l, r, ordering), _,_ = Equality.open_equality 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.open_equality 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.open_equality equality in - let meta_convertibility (pos,equality') = - Equality.meta_convertibility_eq equality equality' - in - in_index tree l meta_convertibility || in_index tree r meta_convertibility -end - diff --git a/matita/components/tactics/paramodulation/equality_indexing.mli b/matita/components/tactics/paramodulation/equality_indexing.mli deleted file mode 100644 index d976843f9..000000000 --- a/matita/components/tactics/paramodulation/equality_indexing.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -module type EqualityIndex = - sig - module PosEqSet : Set.S with type elt = Utils.pos * Equality.equality - type t = Discrimination_tree.Make(Cic_indexable.CicIndexable)(PosEqSet).t - val empty : t - val retrieve_generalizations : t -> Cic.term -> PosEqSet.t - val retrieve_unifiables : t -> Cic.term -> PosEqSet.t - val init_index : unit -> unit - val remove_index : t -> Equality.equality -> t - val index : t -> Equality.equality -> t - val in_index : t -> Equality.equality -> bool - val iter : t -> (Cic_indexable.CicIndexable.constant_name Discrimination_tree.path -> PosEqSet.t -> unit) -> unit - end - -module DT : EqualityIndex -module PT : EqualityIndex - diff --git a/matita/components/tactics/paramodulation/founif.ml b/matita/components/tactics/paramodulation/founif.ml deleted file mode 100644 index b63559951..000000000 --- a/matita/components/tactics/paramodulation/founif.ml +++ /dev/null @@ -1,242 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* let _profiler = <:profiler<_profiler>>;; *) - -(* $Id$ *) - -open Utils;; -open Printf;; - -let debug_print s = ();;(*prerr_endline (Lazy.force s);;*) - -let check_disjoint_invariant subst metasenv msg = - if (List.exists - (fun (i,_,_) -> (Subst.is_in_subst i subst)) metasenv) - then - begin - prerr_endline ("not disjoint: " ^ msg); - assert false - end -;; - -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) -> let l = [] in check_irl 1 l - | Cic.Rel _ -> true - | Cic.Const _ -> true - | Cic.MutInd (_, _, []) -> true - | Cic.MutConstruct (_, _, _, []) -> true - | _ -> false -;; - -let locked menv i = - List.exists (fun (j,_,_) -> i = j) menv -;; - -let unification_simple locked_menv metasenv context t1 t2 ugraph = - let module C = Cic in - let module M = CicMetaSubst in - let module U = CicUnification in - let lookup = Subst.lookup_subst in - let rec occurs_check subst what where = - match where with - | Cic.Meta(i,_) when i = what -> 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 - (* sometimes the same meta has different local contexts; this - could create "cyclic" substitutions *) - | C.Meta (i, _), C.Meta (j, _) when i=j -> subst, menv - | C.Meta (i, _), C.Meta (j, _) - when (locked locked_menv i) &&(locked locked_menv j) -> - raise - (U.UnificationFailure (lazy "Inference.unification.unif")) - | C.Meta (i, _), C.Meta (j, _) when (locked locked_menv i) -> - unif subst menv t s - | C.Meta (i, _), C.Meta (j, _) when (i > j) && not (locked locked_menv j) -> - unif subst menv t s - | C.Meta (i,_), t when occurs_check subst i t -> - raise - (U.UnificationFailure (lazy "Inference.unification.unif")) - | C.Meta (i, l), t when (locked locked_menv i) -> - raise - (U.UnificationFailure (lazy "Inference.unification.unif")) - | C.Meta (i, l), t -> ( - try - let _, _, ty = CicUtil.lookup_meta i menv in - let subst = Subst.buildsubst i context t ty subst in - subst, menv - with CicUtil.Meta_not_found m -> - let names = names_of_context context in - (*debug_print - (lazy*) prerr_endline - (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 Subst.empty_subst metasenv t1 t2 in - let menv = Subst.filter subst menv in - subst, menv, ugraph -;; - -let profiler = HExtlib.profile "P/Inference.unif_simple[flatten]" -let profiler2 = HExtlib.profile "P/Inference.unif_simple[flatten_fast]" -let profiler3 = HExtlib.profile "P/Inference.unif_simple[resolve_meta]" -let profiler4 = HExtlib.profile "P/Inference.unif_simple[filter]" - -let check_for_duplicates metas msg = - let rec aux = function - | [] -> true - | (m,_,_)::tl -> - not (List.exists (fun (i, _, _) -> i = m) tl) && aux tl in - let b = aux metas in - if not b then - begin - prerr_endline ("DUPLICATI ---- " ^ msg); - prerr_endline (CicMetaSubst.ppmetasenv [] metas); - assert false - end - else b -;; - -let check_metasenv msg menv = - List.iter - (fun (i,ctx,ty) -> - try ignore(CicTypeChecker.type_of_aux' menv ctx ty - CicUniv.empty_ugraph) - with - | CicUtil.Meta_not_found _ -> - prerr_endline (msg ^ CicMetaSubst.ppmetasenv [] menv); - assert false - | _ -> () - ) menv -;; - -let unification_aux b metasenv1 metasenv2 context t1 t2 ugraph = - let metasenv = metasenv1@metasenv2 in - if Utils.debug_metas then - begin - ignore(check_for_duplicates metasenv "unification_aux"); - check_metasenv "unification_aux" metasenv; - end; - 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))); - raise (CicUnification.UnificationFailure (lazy "Inference.unification.unif")) - ) else - if b then - (* full unification *) - unification_simple [] metasenv context t1 t2 ugraph - else - (* matching: metasenv1 is locked *) - unification_simple metasenv1 metasenv context t1 t2 ugraph - in - if Utils.debug_res then - ignore(check_disjoint_invariant subst menv "unif"); - (* let flatten subst = - List.map - (fun (i, (context, term, ty)) -> - let context = apply_subst_context subst context in - let term = apply_subst subst term in - let ty = apply_subst subst ty in - (i, (context, term, ty))) subst - in - let flatten subst = profiler.HExtlib.profile flatten subst in - let subst = flatten subst in *) - if Utils.debug_metas then - ignore(check_for_duplicates menv "unification_aux prima di apply_subst"); - let menv = Subst.apply_subst_metasenv subst menv in - if Utils.debug_metas then - (let _ = check_for_duplicates menv "unif_aux after" in - check_metasenv "unification_aux after 1" menv); - subst, menv, ug -;; - -exception MatchingFailure;; - -(** matching takes in input the _disjoint_ metasenv of t1 and t2; -it perform unification in the union metasenv, then check that -the first metasenv has not changed *) -let matching metasenv1 metasenv2 context t1 t2 ugraph = - try - unification_aux false metasenv1 metasenv2 context t1 t2 ugraph - with - CicUnification.UnificationFailure _ -> - raise MatchingFailure -;; - -let unification m1 m2 c t1 t2 ug = - let m1 = - if (m1 = m2 && m1 <> []) then assert false - (* (prerr_endline "eccoci 2"; []) *) else m1 in - (* - prerr_endline (CicPp.ppterm t1); - prerr_endline (CicPp.ppterm t2); - prerr_endline "++++++++++"; *) - try - unification_aux true m1 m2 c t1 t2 ug - with exn -> - raise exn -;; - -let get_stats () = "" (*<:show>*) ;; diff --git a/matita/components/tactics/paramodulation/founif.mli b/matita/components/tactics/paramodulation/founif.mli deleted file mode 100644 index ef1529210..000000000 --- a/matita/components/tactics/paramodulation/founif.mli +++ /dev/null @@ -1,45 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception MatchingFailure - -(** matching between two terms. Can raise MatchingFailure *) -val matching: - Cic.metasenv -> Cic.metasenv -> Cic.context -> - Cic.term -> Cic.term -> - CicUniv.universe_graph -> - Subst.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.metasenv -> Cic.context -> - Cic.term -> Cic.term -> - CicUniv.universe_graph -> - Subst.substitution * Cic.metasenv * CicUniv.universe_graph - -val get_stats: unit -> string diff --git a/matita/components/tactics/paramodulation/indexing.ml b/matita/components/tactics/paramodulation/indexing.ml deleted file mode 100644 index 7ff0dfd2c..000000000 --- a/matita/components/tactics/paramodulation/indexing.ml +++ /dev/null @@ -1,1440 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* let _profiler = <:profiler<_profiler>>;; *) - -(* $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 - 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 string_of_res ?env = - function - None -> "None" - | Some (t, s, m, u, (p,e)) -> - Printf.sprintf "Some: (%s, %s, %s)" - (Utils.string_of_pos p) - (Equality.string_of_equality ?env e) - (CicPp.ppterm t) -;; - -let print_res ?env res = - prerr_endline - (String.concat "\n" - (List.map (string_of_res ?env) res)) -;; - -let print_candidates ?env mode term res = - let _ = - match mode with - | Matching -> - prerr_endline ("| candidates Matching " ^ (CicPp.ppterm term)) - | Unification -> - prerr_endline ("| candidates Unification " ^ (CicPp.ppterm term)) - in - prerr_endline - (String.concat "\n" - (List.map - (fun (p, e) -> - Printf.sprintf "| (%s, %s)" (Utils.string_of_pos p) - (Equality.string_of_equality ?env e)) - res)); -;; - - -let apply_subst = Subst.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 - -let check_disjoint_invariant subst metasenv msg = - if (List.exists - (fun (i,_,_) -> (Subst.is_in_subst i subst)) metasenv) - then - begin - prerr_endline ("not disjoint: " ^ msg); - assert false - end -;; - -let check_for_duplicates metas msg = - let rec aux = function - | [] -> true - | (m,_,_)::tl -> not (List.exists (fun (i, _, _) -> i = m) tl) && aux tl in - let b = aux metas in - if not b then - begin - prerr_endline ("DUPLICATI " ^ msg); - prerr_endline (CicMetaSubst.ppmetasenv [] metas); - assert false - end - else () -;; - -let check_metasenv msg menv = - List.iter - (fun (i,ctx,ty) -> - try ignore(CicTypeChecker.type_of_aux' menv ctx ty - CicUniv.empty_ugraph) - with - | CicUtil.Meta_not_found _ -> - prerr_endline (msg ^ CicMetaSubst.ppmetasenv [] menv); - assert false - | _ -> () - ) menv -;; - -(* the metasenv returned by res must included in the original one, -due to matching. If it fails, it is probably because we are not -demodulating with a unit equality *) - -let not_unit_eq ctx eq = - let (_,_,(ty,left,right,o),metas,_) = Equality.open_equality eq in - let b = - List.exists - (fun (_,_,ty) -> - try - let s,_ = CicTypeChecker.type_of_aux' metas ctx ty CicUniv.oblivion_ugraph - in s = Cic.Sort(Cic.Prop) - with _ -> - prerr_endline ("ERROR typing " ^ CicPp.ppterm ty); assert false) metas - in b -(* -if b then prerr_endline ("not a unit equality: " ^ Equality.string_of_equality eq); b *) -;; - -let check_demod_res res metasenv msg = - match res with - | Some (_, _, menv, _, _) -> - let b = - List.for_all - (fun (i,_,_) -> - (List.exists (fun (j,_,_) -> i=j) metasenv)) menv - in - if (not b) then - begin - debug_print (lazy ("extended context " ^ msg)); - debug_print (lazy (CicMetaSubst.ppmetasenv [] menv)); - end; - b - | None -> false -;; - -let check_res res msg = - match res with - | Some (t, subst, menv, ug, eq_found) -> - let eqs = Equality.string_of_equality (snd eq_found) in - check_metasenv msg menv; - check_disjoint_invariant subst menv msg; - check_for_duplicates menv (msg ^ "\nchecking " ^ eqs); - | None -> () -;; - -let check_target bag context target msg = - let w, proof, (eq_ty, left, right, order), metas,_ = - Equality.open_equality target in - (* check that metas does not contains duplicates *) - let eqs = Equality.string_of_equality target in - let _ = check_for_duplicates metas (msg ^ "\nchecking " ^ eqs) in - let actual = (Utils.metas_of_term left)@(Utils.metas_of_term right) - @(Utils.metas_of_term eq_ty)@(Equality.metas_of_proof bag proof) in - let menv = List.filter (fun (i, _, _) -> List.mem i actual) metas in - let _ = if menv <> metas then - begin - prerr_endline ("extra metas " ^ msg); - prerr_endline (CicMetaSubst.ppmetasenv [] metas); - prerr_endline "**********************"; - prerr_endline (CicMetaSubst.ppmetasenv [] menv); - prerr_endline ("left: " ^ (CicPp.ppterm left)); - prerr_endline ("right: " ^ (CicPp.ppterm right)); - prerr_endline ("ty: " ^ (CicPp.ppterm eq_ty)); - assert false - end - else () in () -(* - try - ignore(CicTypeChecker.type_of_aux' - metas context (Founif.build_proof_term proof) CicUniv.empty_ugraph) - with e -> - prerr_endline msg; - prerr_endline (Founif.string_of_proof proof); - prerr_endline (CicPp.ppterm (Founif.build_proof_term proof)); - prerr_endline ("+++++++++++++left: " ^ (CicPp.ppterm left)); - prerr_endline ("+++++++++++++right: " ^ (CicPp.ppterm right)); - raise e -*) - - -(* 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 ?env mode tree term = - let s = - match mode with - | Matching -> - Index.retrieve_generalizations tree term - | Unification -> - Index.retrieve_unifiables tree term - - in - Index.PosEqSet.elements s -;; - -(* - 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 bag 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, equality = candidate in - (* if not_unit_eq context equality then - begin - prerr_endline "not a unit"; - prerr_endline (Equality.string_of_equality equality) - end; *) - let (_, proof, (ty, left, right, o), metas,_) = - Equality.open_equality equality - in - if Utils.debug_metas then - ignore(check_target bag context (snd candidate) "find_matches"); - if Utils.debug_res then - begin - let c="eq = "^(Equality.string_of_equality (snd candidate)) ^ "\n"in - let t="t = " ^ (CicPp.ppterm term) ^ "\n" in - let m="metas = " ^ (CicMetaSubst.ppmetasenv [] metas) ^ "\n" in - let ms="metasenv =" ^ (CicMetaSubst.ppmetasenv [] metasenv) ^ "\n" in - let eq_uri = - match LibraryObjects.eq_URI () with - | Some (uri) -> uri - | None -> raise (ProofEngineTypes.Fail (lazy "equality not declared")) in - let p="proof = "^ - (CicPp.ppterm(Equality.build_proof_term bag eq_uri [] 0 proof))^"\n" - in - - check_for_duplicates metas "gia nella metas"; - check_for_duplicates metasenv "gia nel metasenv"; - check_for_duplicates (metasenv@metas) ("not disjoint"^c^t^m^ms^p) - end; - if check && not (fst (CicReduction.are_convertible - ~metasenv context termty ty ugraph)) then ( - find_matches bag metasenv context ugraph lift_amount term termty tl - ) else - let do_match c = - let subst', metasenv', ugraph' = - Founif.matching - metasenv metas context term (S.lift lift_amount c) ugraph - in - if Utils.debug_metas then - check_metasenv "founif :" metasenv'; - Some (Cic.Rel(1+lift_amount),subst',metasenv',ugraph',candidate) - in - let c, other = - if pos = Utils.Left then left, right - else right, left - in - if o <> U.Incomparable then - let res = - try - do_match c - with Founif.MatchingFailure -> - find_matches bag metasenv context ugraph lift_amount term termty tl - in - if Utils.debug_res then ignore (check_res res "find1"); - res - else - let res = - try do_match c - with Founif.MatchingFailure -> None - in - if Utils.debug_res then ignore (check_res res "find2"); - 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 bag - metasenv context ugraph lift_amount term termty tl - | None -> - find_matches bag metasenv context ugraph lift_amount term termty tl -;; - -let find_matches metasenv context ugraph lift_amount term termty = - find_matches metasenv context ugraph lift_amount term termty -;; - -(* - as above, but finds all the matching equalities, and the matching condition - can be either Founif.matching or Inference.unification -*) -(* XXX termty unused *) -let rec find_all_matches ?(unif_fun=Founif.unification) ?(demod=false) - 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 - (* prerr_endline ("matching " ^ CicPp.ppterm term); *) - let cmp x y = - let r = !Utils.compare_terms x y in -(* - prerr_endline ( - CicPp.ppterm x ^ " " ^ - Utils.string_of_comparison r ^ " " ^ - CicPp.ppterm y ); -*) - r - in - let check = match termty with C.Implicit None -> false | _ -> true in - function - | [] -> [] - | candidate::tl -> - let pos, equality = candidate in - let (_,_,(ty,left,right,o),metas,_)= Equality.open_equality equality in - if check && not (fst (CicReduction.are_convertible - ~metasenv context termty ty ugraph)) then ( - find_all_matches metasenv context ugraph lift_amount term termty tl - ) else - let do_match c = - let subst', metasenv', ugraph' = - unif_fun metasenv metas context term (S.lift lift_amount c) ugraph - in - (C.Rel (1+lift_amount),subst',metasenv',ugraph',candidate) - in - - let c, other = - if pos = Utils.Left then left, right - else right, left - in - if o <> U.Incomparable then - try - let res = do_match c in - res::(find_all_matches ~unif_fun metasenv context ugraph - lift_amount term termty tl) - with - | Founif.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 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 (demod && order = U.Gt) || - (not demod && (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 - | Founif.MatchingFailure - | CicUnification.UnificationFailure _ - | CicUnification.Uncertain _ -> - find_all_matches ~unif_fun metasenv context ugraph - lift_amount term termty tl -;; - -let find_all_matches - ?unif_fun ?demod metasenv context ugraph lift_amount term termty l -= - find_all_matches - ?unif_fun ?demod metasenv context ugraph lift_amount term termty l - (*prerr_endline "CANDIDATES:"; - List.iter (fun (_,x)->prerr_endline (Founif.string_of_equality x)) l; - prerr_endline ("MATCHING:" ^ CicPp.ppterm term ^ " are " ^ string_of_int - (List.length rc));*) -;; -(* - returns true if target is subsumed by some equality in table -*) -(* -let print_res l = - prerr_endline (String.concat "\n" (List.map (fun (_, subst, menv, ug, - ((pos,equation),_)) -> Equality.string_of_equality equation)l)) -;; -*) - -let subsumption_aux use_unification env table target = - let _, _, (ty, left, right, _), tmetas, _ = Equality.open_equality target in - let _, context, ugraph = env in - let metasenv = tmetas in - let predicate, unif_fun = - if use_unification then - Unification, Founif.unification - else - Matching, Founif.matching - in - let leftr = - match left with - | Cic.Meta _ when not use_unification -> [] - | _ -> - let leftc = get_candidates predicate table left in - find_all_matches ~unif_fun - metasenv context ugraph 0 left ty leftc - in - let rec ok what leftorright = function - | [] -> None - | (_, subst, menv, ug, (pos,equation))::tl -> - let _, _, (_, l, r, o), m,_ = Equality.open_equality equation in - try - let other = if pos = Utils.Left then r else l in - let what' = Subst.apply_subst subst what in - let other' = Subst.apply_subst subst other in - let subst', menv', ug' = - unif_fun metasenv m context what' other' ugraph - in - (match Subst.merge_subst_if_possible subst subst' with - | None -> ok what leftorright tl - | Some s -> Some (s, equation, leftorright <> pos )) - with - | Founif.MatchingFailure - | CicUnification.UnificationFailure _ -> ok what leftorright tl - in - match ok right Utils.Left leftr with - | Some _ as res -> res - | None -> - let rightr = - match right with - | Cic.Meta _ when not use_unification -> [] - | _ -> - let rightc = get_candidates predicate table right in - find_all_matches ~unif_fun - metasenv context ugraph 0 right ty rightc - in - ok left Utils.Right rightr -;; - -let subsumption x y z = - subsumption_aux false x y z -;; - -let unification x y z = - subsumption_aux true x y z -;; - -(* the target must be disjoint from the equations in the table *) -let subsumption_aux_all use_unification env table target = - let _, _, (ty, left, right, _), tmetas, _ = Equality.open_equality target in - let _, context, ugraph = env in - let metasenv = tmetas in - if Utils.debug_metas then - check_for_duplicates metasenv "subsumption_aux_all"; - let predicate, unif_fun = - if use_unification then - Unification, Founif.unification - else - Matching, Founif.matching - in - let leftr = - match left with - | Cic.Meta _ (*when not use_unification*) -> [] - | _ -> - let leftc = get_candidates predicate table left in - find_all_matches ~unif_fun - metasenv context ugraph 0 left ty leftc - in - let rightr = - match right with - | Cic.Meta _ (*when not use_unification*) -> [] - | _ -> - let rightc = get_candidates predicate table right in - find_all_matches ~unif_fun - metasenv context ugraph 0 right ty rightc - in - let rec ok_all what leftorright = function - | [] -> [] - | (_, subst, menv, ug, (pos,equation))::tl -> - let _, _, (_, l, r, o), m,_ = Equality.open_equality equation in - try - let other = if pos = Utils.Left then r else l in - let what' = Subst.apply_subst subst what in - let other' = Subst.apply_subst subst other in - let subst', menv', ug' = - unif_fun [] menv context what' other' ugraph - in - (match Subst.merge_subst_if_possible subst subst' with - | None -> ok_all what leftorright tl - | Some s -> - (s, equation, leftorright <> pos )::(ok_all what leftorright tl)) - with - | Founif.MatchingFailure - | CicUnification.UnificationFailure _ -> (ok_all what leftorright tl) - in - (ok_all right Utils.Left leftr)@(ok_all left Utils.Right rightr ) -;; - -let subsumption_all x y z = - subsumption_aux_all false x y z -;; - -let unification_all x y z = - subsumption_aux_all true x y z -;; - -let rec demodulation_aux bag ?from ?(typecheck=false) - metasenv context ugraph table lift_amount term = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - if Utils.debug_metas then - check_for_duplicates metasenv "in input a demodulation aux"; - let candidates = - get_candidates - ~env:(metasenv,context,ugraph) (* Unification *) Matching table term - in -(* let candidates = List.filter (fun _,x -> not (not_unit_eq context x)) candidates in *) - let res = - match term with - | C.Meta _ -> None - | term -> - let res = - try - let termty, ugraph = - if typecheck then - CicTypeChecker.type_of_aux' metasenv context term ugraph - else - C.Implicit None, ugraph - in - find_matches bag metasenv context ugraph - lift_amount term termty candidates - with _ -> - prerr_endline "type checking error"; - prerr_endline ("menv :\n" ^ CicMetaSubst.ppmetasenv [] metasenv); - prerr_endline ("term: " ^ (CicPp.ppterm term)); - assert false; - (* None *) - in - let res = - (if Utils.debug_res then - ignore(check_res res "demod1"); - if check_demod_res res metasenv "demod" then res else None) 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 bag ~from:"1" metasenv context ugraph table ~typecheck - 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 bag ~from:"2" - metasenv context ugraph table lift_amount s in ( - match r1 with - | None -> - let r2 = - demodulation_aux bag 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) -> - prerr_endline "siam qui"; - let r1 = - demodulation_aux bag - metasenv context ugraph table lift_amount s in ( - match r1 with - | None -> - let r2 = - demodulation_aux bag 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 - in - if Utils.debug_res then ignore(check_res res "demod_aux output"); - res -;; - -exception Foo - -(** demodulation, when target is an equality *) -let rec demodulation_equality bag ?from eq_uri env table 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, id = - Equality.open_equality target - in - (* first, we simplify *) -(* let right = U.guarded_simpl context right in *) -(* let left = U.guarded_simpl context left in *) -(* let order = !Utils.compare_terms left right in *) -(* let stat = (eq_ty, left, right, order) in *) -(* let w = Utils.compute_equality_weight stat in*) - (* let target = Equality.mk_equality (w, proof, stat, metas) in *) - if Utils.debug_metas then - ignore(check_target bag context target "demod equalities input"); - let metasenv' = (* metasenv @ *) metas in - - let build_newtarget bag is_left (t, subst, menv, ug, eq_found) = - - if Utils.debug_metas then - begin - ignore(check_for_duplicates menv "input1"); - ignore(check_disjoint_invariant subst menv "input2"); - let substs = Subst.ppsubst subst in - ignore(check_target bag context (snd eq_found) ("input3" ^ substs)) - end; - let pos, equality = eq_found in - let (_, proof', - (ty, what, other, _), menv',id') = Equality.open_equality equality in - (* - let ty = - try fst (CicTypeChecker.type_of_aux' menv' context what ugraph) - with CicUtil.Meta_not_found _ -> ty - in *) - let ty, eq_ty = apply_subst subst ty, apply_subst subst eq_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*) - let name = C.Name "x" in - 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 (eq_uri, 0, []); S.lift 1 eq_ty; l; r] - in - (bo, (Equality.Step (subst,(Equality.Demodulation, id,(pos,id'), - (Cic.Lambda (name, ty, bo')))))) - in - let newmenv = menv in - let left, right = if is_left then newterm, right else left, newterm in - let ordering = !Utils.compare_terms left right in - let stat = (eq_ty, left, right, ordering) in - let bag, res = - let w = Utils.compute_equality_weight stat in - Equality.mk_equality bag (w, newproof, stat,newmenv) - in - if Utils.debug_metas then - ignore(check_target bag context res "buildnew_target output"); - bag, res - in - let res = - demodulation_aux bag ~from:"from3" metasenv' context ugraph table 0 left - in - if Utils.debug_res then check_res res "demod result"; - let bag, newtarget = - match res with - | Some t -> - let bag, newtarget = build_newtarget bag true t in - (* assert (not (Equality.meta_convertibility_eq target newtarget)); *) - if (Equality.is_weak_identity newtarget) (* || *) - (*Equality.meta_convertibility_eq target newtarget*) then - bag, newtarget - else - demodulation_equality bag ?from eq_uri env table newtarget - | None -> - let res = demodulation_aux bag metasenv' context ugraph table 0 right in - if Utils.debug_res then check_res res "demod result 1"; - match res with - | Some t -> - let bag, newtarget = build_newtarget bag false t in - if (Equality.is_weak_identity newtarget) || - (Equality.meta_convertibility_eq target newtarget) then - bag, newtarget - else - demodulation_equality bag ?from eq_uri env table newtarget - | None -> - bag, target - in - (* newmeta, newtarget *) - bag, 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 - ?(subterms_only=false) metasenv context ugraph table lift_amount term -= - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - - let res, lifted_term = - match term with - | C.Meta (i, l) -> - let l = [] in - 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_left - (fun (res, lifted_tl) arg -> - 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) - ) ([], []) (List.rev 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 candidates = get_candidates Unification table term in - (* List.iter (fun (_,e) -> debug_print (lazy (Equality.string_of_equality e))) candidates; *) - let r = - if subterms_only then - [] - else - find_all_matches - metasenv context ugraph lift_amount term termty candidates - in - r @ res, lifted_term -;; - -(** - 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 bag - ?(subterms_only=false) eq_uri (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 w, eqproof, (eq_ty, left, right, ordering), newmetas,id = - Equality.open_equality target - in - if Utils.debug_metas then - ignore (check_target bag context target "superpositionright"); - let metasenv' = newmetas in - let res1, res2 = - match ordering with - | U.Gt -> - fst (betaexpand_term ~subterms_only metasenv' context ugraph table 0 left), [] - | U.Lt -> - [], fst (betaexpand_term ~subterms_only 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 ~subterms_only metasenv' context ugraph table 0 l)) - in - (res left right), (res right left) - in - let build_new bag ordering (bo, s, m, ug, eq_found) = - if Utils.debug_metas then - ignore (check_target bag context (snd eq_found) "buildnew1" ); - - let pos, equality = eq_found in - let (_, proof', (ty, what, other, _), menv',id') = - Equality.open_equality equality in - let what, other = if pos = Utils.Left then what, other else other, what in - - let ty, eq_ty = apply_subst s ty, apply_subst s eq_ty in - let newgoal, newproof = - (* qua *) - let bo' = - Utils.guarded_simpl context (apply_subst s (S.subst other bo)) - in - let name = C.Name "x" in - 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 (eq_uri, 0, []); S.lift 1 eq_ty; l; r] - in - bo', - Equality.Step - (s,(Equality.SuperpositionRight, - id,(pos,id'),(Cic.Lambda(name,ty,bo'')))) - in - let bag, 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 in - let newmenv = (* Founif.filter s *) m in - let stat = (eq_ty, left, right, neworder) in - let bag, eq' = - let w = Utils.compute_equality_weight stat in - Equality.mk_equality bag (w, newproof, stat, newmenv) in - if Utils.debug_metas then - ignore (check_target bag context eq' "buildnew3"); - let bag, eq' = Equality.fix_metas bag eq' in - if Utils.debug_metas then - ignore (check_target bag context eq' "buildnew4"); - bag, eq' - in - if Utils.debug_metas then - ignore(check_target bag context newequality "buildnew2"); - bag, newequality - in - let bag, new1 = - List.fold_right - (fun x (bag,acc) -> - let bag, e = build_new bag U.Gt x in - bag, e::acc) res1 (bag,[]) - in - let bag, new2 = - List.fold_right - (fun x (bag,acc) -> - let bag, e = build_new bag U.Lt x in - bag, e::acc) res2 (bag,[]) - in - let ok e = not (Equality.is_identity (metasenv', context, ugraph) e) in - bag, List.filter ok (new1 @ new2) -;; - -(** demodulation, when the target is a theorem *) -let rec demodulation_theorem bag env table theorem = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let eq_uri = - match LibraryObjects.eq_URI() with - | Some u -> u - | None -> assert false in - let metasenv, context, ugraph = env in - let proof, theo, metas = theorem in - let build_newtheorem (t, subst, menv, ug, eq_found) = - let pos, equality = eq_found in - let (_, proof', (ty, what, other, _), menv',id) = - Equality.open_equality equality in - let peq = - match proof' with - | Equality.Exact p -> p - | _ -> assert false in - let what, other = - if pos = Utils.Left then what, other else other, what in - let newtheo = apply_subst subst (S.subst other t) in - let name = C.Name "x" in - let body = apply_subst subst t in - let pred = C.Lambda(name,ty,body) in - let newproof = - match pos with - | Utils.Left -> - Equality.mk_eq_ind eq_uri ty what pred proof other peq - | Utils.Right -> - Equality.mk_eq_ind eq_uri ty what pred proof other peq - in - newproof,newtheo - in - let res = demodulation_aux bag metas context ugraph table 0 theo in - match res with - | Some t -> - let newproof, newtheo = build_newtheorem t in - if Equality.meta_convertibility theo newtheo then - newproof, newtheo - else - demodulation_theorem bag env table (newproof,newtheo,[]) - | None -> - proof,theo -;; - -(*****************************************************************************) -(** OPERATIONS ON GOALS **) -(** **) -(** DEMODULATION_GOAL & SUPERPOSITION_LEFT **) -(*****************************************************************************) - -(* new: demodulation of non_equality terms *) -let build_newg bag context goal rule expansion = - let goalproof,_,_ = goal in - let (t,subst,menv,ug,eq_found) = expansion in - let pos, equality = eq_found in - let (_, proof', (ty, what, other, _), menv',id) = - Equality.open_equality equality in - let what, other = if pos = Utils.Left then what, other else other, what in - let newterm, newgoalproof = - let bo = - Utils.guarded_simpl context - (apply_subst subst (CicSubstitution.subst other t)) - in - let name = Cic.Name "x" in - let pred = apply_subst subst (Cic.Lambda (name,ty,t)) in - let newgoalproofstep = (rule,pos,id,subst,pred) in - bo, (newgoalproofstep::goalproof) - in - let newmetasenv = (* Founif.filter subst *) menv in - (newgoalproof, newmetasenv, newterm) -;; - -let rec demod bag env table goal = - let _,menv,t = goal in - let _, context, ugraph = env in - let res = demodulation_aux bag menv context ugraph table 0 t (~typecheck:false)in - match res with - | Some newt -> - let newg = - build_newg bag context goal Equality.Demodulation newt - in - let _,_,newt = newg in - if Equality.meta_convertibility t newt then - false, goal - else - true, snd (demod bag env table newg) - | None -> - false, goal -;; - -let open_goal g = - match g with - | (proof,menv,Cic.Appl[(Cic.MutInd(uri,0,_)) as eq;ty;l;r]) -> - (* assert (LibraryObjects.is_eq_URI uri); *) - proof,menv,eq,ty,l,r - | _ -> assert false - -let ty_of_goal (_,_,ty) = ty ;; - -(* checks if two goals are metaconvertible *) -let goal_metaconvertibility_eq g1 g2 = - Equality.meta_convertibility (ty_of_goal g1) (ty_of_goal g2) -;; - -(* when the betaexpand_term function is called on the left/right side of the - * goal, the predicate has to be fixed - * C[x] ---> (eq ty unchanged C[x]) - * [posu] is the side of the [unchanged] term in the original goal - *) - -let fix_expansion goal posu (t, subst, menv, ug, eq_f) = - let _,_,eq,ty,l,r = open_goal goal in - let unchanged = if posu = Utils.Left then l else r in - let unchanged = CicSubstitution.lift 1 unchanged in - let ty = CicSubstitution.lift 1 ty in - let pred = - match posu with - | Utils.Left -> Cic.Appl [eq;ty;unchanged;t] - | Utils.Right -> Cic.Appl [eq;ty;t;unchanged] - in - (pred, subst, menv, ug, eq_f) -;; - -(* ginve the old [goal], the side that has not changed [posu] and the - * expansion builds a new goal *) -let build_newgoal bag context goal posu rule expansion = - let goalproof,_,_,_,_,_ = open_goal goal in - let (t,subst,menv,ug,eq_found) = fix_expansion goal posu expansion in - let pos, equality = eq_found in - let (_, proof', (ty, what, other, _), menv',id) = - Equality.open_equality equality in - let what, other = if pos = Utils.Left then what, other else other, what in - let newterm, newgoalproof = - let bo = - Utils.guarded_simpl context - (apply_subst subst (CicSubstitution.subst other t)) - in - let name = Cic.Name "x" in - let pred = apply_subst subst (Cic.Lambda (name,ty,t)) in - let newgoalproofstep = (rule,pos,id,subst,pred) in - bo, (newgoalproofstep::goalproof) - in - let newmetasenv = (* Founif.filter subst *) menv in - (newgoalproof, newmetasenv, newterm) -;; - -(** - 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 bag (metasenv, context, ugraph) table goal = - let names = Utils.names_of_context context in - let proof,menv,eq,ty,l,r = open_goal goal in - let c = !Utils.compare_terms l r in - let newgoals = - if c = Utils.Incomparable then - begin - let expansionsl, _ = betaexpand_term menv context ugraph table 0 l in - let expansionsr, _ = betaexpand_term menv context ugraph table 0 r in - (* prerr_endline "incomparable"; - prerr_endline (string_of_int (List.length expansionsl)); - prerr_endline (string_of_int (List.length expansionsr)); - *) - List.map (build_newgoal bag context goal Utils.Right Equality.SuperpositionLeft) expansionsl - @ - List.map (build_newgoal bag context goal Utils.Left Equality.SuperpositionLeft) expansionsr - end - else - match c with - | Utils.Gt -> - let big,small,possmall = l,r,Utils.Right in - let expansions, _ = betaexpand_term menv context ugraph table 0 big in - List.map - (build_newgoal bag context goal possmall Equality.SuperpositionLeft) - expansions - | Utils.Lt -> (* prerr_endline "LT"; *) - let big,small,possmall = r,l,Utils.Left in - let expansions, _ = betaexpand_term menv context ugraph table 0 big in - List.map - (build_newgoal bag context goal possmall Equality.SuperpositionLeft) - expansions - | Utils.Eq -> [] - | _ -> - prerr_endline - ("NOT GT, LT NOR EQ : "^CicPp.pp l names^" - "^CicPp.pp r names); - assert false - in - (* rinfresco le meta *) - List.fold_right - (fun g (b,acc) -> - let b,g = Equality.fix_metas_goal b g in - b,g::acc) - newgoals (bag,[]) -;; - -(** demodulation, when the target is a goal *) -let rec demodulation_goal bag env table goal = - let goalproof,menv,_,_,left,right = open_goal goal in - let _, context, ugraph = env in -(* let term = Utils.guarded_simpl (~debug:true) context term in*) - let do_right () = - let resright = demodulation_aux bag menv context ugraph table 0 right in - match resright with - | Some t -> - let newg = - build_newgoal bag context goal Utils.Left Equality.Demodulation t - in - if goal_metaconvertibility_eq goal newg then - false, goal - else - true, snd (demodulation_goal bag env table newg) - | None -> false, goal - in - let resleft = demodulation_aux bag menv context ugraph table 0 left in - match resleft with - | Some t -> - let newg = build_newgoal bag context goal Utils.Right Equality.Demodulation t in - if goal_metaconvertibility_eq goal newg then - do_right () - else - true, snd (demodulation_goal bag env table newg) - | None -> do_right () -;; - -(* returns all the 1 step demodulations *) -module C = Cic;; -module S = CicSubstitution;; - -let rec demodulation_all_aux - metasenv context ugraph table lift_amount term -= - let candidates = - get_candidates ~env:(metasenv,context,ugraph) Matching table term - in - match term with - | C.Meta _ -> [] - | _ -> - let termty, ugraph = C.Implicit None, ugraph in - let res = - find_all_matches - ~unif_fun:Founif.matching ~demod:true - metasenv context ugraph lift_amount term termty candidates - in - match term with - | C.Appl l -> - let res, _, _, _ = - List.fold_left - (fun (res,b,l,r) t -> - if not b then res,b,l,r - else - let demods_for_t = - demodulation_all_aux - metasenv context ugraph table lift_amount t - in - let b = demods_for_t = [] in - res @ - List.map - (fun (rel, s, m, ug, c) -> - (Cic.Appl (l@[rel]@List.tl r), s, m, ug, c)) - demods_for_t, b, l@[List.hd r], List.tl r) - (res, true, [], List.map (S.lift 1) l) l - in - res - | t -> res -;; - -let demod_all steps bag env table goal = - let _, context, ugraph = env in - let is_visited l (_,_,t) = - List.exists (fun (_,_,s) -> Equality.meta_convertibility s t) l - in - let rec aux steps visited nf bag = function - | _ when steps = 0 -> visited, bag, nf - | [] -> visited, bag, nf - | goal :: rest when is_visited visited goal-> aux steps visited nf bag rest - | goal :: rest -> - let visited = goal :: visited in - let _,menv,t = goal in - let res = demodulation_all_aux menv context ugraph table 0 t in - let steps = if res = [] then steps-1 else steps in - let new_goals = - List.map (build_newg bag context goal Equality.Demodulation) res - in - let nf = if new_goals = [] then goal :: nf else nf in - aux steps visited nf bag (new_goals @ rest) - in - aux steps [] [] bag [goal] -;; - -let combine_demodulation_proofs bag env goal (pl,ml,l) (pr,mr,r) = - let proof,m,eq,ty,left,right = open_goal goal in - let pl = - List.map - (fun (rule,pos,id,subst,pred) -> - let pred = - match pred with - | Cic.Lambda (name,src,tgt) -> - Cic.Lambda (name,src, - Cic.Appl[eq;ty;tgt;CicSubstitution.lift 1 right]) - | _ -> assert false - in - rule,pos,id,subst,pred) - pl - in - let pr = - List.map - (fun (rule,pos,id,subst,pred) -> - let pred = - match pred with - | Cic.Lambda (name,src,tgt) -> - Cic.Lambda (name,src, - Cic.Appl[eq;ty;CicSubstitution.lift 1 l;tgt]) - | _ -> assert false - in - rule,pos,id,subst,pred) - pr - in - (pr@pl@proof, m, Cic.Appl [eq;ty;l;r]) -;; - -let demodulation_all_goal bag env table goal maxnf = - let proof,menv,eq,ty,left,right = open_goal goal in - let v1, bag, l_demod = demod_all maxnf bag env table ([],menv,left) in - let v2, bag, r_demod = demod_all maxnf bag env table ([],menv,right) in - let l_demod = if l_demod = [] then [ [], menv, left ] else l_demod in - let r_demod = if r_demod = [] then [ [], menv, right ] else r_demod in - List.fold_left - (fun acc (_,_,l as ld) -> - List.fold_left - (fun acc (_,_,r as rd) -> - combine_demodulation_proofs bag env goal ld rd :: acc) - acc r_demod) - [] l_demod -;; - -let solve_demodulating bag env table initgoal steps = - let proof,menv,eq,ty,left,right = open_goal initgoal in - let uri = - match eq with - | Cic.MutInd (u,_,_) -> u - | _ -> assert false - in - let _, context, ugraph = env in - let v1, bag, l_demod = demod_all steps bag env table ([],menv,left) in - let v2, bag, r_demod = demod_all steps bag env table ([],menv,right) in - let is_solved left right ml mr = - let m = ml @ (List.filter - (fun (x,_,_) -> not (List.exists (fun (y,_,_) -> x=y)ml)) mr) - in - try - let s,_,_ = - Founif.unification [] m context left right CicUniv.empty_ugraph in - Some (bag, m,s,Equality.Exact (Equality.refl_proof uri ty left)) - with CicUnification.UnificationFailure _ -> - let solutions = - unification_all env table (Equality.mk_tmp_equality - (0,(Cic.Implicit None,left,right,Utils.Incomparable),m)) - in - if solutions = [] then None - else - let s, e, swapped = List.hd solutions in - let _,p,(ty,l,r,_),me,id = Equality.open_equality e in - let bag, p = - if swapped then Equality.symmetric bag ty l id uri me else bag, p - in - Some (bag, m,s, p) - in - let newgoal = - HExtlib.list_findopt - (fun (pr,mr,r) _ -> - try - let pl,ml,l,bag,m,s,p = - match - HExtlib.list_findopt (fun (pl,ml,l) _ -> - match is_solved l r ml mr with - | None -> None - | Some (bag,m,s,p) -> Some (pl,ml,l,bag,m,s,p) - ) l_demod - with Some x -> x | _ -> raise Not_found - in - let pl = - List.map - (fun (rule,pos,id,subst,pred) -> - let pred = - match pred with - | Cic.Lambda (name,src,tgt) -> - Cic.Lambda (name,src, - Cic.Appl[eq;ty;tgt;CicSubstitution.lift 1 right]) - | _ -> assert false - in - rule,pos,id,subst,pred) - pl - in - let pr = - List.map - (fun (rule,pos,id,subst,pred) -> - let pred = - match pred with - | Cic.Lambda (name,src,tgt) -> - Cic.Lambda (name,src, - Cic.Appl[eq;ty;CicSubstitution.lift 1 l;tgt]) - | _ -> assert false - in - rule,pos,id,subst,pred) - pr - in - Some (bag,pr@pl@proof,m,s,p) - with Not_found -> None) - r_demod - in - newgoal -;; - - - diff --git a/matita/components/tactics/paramodulation/indexing.mli b/matita/components/tactics/paramodulation/indexing.mli deleted file mode 100644 index 06d1ada3f..000000000 --- a/matita/components/tactics/paramodulation/indexing.mli +++ /dev/null @@ -1,122 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -module Index : - sig - module PosEqSet : Set.S - with type elt = Utils.pos * Equality.equality - and type t = Equality_indexing.DT.PosEqSet.t - type t = - Discrimination_tree.Make(Cic_indexable.CicIndexable)(PosEqSet).t - end - -val check_for_duplicates : Cic.metasenv -> string -> unit -val index : Index.t -> Equality.equality -> Index.t -val remove_index : Index.t -> Equality.equality -> Index.t -val in_index : Index.t -> Equality.equality -> bool -val empty : Index.t -val init_index : unit -> unit -val unification : - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Equality.equality -> - (Subst.substitution * Equality.equality * bool) option -val subsumption : - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Equality.equality -> - (Subst.substitution * Equality.equality * bool) option -val unification_all : - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Equality.equality -> - (Subst.substitution * Equality.equality * bool) list -val subsumption_all : - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Equality.equality -> - (Subst.substitution * Equality.equality * bool) list -val superposition_left : - Equality.equality_bag -> - Cic.conjecture list * Cic.context * CicUniv.universe_graph -> - Index.t -> Equality.goal -> - Equality.equality_bag * Equality.goal list - -val superposition_right : - Equality.equality_bag -> - ?subterms_only:bool -> - UriManager.uri -> - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Equality.equality -> - Equality.equality_bag * Equality.equality list - -val demod : - Equality.equality_bag -> - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Equality.goal -> - bool * Equality.goal -val demodulation_equality : - Equality.equality_bag -> - ?from:string -> - UriManager.uri -> - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Equality.equality -> Equality.equality_bag * Equality.equality -val demodulation_goal : - Equality.equality_bag -> - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Equality.goal -> - bool * Equality.goal -val demodulation_all_goal : - Equality.equality_bag -> - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Equality.goal -> int -> - Equality.goal list -val demodulation_theorem : - Equality.equality_bag -> - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Cic.term * Cic.term * Cic.metasenv - -> Cic.term * Cic.term - -val check_target: - Equality.equality_bag -> - Cic.context -> - Equality.equality -> string -> unit -val solve_demodulating: - Equality.equality_bag -> - Cic.metasenv * Cic.context * CicUniv.universe_graph -> - Index.t -> - Equality.goal -> - int -> - (Equality.equality_bag * Equality.goal_proof * Cic.metasenv * - Subst.substitution * Equality.proof) option - diff --git a/matita/components/tactics/paramodulation/saturation.ml b/matita/components/tactics/paramodulation/saturation.ml deleted file mode 100644 index c5f3132e9..000000000 --- a/matita/components/tactics/paramodulation/saturation.ml +++ /dev/null @@ -1,1738 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* let _profiler = <:profiler<_profiler>>;; *) - -(* $Id$ *) - -(* set to false to disable paramodulation inside auto_tac *) - -let fst3 a,_,_ = a;; -let last _,_,a = a;; - -let connect_to_auto = true;; - -let debug_print = Utils.debug_print;; - -(* 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 6 (* 5 *);; (* 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;; - -(* varbiables controlling the search-space *) -let maxdepth = ref 3;; -let maxwidth = ref 3;; - -type theorem = Cic.term * Cic.term * Cic.metasenv;; - -let symbols_of_equality equality = - let (_, _, (_, left, right, _), _,_) = Equality.open_equality equality in - let m1 = Utils.symbols_of_term left in - let m = - Utils.TermMap.fold - (fun k v res -> - try - let c = Utils.TermMap.find k res in - Utils.TermMap.add k (c+v) res - with Not_found -> - Utils.TermMap.add k v res) - (Utils.symbols_of_term right) m1 - in - m -;; - -(* griggio *) -module OrderedEquality = struct - type t = Equality.equality - - let compare eq1 eq2 = - match Equality.meta_convertibility_eq eq1 eq2 with - | true -> 0 - | false -> - let w1, _, (ty,left, right, _), m1,_ = Equality.open_equality eq1 in - let w2, _, (ty',left', right', _), m2,_ = Equality.open_equality eq2 in - match Pervasives.compare w1 w2 with - | 0 -> - let res = (List.length m1) - (List.length m2) in - if res <> 0 then res else - Equality.compare eq1 eq2 - | res -> res -end - -module EqualitySet = Set.Make(OrderedEquality);; - -type passive_table = Equality.equality list * EqualitySet.t * Indexing.Index.t -type active_table = Equality.equality list * Indexing.Index.t -type new_proof = - Equality.goal_proof * Equality.proof * int * Subst.substitution * Cic.metasenv -type result = - | ParamodulationFailure of - string * active_table * passive_table * Equality.equality_bag - | ParamodulationSuccess of - new_proof * active_table * passive_table * Equality.equality_bag -;; - -let list_of_passive (l,_,_) = l ;; -let list_of_active (l,_) = l ;; - -let make_passive eq_list = - let set = - List.fold_left (fun s e -> EqualitySet.add e s) EqualitySet.empty eq_list - in - (* we have the invariant that the list and the set have the same - * cardinality *) - EqualitySet.elements set, set, - List.fold_left Indexing.index Indexing.empty eq_list -;; - -let make_empty_active () = [], Indexing.empty ;; -let make_active eq_list = - eq_list, List.fold_left Indexing.index Indexing.empty eq_list -;; - -let size_of_passive (passive_list, _,_) = List.length passive_list;; -let size_of_active (active_list, _) = List.length active_list;; - -let passive_is_empty = function - | [], s , _ when EqualitySet.is_empty s -> true - | [], s ,_ -> assert false (* the set and the list should be in sync *) - | _ -> false -;; - -type goals = Equality.goal list * Equality.goal list - -let no_more_passive_goals g = match g with | _,[] -> true | _ -> false;; - - -let age_factor = 0.01;; - -(** - selects one equality from passive. The selection strategy is a combination - of weight, age and goal-similarity -*) - -let rec select env g passive = - processed_clauses := !processed_clauses + 1; -(* - let goal = - match (List.rev goals) with goal::_ -> goal | _ -> assert false - in -*) - let pos_list, pos_set, pos_table = passive in - let remove eq l = List.filter (fun e -> Equality.compare e eq <> 0) 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; - let skip_giant pos_list pos_set pos_table = - match pos_list with - | (hd:EqualitySet.elt)::tl -> - let w,_,_,_,_ = Equality.open_equality hd in - if w < 30 then - hd, (tl, EqualitySet.remove hd pos_set, - Indexing.remove_index pos_table hd) - else -(* - (prerr_endline - ("+++ skipping giant of size "^string_of_int w^" +++"); -*) - select env g (tl@[hd],pos_set,pos_table) - | _ -> assert false - in - skip_giant pos_list pos_set pos_table) - -(* - let rec skip_giant pos_list pos_set = - match pos_list with - | (hd:EqualitySet.elt)::tl -> - let w,_,_,_,_ = Equality.open_equality hd in - let pos_set = EqualitySet.remove hd pos_set in - if w < 30 then - hd, (tl, pos_set) - else - (prerr_endline - ("+++ skipping giant of size "^string_of_int w^" +++"); - skip_giant tl pos_set) - | _ -> assert false - in - skip_giant pos_list pos_set) - -*) -(* - | _ when (!symbols_counter > 0) -> - (symbols_counter := !symbols_counter - 1; - let cardinality map = - Utils.TermMap.fold (fun k v res -> res + v) map 0 - in - let symbols = - let _, _, term = goal in - Utils.symbols_of_term term - in - let card = cardinality symbols in - let foldfun k v (r1, r2) = - if Utils.TermMap.mem k symbols then - let c = Utils.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 = - Utils.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 = - Utils.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 - current, - (remove current pos_list, EqualitySet.remove current pos_set)) -*) - | _ -> - symbols_counter := !symbols_ratio; - let my_min e1 e2 = - let w1,_,_,_,_ = Equality.open_equality e1 in - let w2,_,_,_,_ = Equality.open_equality e2 in - if w1 < w2 then e1 else e2 - in - let rec my_min_elt min = function - | [] -> min - | hd::tl -> my_min_elt (my_min hd min) tl - in -(* let current = EqualitySet.min_elt pos_set in *) - let current = my_min_elt (List.hd pos_list) (List.tl pos_list) in - current,(remove current pos_list, EqualitySet.remove current pos_set, - Indexing.remove_index pos_table current) -;; - - -let filter_dependent bag passive id = - let pos_list, pos_set, pos_table = passive in - let passive,no_pruned = - List.fold_right - (fun eq ((list,set,table),no) -> - if Equality.depend bag eq id then - (list, EqualitySet.remove eq set,Indexing.remove_index table eq), - no + 1 - else - (eq::list,set,table), no) - pos_list (([],pos_set,pos_table),0) - in -(* - if no_pruned > 0 then - prerr_endline ("+++ pruning "^ string_of_int no_pruned ^" passives +++"); -*) - passive -;; - - -(* adds to passive a list of equalities new_pos *) -let add_to_passive passive new_pos preferred = - let pos_list, pos_set , pos_table = passive in - let ok set equality = not (EqualitySet.mem equality set) in - let pos = List.filter (ok pos_set) new_pos in - let add set equalities = - List.fold_left (fun s e -> EqualitySet.add e s) set equalities - in - let pos_head, pos_tail = - List.partition - (fun e -> List.exists (fun x -> Equality.compare x e = 0) preferred) - pos - in - pos_head @ pos_list @ pos_tail, add pos_set pos, - List.fold_left Indexing.index pos_table pos -;; - -(* TODO *) -(* removes from passive equalities that are estimated impossible to activate - within the current time limit *) -let prune_passive howmany (active, _) passive = - let (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 - Utils.debug_print - (lazy (Printf.sprintf "in_weight: %d, in_age: %d\n" in_weight in_age)); - let counter = ref !symbols_ratio in - let rec pickw w ps = - if w > 0 then - if !counter > 0 then - let _ = - counter := !counter - 1; - if !counter = 0 then counter := !symbols_ratio in - let e = EqualitySet.min_elt ps in - let ps' = pickw (w-1) (EqualitySet.remove e ps) in - EqualitySet.add e ps' - else - let e = EqualitySet.min_elt ps in - let ps' = pickw (w-1) (EqualitySet.remove e ps) in - EqualitySet.add e ps' - else - EqualitySet.empty - in - let ps = pickw in_weight 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 _, 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 - (pl, ps), tbl -;; - - -(** inference of new equalities between current and some in active *) -let infer bag eq_uri env current (active_list, active_table) = - let (_,c,_) = env in - if Utils.debug_metas then - (ignore(Indexing.check_target bag c current "infer1"); - ignore(List.map (function current -> Indexing.check_target bag c current "infer2") active_list)); - let bag, new_pos = - let bag, copy_of_current = Equality.fix_metas bag current in - let active_table = Indexing.index active_table copy_of_current in -(* let _ = <:start> in *) - let bag, res = - Indexing.superposition_right bag eq_uri env active_table current - in -(* let _ = <:stop> in *) - if Utils.debug_metas then - ignore(List.map - (function current -> - Indexing.check_target bag c current "sup0") res); - let rec infer_positive bag table = function - | [] -> bag, [] - | equality::tl -> - let bag, res = - Indexing.superposition_right bag - ~subterms_only:true eq_uri env table equality - in - if Utils.debug_metas then - ignore - (List.map - (function current -> - Indexing.check_target bag c current "sup2") res); - let bag, pos = infer_positive bag table tl in - bag, res @ pos - in - let curr_table = Indexing.index Indexing.empty current in - let bag, pos = infer_positive bag curr_table ((*copy_of_current::*)active_list) in - if Utils.debug_metas then - ignore(List.map - (function current -> - Indexing.check_target bag c current "sup3") pos); - bag, res @ pos - in - derived_clauses := !derived_clauses + (List.length new_pos); - match !maximal_retained_equality with - | None -> bag, new_pos - | Some eq -> - ignore(assert false); - (* 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 *) - bag, List.filter (fun e -> OrderedEquality.compare e eq <= 0) new_pos -;; - -let check_for_deep_subsumption env active_table eq = - let _,_,(eq_ty, left, right, order),metas,id = Equality.open_equality eq in - let check_subsumed deep l r = - let eqtmp = - Equality.mk_tmp_equality(0,(eq_ty,l,r,Utils.Incomparable),metas)in - match Indexing.subsumption env active_table eqtmp with - | None -> false - | Some _ -> true - in - let rec aux b (ok_so_far, subsumption_used) t1 t2 = - match t1,t2 with - | t1, t2 when not ok_so_far -> ok_so_far, subsumption_used - | t1, t2 when subsumption_used -> t1 = t2, subsumption_used - | Cic.Appl (h1::l),Cic.Appl (h2::l') -> - let rc = check_subsumed b t1 t2 in - if rc then - true, true - else if h1 = h2 then - (try - List.fold_left2 - (fun (ok_so_far, subsumption_used) t t' -> - aux true (ok_so_far, subsumption_used) t t') - (ok_so_far, subsumption_used) l l' - with Invalid_argument _ -> false,subsumption_used) - else - false, subsumption_used - | _ -> false, subsumption_used - in - fst (aux false (true,false) left right) -;; - -(** simplifies current using active and passive *) -let forward_simplify bag eq_uri env current (active_list, active_table) = - let _, context, _ = env in - let demodulate bag table current = - let bag, newcurrent = - Indexing.demodulation_equality bag eq_uri env table current - in - bag, if Equality.is_identity env newcurrent then None else Some newcurrent - in - let demod bag current = - if Utils.debug_metas then - ignore (Indexing.check_target bag context current "demod0"); - let bag, res = demodulate bag active_table current in - if Utils.debug_metas then - ignore ((function None -> () | Some x -> - ignore (Indexing.check_target bag context x "demod1");()) res); - bag, res - in - let bag, res = demod bag current in - match res with - | None -> bag, None - | Some c -> - if Indexing.in_index active_table c || - check_for_deep_subsumption env active_table c - then - bag, None - else - bag, res -;; - -(** simplifies new using active and passive *) -let forward_simplify_new bag eq_uri env new_pos active = - if Utils.debug_metas then - begin - let m,c,u = env in - ignore(List.map - (fun current -> Indexing.check_target bag c current "forward new pos") - new_pos;) - end; - let active_list, active_table = active in - let demodulate bag table target = - let bag, newtarget = - Indexing.demodulation_equality bag eq_uri env table target - in - bag, newtarget - in - (* we could also demodulate using passive. Currently we don't *) - let bag, new_pos = - List.fold_right (fun x (bag,acc) -> - let bag, y = demodulate bag active_table x in - bag, y::acc) - new_pos (bag,[]) - in - let new_pos_set = - List.fold_left - (fun s e -> - if not (Equality.is_identity env e) then - EqualitySet.add e s - else s) - EqualitySet.empty new_pos - in - let new_pos = EqualitySet.elements new_pos_set in - let subs e = Indexing.subsumption env active_table e = None in - let is_duplicate e = not (Indexing.in_index active_table e) in - bag, List.filter subs (List.filter is_duplicate new_pos) -;; - - -(** simplifies a goal with equalities in active and passive *) -let rec simplify_goal bag env goal (active_list, active_table) = - let demodulate table goal = Indexing.demodulation_goal bag env table goal in - let changed, goal = demodulate active_table goal in - changed, - if not changed then - goal - else - snd (simplify_goal bag env goal (active_list, active_table)) -;; - - -let simplify_goals bag env goals active = - let a_goals, p_goals = goals in - let p_goals = List.map (fun g -> snd (simplify_goal bag env g active)) p_goals in - let a_goals = List.map (fun g -> snd (simplify_goal bag env g active)) a_goals in - a_goals, p_goals -;; - - -(** simplifies active usign new *) -let backward_simplify_active - bag eq_uri env new_pos new_table min_weight active -= - let active_list, active_table = active in - let bag, active_list, newa, pruned = - List.fold_right - (fun equality (bag, res, newn,pruned) -> - let ew, _, _, _,id = Equality.open_equality equality in - if ew < min_weight then - bag, equality::res, newn,pruned - else - match - forward_simplify bag eq_uri env equality (new_pos, new_table) - with - | bag, None -> bag, res, newn, id::pruned - | bag, Some e -> - if Equality.compare equality e = 0 then - bag, e::res, newn, pruned - else - bag, res, e::newn, pruned) - active_list (bag, [], [],[]) - in - let find eq1 where = - List.exists (Equality.meta_convertibility_eq eq1) where - in - let id_of_eq eq = - let _, _, _, _,id = Equality.open_equality eq in id - in - let ((active1,pruned),tbl), newa = - List.fold_right - (fun eq ((res,pruned), tbl) -> - if List.mem eq res then - (res, (id_of_eq eq)::pruned),tbl - else if (Equality.is_identity env eq) || (find eq res) then ( - (res, (id_of_eq eq)::pruned),tbl - ) - else - (eq::res,pruned), Indexing.index tbl eq) - active_list (([],pruned), Indexing.empty), - List.fold_right - (fun eq p -> - if (Equality.is_identity env eq) then p - else eq::p) - newa [] - in - match newa with - | [] -> bag, (active1,tbl), None, pruned - | _ -> bag, (active1,tbl), Some newa, pruned -;; - - -(** simplifies passive using new *) -let backward_simplify_passive - bag eq_uri env new_pos new_table min_weight passive -= - let (pl, ps), passive_table = passive in - let f bag equality (resl, ress, newn) = - let ew, _, _, _ , _ = Equality.open_equality equality in - if ew < min_weight then - bag, (equality::resl, ress, newn) - else - match - forward_simplify bag eq_uri env equality (new_pos, new_table) - with - | bag, None -> - bag, (resl, EqualitySet.remove equality ress, newn) - | bag, Some e -> - if equality = e then - bag, (equality::resl, ress, newn) - else - let ress = EqualitySet.remove equality ress in - bag, (resl, ress, e::newn) - in - let bag, (pl, ps, newp) = - List.fold_right (fun x (bag,acc) -> f bag x acc) pl (bag,([], ps, [])) in - let passive_table = - List.fold_left - (fun tbl e -> Indexing.index tbl e) Indexing.empty pl - in - match newp with - | [] -> bag, ((pl, ps), passive_table), None - | _ -> bag, ((pl, ps), passive_table), Some (newp) -;; - -let build_table equations = - List.fold_left - (fun (l, t, w) e -> - let ew, _, _, _ , _ = Equality.open_equality e in - e::l, Indexing.index t e, min ew w) - ([], Indexing.empty, 1000000) equations -;; - - -let backward_simplify bag eq_uri env new' active = - let new_pos, new_table, min_weight = build_table new' in - let bag, active, newa, pruned = - backward_simplify_active bag eq_uri env new_pos new_table min_weight active - in - bag, active, newa, pruned -;; - -let close bag eq_uri env new' given = - let new_pos, new_table, min_weight = - List.fold_left - (fun (l, t, w) e -> - let ew, _, _, _ , _ = Equality.open_equality e in - e::l, Indexing.index t e, min ew w) - ([], Indexing.empty, 1000000) (snd new') - in - List.fold_left - (fun (bag,p) c -> - let bag, pos = infer bag eq_uri env c (new_pos,new_table) in - bag, pos@p) - (bag,[]) given -;; - -let is_commutative_law eq = - let w, proof, (eq_ty, left, right, order), metas , _ = - Equality.open_equality eq - in - match left,right with - Cic.Appl[f1;Cic.Meta _ as a1;Cic.Meta _ as b1], - Cic.Appl[f2;Cic.Meta _ as a2;Cic.Meta _ as b2] -> - f1 = f2 && a1 = b2 && a2 = b1 - | _ -> false -;; - -let prova bag eq_uri env new' active = - let given = List.filter is_commutative_law (fst active) in - let _ = - Utils.debug_print - (lazy - (Printf.sprintf "symmetric:\n%s\n" - (String.concat "\n" - (List.map - (fun e -> Equality.string_of_equality ~env e) - given)))) in - close bag eq_uri env new' given -;; - -(* 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 -;; - -let make_goal_set goal = - ([],[goal]) -;; - -(** initializes the set of theorems *) -let make_theorems theorems = - theorems, [] -;; - - -let activate_goal (active, passive) = - if active = [] then - match passive with - | goal_conj::tl -> true, (goal_conj::active, tl) - | [] -> false, (active, passive) - else - true, (active,passive) -;; - - -let activate_theorem (active, passive) = - match passive with - | theorem::tl -> true, (theorem::active, tl) - | [] -> false, (active, passive) -;; - -let rec simpl bag eq_uri env e others others_simpl = - let active = others @ others_simpl in - let tbl = - List.fold_left - (fun t e -> - if Equality.is_identity env e then t else Indexing.index t e) - Indexing.empty active - in - let bag, res = - forward_simplify bag eq_uri env e (active, tbl) - in - match others with - | hd::tl -> ( - match res with - | None -> simpl bag eq_uri env hd tl others_simpl - | Some e -> simpl bag eq_uri env hd tl (e::others_simpl) - ) - | [] -> ( - match res with - | None -> bag, others_simpl - | Some e -> bag, e::others_simpl - ) -;; - -let simplify_equalities bag eq_uri env equalities = - Utils.debug_print - (lazy - (Printf.sprintf "equalities:\n%s\n" - (String.concat "\n" - (List.map Equality.string_of_equality equalities)))); -Utils.debug_print (lazy "SIMPLYFYING EQUALITIES..."); - match equalities with - | [] -> bag, [] - | hd::tl -> - let bag, res = simpl bag eq_uri env hd tl [] in - let res = List.rev res in - Utils.debug_print - (lazy - (Printf.sprintf "equalities AFTER:\n%s\n" - (String.concat "\n" - (List.map Equality.string_of_equality res)))); - bag, res -;; - -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)) -;; - -let pp_goal_set msg goals names = - let active_goals, passive_goals = goals in - debug_print (lazy ("////" ^ msg)); - debug_print (lazy ("ACTIVE G: " ^ - (String.concat "\n " (List.map (fun (_,_,g) -> CicPp.pp g names) - active_goals)))); - debug_print (lazy ("PASSIVE G: " ^ - (String.concat "\n " (List.map (fun (_,_,g) -> CicPp.pp g names) - passive_goals)))) -;; - -let check_if_goal_is_subsumed bag ((_,ctx,_) as env) table (goalproof,menv,ty) = -(* let names = Utils.names_of_context ctx in *) - match ty with - | Cic.Appl[Cic.MutInd(uri,_,_);eq_ty;left;right] - when LibraryObjects.is_eq_URI uri -> - (let bag, goal_equation = - Equality.mk_equality bag - (0,Equality.Exact (Cic.Implicit None),(eq_ty,left,right,Utils.Eq),menv) - in - (* match Indexing.subsumption env table goal_equation with *) - match Indexing.unification env table goal_equation with - | Some (subst, equality, swapped ) -> -(* - prerr_endline - ("GOAL SUBSUMED IS: "^Equality.string_of_equality goal_equation ~env); - prerr_endline - ("GOAL IS SUBSUMED BY: "^Equality.string_of_equality equality ~env); - prerr_endline ("SUBST:"^Subst.ppsubst ~names subst); -*) - let (_,p,(ty,l,r,_),m,id) = Equality.open_equality equality in - let cicmenv = Subst.apply_subst_metasenv subst (m @ menv) in - let bag, p = - if swapped then - Equality.symmetric bag eq_ty l id uri m - else - bag, p - in - bag, Some (goalproof, p, id, subst, cicmenv) - | None -> - bag, None) - | _ -> bag, None -;; - -let find_all_subsumed bag env table (goalproof,menv,ty) = - match ty with - | Cic.Appl[Cic.MutInd(uri,_,_);eq_ty;left;right] - when LibraryObjects.is_eq_URI uri -> - let bag, goal_equation = - (Equality.mk_equality bag - (0,Equality.Exact (Cic.Implicit None),(eq_ty,left,right,Utils.Eq),menv)) - in - List.fold_right - (fun (subst, equality, swapped) (bag,acc) -> - let (_,p,(ty,l,r,_),m,id) = Equality.open_equality equality in - let cicmenv = Subst.apply_subst_metasenv subst (m @ menv) in - if Utils.debug_metas then - Indexing.check_for_duplicates cicmenv "from subsumption"; - let bag, p = - if swapped then - Equality.symmetric bag eq_ty l id uri m - else - bag, p - in - bag, (goalproof, p, id, subst, cicmenv)::acc) - (Indexing.subsumption_all env table goal_equation) (bag,[]) - (* (Indexing.unification_all env table goal_equation) *) - | _ -> assert false -;; - - -let check_if_goal_is_identity env = function - | (goalproof,m,Cic.Appl[Cic.MutInd(uri,_,ens);eq_ty;left;right]) - when left = right && LibraryObjects.is_eq_URI uri -> - let reflproof = Equality.Exact (Equality.refl_proof uri eq_ty left) in - Some (goalproof, reflproof, 0, Subst.empty_subst,m) - | (goalproof,m,Cic.Appl[Cic.MutInd(uri,_,ens);eq_ty;left;right]) - when LibraryObjects.is_eq_URI uri -> - (let _,context,_ = env in - try - let s,m,_ = - Founif.unification [] m context left right CicUniv.empty_ugraph - in - let reflproof = Equality.Exact (Equality.refl_proof uri eq_ty left) in - let m = Subst.apply_subst_metasenv s m in - Some (goalproof, reflproof, 0, s,m) - with CicUnification.UnificationFailure _ -> None) - | _ -> None -;; - -let rec check b goal = function - | [] -> b, None - | f::tl -> - match f b goal with - | b, None -> check b goal tl - | b, (Some _ as ok) -> b, ok -;; - -let simplify_goal_set bag env goals active = - let active_goals, passive_goals = goals in - let find (_,_,g) where = - List.exists (fun (_,_,g1) -> Equality.meta_convertibility g g1) where - in - (* prova:tengo le passive semplificate - let passive_goals = - List.map (fun g -> snd (simplify_goal env g active)) passive_goals - in *) - List.fold_left - (fun (acc_a,acc_p) goal -> - match simplify_goal bag env goal active with - | changed, g -> - if changed then - if find g acc_p then acc_a,acc_p else acc_a,g::acc_p - else - if find g acc_a then acc_a,acc_p else g::acc_a,acc_p) - ([],passive_goals) active_goals -;; - -let check_if_goals_set_is_solved bag env active passive goals = - let active_goals, passive_goals = goals in - List.fold_left - (fun (bag, proof) goal -> - match proof with - | Some p -> bag, proof - | None -> - check bag goal [ - (fun b x -> b, check_if_goal_is_identity env x); - (fun bag -> check_if_goal_is_subsumed bag env (snd active)); - (fun bag -> check_if_goal_is_subsumed bag env (last passive)) - ]) - (bag,None) (active_goals @ passive_goals) -;; - -let infer_goal_set bag env active goals = - let active_goals, passive_goals = goals in - let rec aux bag = function - | [] -> bag, (active_goals, []) - | hd::tl -> - let changed, selected = simplify_goal bag env hd active in - let (_,m1,t1) = selected in - let already_in = - List.exists (fun (_,_,t) -> Equality.meta_convertibility t t1) - active_goals - in - if already_in then - aux bag tl - else - let passive_goals = tl in - let bag, new_passive_goals = - if Utils.metas_of_term t1 = [] then - bag, passive_goals - else - let bag, new' = - Indexing.superposition_left bag env (snd active) selected - in - bag, passive_goals @ new' - in - bag, (selected::active_goals, new_passive_goals) - in - aux bag passive_goals -;; - -let infer_goal_set_with_current bag env current goals active = - let active_goals, passive_goals = simplify_goal_set bag env goals active in - let l,table,_ = build_table [current] in - let bag, passive_goals = - List.fold_left - (fun (bag, acc) g -> - let bag, new' = Indexing.superposition_left bag env table g in - bag, acc @ new') - (bag, passive_goals) active_goals - in - bag, active_goals, passive_goals -;; - -let ids_of_goal g = - let p,_,_ = g in - let ids = List.map (fun _,_,i,_,_ -> i) p in - ids -;; - -let ids_of_goal_set (ga,gp) = - List.flatten (List.map ids_of_goal ga) @ - List.flatten (List.map ids_of_goal gp) -;; - -let size_of_goal_set_a (l,_) = List.length l;; -let size_of_goal_set_p (_,l) = List.length l;; - -let pp_goals label goals context = - let names = Utils.names_of_context context in - List.iter - (fun _,_,g -> - debug_print (lazy - (Printf.sprintf "Current goal: %s = %s\n" label (CicPp.pp g names)))) - (fst goals); - List.iter - (fun _,_,g -> - debug_print (lazy - (Printf.sprintf "PASSIVE goal: %s = %s\n" label (CicPp.pp g names)))) - (snd goals); -;; - -let print_status iterno goals active passive = - debug_print (lazy - (Printf.sprintf "\n%d #ACTIVES: %d #PASSIVES: %d #GOALSET: %d(%d)" - iterno (size_of_active active) (size_of_passive passive) - (size_of_goal_set_a goals) (size_of_goal_set_p goals))) -;; - -let add_to_active_aux bag active passive env eq_uri current = - debug_print (lazy ("Adding to actives : " ^ - Equality.string_of_equality ~env current)); - match forward_simplify bag eq_uri env current active with - | bag, None -> None, active, passive, bag - | bag, Some current -> - let bag, new' = infer bag eq_uri env current active in - let active = - let al, tbl = active in - al @ [current], Indexing.index tbl current - in - let rec simplify bag new' active passive = - let bag, new' = - forward_simplify_new bag eq_uri env new' active - in - let bag, active, newa, pruned = - backward_simplify bag eq_uri env new' active - in - let passive = - List.fold_left (filter_dependent bag) passive pruned - in - match newa with - | None -> bag, active, passive, new' - | Some p -> simplify bag (new' @ p) active passive - in - let bag, active, passive, new' = - simplify bag new' active passive - in - let passive = add_to_passive passive new' [] in - Some new', active, passive, bag -;; - -(** given-clause algorithm with full reduction strategy: NEW implementation *) -(* here goals is a set of goals in OR *) -let given_clause - bag eq_uri ((_,context,_) as env) goals passive active - goal_steps saturation_steps max_time -= - let initial_time = Unix.gettimeofday () in - let iterations_left iterno = - let now = Unix.gettimeofday () in - let time_left = max_time -. now in - let time_spent_until_now = now -. initial_time in - let iteration_medium_cost = - time_spent_until_now /. (float_of_int iterno) - in - let iterations_left = time_left /. iteration_medium_cost in - int_of_float iterations_left - in - let rec step bag goals passive active g_iterno s_iterno = - if g_iterno > goal_steps && s_iterno > saturation_steps then - (ParamodulationFailure ("No more iterations to spend",active,passive,bag)) - else if Unix.gettimeofday () > max_time then - (ParamodulationFailure ("No more time to spend",active,passive,bag)) - else - let _ = - print_status (max g_iterno s_iterno) goals active passive -(* Printf.eprintf ".%!"; *) - in - (* PRUNING OF PASSIVE THAT WILL NEVER BE PROCESSED *) - let passive = - let selection_estimate = iterations_left (max g_iterno s_iterno) in - let kept = size_of_passive passive in - if kept > selection_estimate then - begin - (*Printf.eprintf "Too many passive equalities: pruning..."; - prune_passive selection_estimate active*) passive - end - else - passive - in - kept_clauses := (size_of_passive passive) + (size_of_active active); - let bag, goals = - if g_iterno < goal_steps then - infer_goal_set bag env active goals - else - bag, goals - in - match check_if_goals_set_is_solved bag env active passive goals with - | bag, Some p -> - debug_print (lazy - (Printf.sprintf "\nFound a proof in: %f\n" - (Unix.gettimeofday() -. initial_time))); - ParamodulationSuccess (p,active,passive,bag) - | bag, None -> - (* SELECTION *) - if passive_is_empty passive then - if no_more_passive_goals goals then - ParamodulationFailure - ("No more passive equations/goals",active,passive,bag) - (*maybe this is a success! *) - else - step bag goals passive active (g_iterno+1) (s_iterno+1) - else - begin - (* COLLECTION OF GARBAGED EQUALITIES *) - let bag = - if max g_iterno s_iterno mod 40 = 0 then - (print_status (max g_iterno s_iterno) goals active passive; - let active = List.map Equality.id_of (fst active) in - let passive = List.map Equality.id_of (fst3 passive) in - let goal = ids_of_goal_set goals in - Equality.collect bag active passive goal) - else - bag - in - if s_iterno > saturation_steps then - step bag goals passive active (g_iterno+1) (s_iterno+1) - (* ParamodulationFailure ("max saturation steps",active,passive,bag) *) - else - let current, passive = select env goals passive in - match add_to_active_aux bag active passive env eq_uri current with - | None, active, passive, bag -> - step bag goals passive active (g_iterno+1) (s_iterno+1) - | Some new', active, passive, bag -> - let bag, active_goals, passive_goals = - infer_goal_set_with_current bag env current goals active - in - let goals = - let a,b,_ = build_table new' in - let rc = - simplify_goal_set bag env (active_goals,passive_goals) (a,b) - in - rc - in - step bag goals passive active (g_iterno+1) (s_iterno+1) - end - in - step bag goals passive active 0 0 -;; - -let rec saturate_equations bag eq_uri env goal accept_fun passive active = - elapsed_time := Unix.gettimeofday () -. !start_time; - if !elapsed_time > !time_limit then - bag, active, passive - else - let current, passive = select env ([goal],[]) passive in - let bag, res = forward_simplify bag eq_uri env current active in - match res with - | None -> - saturate_equations bag eq_uri env goal accept_fun passive active - | Some current -> - Utils.debug_print (lazy (Printf.sprintf "selected: %s" - (Equality.string_of_equality ~env current))); - let bag, new' = infer bag eq_uri env current active in - let active = - if Equality.is_identity env current then active - else - let al, tbl = active in - al @ [current], Indexing.index tbl current - in - (* alla fine new' contiene anche le attive semplificate! - * quindi le aggiungo alle passive insieme alle new *) - let rec simplify bag new' active passive = - let bag, new' = forward_simplify_new bag eq_uri env new' active in - let bag, active, newa, pruned = - backward_simplify bag eq_uri env new' active in - let passive = - List.fold_left (filter_dependent bag) passive pruned in - match newa with - | None -> bag, active, passive, new' - | Some p -> simplify bag (new' @ p) active passive - in - let bag, active, passive, new' = simplify bag new' active passive in - let _ = - Utils.debug_print - (lazy - (Printf.sprintf "active:\n%s\n" - (String.concat "\n" - (List.map - (fun e -> Equality.string_of_equality ~env e) - (fst active))))) - in - let _ = - Utils.debug_print - (lazy - (Printf.sprintf "new':\n%s\n" - (String.concat "\n" - (List.map - (fun e -> "Negative " ^ - (Equality.string_of_equality ~env e)) new')))) - in - let new' = List.filter accept_fun new' in - let passive = add_to_passive passive new' [] in - saturate_equations bag eq_uri env goal accept_fun passive active -;; - -let default_depth = !maxdepth -and default_width = !maxwidth;; - -let reset_refs () = - 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 add_to_active bag active passive env ty term newmetas = - reset_refs (); - match LibraryObjects.eq_URI () with - | None -> active, passive, bag - | Some eq_uri -> - try - let bag, current = Equality.equality_of_term bag term ty newmetas in - let w,_,_,_,_ = Equality.open_equality current in - if w > 100 then - (HLog.debug - ("skipping giant " ^ CicPp.ppterm term ^ " of weight " ^ - string_of_int w); active, passive, bag) - else - let bag, current = Equality.fix_metas bag current in - match add_to_active_aux bag active passive env eq_uri current with - | _,a,p,b -> a,p,b - with - | Equality.TermIsNotAnEquality -> active, passive, bag -;; - - -let eq_of_goal = function - | Cic.Appl [Cic.MutInd(uri,0,_);_;_;_] when LibraryObjects.is_eq_URI uri -> - uri - | _ -> raise (ProofEngineTypes.Fail (lazy ("The goal is not an equality "))) -;; - -let eq_and_ty_of_goal = function - | Cic.Appl [Cic.MutInd(uri,0,_);t;_;_] when LibraryObjects.is_eq_URI uri -> - uri,t - | _ -> raise (ProofEngineTypes.Fail (lazy ("The goal is not an equality "))) -;; - -(* fix proof takes in input a term and try to build a metasenv for it *) - -let fix_proof metasenv context all_implicits p = - let rec aux metasenv n p = - match p with - | Cic.Meta (i,_) -> - if all_implicits then - metasenv,Cic.Implicit None - else - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context - in - let meta = CicSubstitution.lift n (Cic.Meta (i,irl)) in - let metasenv = - try - let _ = CicUtil.lookup_meta i metasenv in metasenv - with CicUtil.Meta_not_found _ -> - debug_print (lazy ("not found: "^(string_of_int i))); - let metasenv,j = CicMkImplicit.mk_implicit_type metasenv [] context in - (i,context,Cic.Meta(j,irl))::metasenv - in - metasenv,meta - | Cic.Appl l -> - let metasenv,l= - List.fold_right - (fun a (metasenv,l) -> - let metasenv,a' = aux metasenv n a in - metasenv,a'::l) - l (metasenv,[]) - in metasenv,Cic.Appl l - | Cic.Lambda(name,s,t) -> - let metasenv,s = aux metasenv n s in - let metasenv,t = aux metasenv (n+1) t in - metasenv,Cic.Lambda(name,s,t) - | Cic.Prod(name,s,t) -> - let metasenv,s = aux metasenv n s in - let metasenv,t = aux metasenv (n+1) t in - metasenv,Cic.Prod(name,s,t) - | Cic.LetIn(name,s,ty,t) -> - let metasenv,s = aux metasenv n s in - let metasenv,ty = aux metasenv n ty in - let metasenv,t = aux metasenv (n+1) t in - metasenv,Cic.LetIn(name,s,ty,t) - | Cic.Const(uri,ens) -> - let metasenv,ens = - List.fold_right - (fun (v,a) (metasenv,ens) -> - let metasenv,a' = aux metasenv n a in - metasenv,(v,a')::ens) - ens (metasenv,[]) - in - metasenv,Cic.Const(uri,ens) - | t -> metasenv,t - in - aux metasenv 0 p -;; - -let fix_metasenv context metasenv = - List.fold_left - (fun m (i,c,t) -> - let m,t = fix_proof m context false t in - let m = List.filter (fun (j,_,_) -> j<>i) m in - (i,context,t)::m) - metasenv metasenv -;; - - -(* status: input proof status - * goalproof: forward steps on goal - * newproof: backward steps - * subsumption_id: the equation used if goal is closed by subsumption - * (0 if not closed by subsumption) (DEBUGGING: can be safely removed) - * subsumption_subst: subst to make newproof and goalproof match - * proof_menv: final metasenv - *) - -let build_proof - bag status - goalproof newproof subsumption_id subsumption_subst proof_menv -= - if proof_menv = [] then debug_print (lazy "+++++++++++++++VUOTA") - else debug_print (lazy (CicMetaSubst.ppmetasenv [] proof_menv)); - let proof, goalno = status in - let uri, metasenv, _subst, meta_proof, term_to_prove, attrs = proof in - let _, context, type_of_goal = CicUtil.lookup_meta goalno metasenv in - let eq_uri = eq_of_goal type_of_goal in - let names = Utils.names_of_context context in - debug_print (lazy "Proof:"); - debug_print (lazy - (Equality.pp_proof bag names goalproof newproof subsumption_subst - subsumption_id type_of_goal)); -(* - prerr_endline ("max weight: " ^ - (string_of_int (Equality.max_weight goalproof newproof))); -*) - (* generation of the CIC proof *) - (* let metasenv' = List.filter (fun i,_,_ -> i<>goalno) metasenv in *) - let side_effects = - List.filter (fun i -> i <> goalno) - (ProofEngineHelpers.compare_metasenvs - ~newmetasenv:metasenv ~oldmetasenv:proof_menv) in - let goal_proof, side_effects_t = - let initial = Equality.add_subst subsumption_subst newproof in - Equality.build_goal_proof bag - eq_uri goalproof initial type_of_goal side_effects - context proof_menv - in -(* Equality.draw_proof bag names goalproof newproof subsumption_id; *) - let goal_proof = Subst.apply_subst subsumption_subst goal_proof in - (* assert (metasenv=[]); *) - let real_menv = fix_metasenv context (proof_menv@metasenv) in - let real_menv,goal_proof = - fix_proof real_menv context false goal_proof in -(* - let real_menv,fixed_proof = fix_proof proof_menv context false goal_proof in - (* prerr_endline ("PROOF: " ^ CicPp.pp goal_proof names); *) -*) - let pp_error goal_proof names error exn = - prerr_endline "THE PROOF DOES NOT TYPECHECK! "; - prerr_endline (CicPp.pp goal_proof names); - prerr_endline "THE PROOF DOES NOT TYPECHECK!"; - prerr_endline error; - prerr_endline "THE PROOF DOES NOT TYPECHECK! "; - raise exn - in - let old_insert_coercions = !CicRefine.insert_coercions in - let goal_proof,goal_ty,real_menv,_ = - (* prerr_endline ("parte la refine per: " ^ (CicPp.pp goal_proof names)); *) - try - debug_print (lazy (CicPp.ppterm goal_proof)); - CicRefine.insert_coercions := false; - let res = - CicRefine.type_of_aux' - real_menv context goal_proof CicUniv.empty_ugraph - in - CicRefine.insert_coercions := old_insert_coercions; - res - with - | CicRefine.RefineFailure s - | CicRefine.Uncertain s - | CicRefine.AssertFailure s as exn -> - CicRefine.insert_coercions := old_insert_coercions; - pp_error goal_proof names (Lazy.force s) exn - | CicUtil.Meta_not_found i as exn -> - CicRefine.insert_coercions := old_insert_coercions; - pp_error goal_proof names ("META NOT FOUND: "^string_of_int i) exn - | Invalid_argument "list_fold_left2" as exn -> - CicRefine.insert_coercions := old_insert_coercions; - pp_error goal_proof names "Invalid_argument: list_fold_left2" exn - | exn -> - CicRefine.insert_coercions := old_insert_coercions; - raise exn - in - let subst_side_effects,real_menv,_ = - try - CicUnification.fo_unif_subst [] context real_menv - goal_ty type_of_goal CicUniv.empty_ugraph - with - | CicUnification.UnificationFailure s - | CicUnification.Uncertain s - | CicUnification.AssertFailure s -> assert false - (* fail "Maybe the local context of metas in the goal was not an IRL" s *) - in - Utils.debug_print (lazy "+++++++++++++ FINE UNIF"); - let final_subst = - (goalno,(context,goal_proof,type_of_goal))::subst_side_effects - in -(* - let metas_of_proof = Utils.metas_of_term goal_proof in -*) - let proof, real_metasenv = - ProofEngineHelpers.subst_meta_and_metasenv_in_proof - proof goalno final_subst - (List.filter (fun i,_,_ -> i<>goalno ) real_menv) - in - let open_goals = - (ProofEngineHelpers.compare_metasenvs - ~oldmetasenv:metasenv ~newmetasenv:real_metasenv) in -(* - let open_goals = - List.map (fun i,_,_ -> i) real_metasenv in -*) - final_subst, proof, open_goals - - -(* - - let metas_still_open_in_proof = Utils.metas_of_term goal_proof in - (* prerr_endline (CicPp.pp goal_proof names); *) - let goal_proof = (* Subst.apply_subst subsumption_subst *) goal_proof in - let side_effects_t = - List.map (Subst.apply_subst subsumption_subst) side_effects_t - in - (* replacing fake mets with real ones *) - (* prerr_endline "replacing metas..."; *) - let irl=CicMkImplicit.identity_relocation_list_for_metavariable context in - CicMetaSubst.ppmetasenv [] proof_menv; - let what, with_what = - List.fold_left - (fun (acc1,acc2) i -> - (Cic.Meta(i,[]))::acc1, (Cic.Implicit None)::acc2) - ([],[]) - metas_still_open_in_proof -(* - (List.filter - (fun (i,_,_) -> - List.mem i metas_still_open_in_proof - (*&& not(List.mem i metas_still_open_in_goal)*)) - proof_menv) -*) - in - let goal_proof_menv = - List.filter - (fun (i,_,_) -> List.mem i metas_still_open_in_proof) - proof_menv - in - let replace where = - (* we need this fake equality since the metas of the hypothesis may be - * with a real local context *) - ProofEngineReduction.replace_lifting - ~equality:(fun x y -> - match x,y with Cic.Meta(i,_),Cic.Meta(j,_) -> i=j | _-> false) - ~what ~with_what ~where - in - let goal_proof = replace goal_proof in - (* ok per le meta libere... ma per quelle che c'erano e sono rimaste? - * what mi pare buono, sostituisce solo le meta farlocche *) - let side_effects_t = List.map replace side_effects_t in - let free_metas = - List.filter (fun i -> i <> goalno) - (ProofEngineHelpers.compare_metasenvs - ~oldmetasenv:metasenv ~newmetasenv:goal_proof_menv) - in - (* prerr_endline - * ("freemetas: " ^ - * String.concat "," (List.map string_of_int free_metas) ); *) - (* check/refine/... build the new proof *) - let replaced_goal = - ProofEngineReduction.replace - ~what:side_effects ~with_what:side_effects_t - ~equality:(fun i t -> match t with Cic.Meta(j,_)->j=i|_->false) - ~where:type_of_goal - in - let goal_proof,goal_ty,real_menv,_ = - try - CicRefine.type_of_aux' metasenv context goal_proof - CicUniv.empty_ugraph - with - | CicUtil.Meta_not_found _ - | CicRefine.RefineFailure _ - | CicRefine.Uncertain _ - | CicRefine.AssertFailure _ - | Invalid_argument "list_fold_left2" as exn -> - prerr_endline "THE PROOF DOES NOT TYPECHECK!"; - prerr_endline (CicPp.pp goal_proof names); - prerr_endline "THE PROOF DOES NOT TYPECHECK!"; - raise exn - in - prerr_endline "+++++++++++++ METASENV"; - prerr_endline - (CicMetaSubst.ppmetasenv [] real_menv); - let subst_side_effects,real_menv,_ = -(* - prerr_endline ("XX type_of_goal " ^ CicPp.ppterm type_of_goal); - prerr_endline ("XX replaced_goal " ^ CicPp.ppterm replaced_goal); - prerr_endline ("XX metasenv " ^ - CicMetaSubst.ppmetasenv [] (metasenv @ free_metas_menv)); -*) - try - CicUnification.fo_unif_subst [] context real_menv - goal_ty type_of_goal CicUniv.empty_ugraph - with - | CicUnification.UnificationFailure s - | CicUnification.Uncertain s - | CicUnification.AssertFailure s -> assert false -(* fail "Maybe the local context of metas in the goal was not an IRL" s *) - in - let final_subst = - (goalno,(context,goal_proof,type_of_goal))::subst_side_effects - in -(* - let metas_of_proof = Utils.metas_of_term goal_proof in -*) - let proof, real_metasenv = - ProofEngineHelpers.subst_meta_and_metasenv_in_proof - proof goalno (CicMetaSubst.apply_subst final_subst) - (List.filter (fun i,_,_ -> i<>goalno ) real_menv) - in - let open_goals = - List.map (fun i,_,_ -> i) real_metasenv in - -(* - HExtlib.list_uniq (List.sort Pervasives.compare metas_of_proof) - in *) -(* - match free_meta with Some(Cic.Meta(m,_)) when m<>goalno ->[m] | _ ->[] - in -*) -(* - Printf.eprintf - "GOALS APERTI: %s\nMETASENV PRIMA:\n%s\nMETASENV DOPO:\n%s\n" - (String.concat ", " (List.map string_of_int open_goals)) - (CicMetaSubst.ppmetasenv [] metasenv) - (CicMetaSubst.ppmetasenv [] real_metasenv); -*) - final_subst, proof, open_goals -;; -*) - -(* **************** HERE ENDS THE PARAMODULATION STUFF ******************** *) - -(* exported functions *) - -let pump_actives context bag active passive saturation_steps max_time = - reset_refs(); -(* - let max_l l = - List.fold_left - (fun acc e -> let _,_,_,menv,_ = Equality.open_equality e in - List.fold_left (fun acc (i,_,_) -> max i acc) acc menv) - 0 l in -*) -(* let active_l = fst active in *) -(* let passive_l = fst passive in *) -(* let ma = max_l active_l in *) -(* let mp = max_l passive_l in *) - match LibraryObjects.eq_URI () with - | None -> active, passive, bag - | Some eq_uri -> - let env = [],context,CicUniv.empty_ugraph in - (match - given_clause bag eq_uri env ([],[]) - passive active 0 saturation_steps max_time - with - | ParamodulationFailure (_,a,p,b) -> - a, p, b - | ParamodulationSuccess _ -> - assert false) -;; - -let all_subsumed bag status active passive = - let proof, goalno = status in - let uri, metasenv, _subst, meta_proof, term_to_prove, attrs = proof in - let _, context, type_of_goal = CicUtil.lookup_meta goalno metasenv in - let env = metasenv,context,CicUniv.empty_ugraph in - let cleaned_goal = Utils.remove_local_context type_of_goal in - let canonical_menv,other_menv = - List.partition (fun (_,c,_) -> c = context) metasenv in - (* prerr_endline ("other menv = " ^ (CicMetaSubst.ppmetasenv [] other_menv)); *) - let metasenv = List.map (fun (i,_,ty)-> (i,[],ty)) canonical_menv in - let goal = [], List.filter (fun (i,_,_)->i<>goalno) metasenv, cleaned_goal in - debug_print (lazy (string_of_int (List.length (fst active)))); - (* we simplify using both actives passives *) - let table = - List.fold_left - (fun (l,tbl) eq -> eq::l,(Indexing.index tbl eq)) - active (list_of_passive passive) in - let (_,_,ty) = goal in - debug_print (lazy ("prima " ^ CicPp.ppterm ty)); - let _,goal = simplify_goal bag env goal table in - let (_,_,ty) = goal in - debug_print (lazy ("in mezzo " ^ CicPp.ppterm ty)); - let bag, subsumed = find_all_subsumed bag env (snd table) goal in - debug_print (lazy ("dopo " ^ CicPp.ppterm ty)); - let subsumed_or_id = - match (check_if_goal_is_identity env goal) with - None -> subsumed - | Some id -> id::subsumed in - debug_print (lazy "dopo subsumed"); - let res = - List.map - (fun - (goalproof,newproof,subsumption_id,subsumption_subst, proof_menv) -> - let subst, proof, gl = - build_proof bag - status goalproof newproof subsumption_id subsumption_subst proof_menv - in - let uri, metasenv, subst, meta_proof, term_to_prove, attrs = proof in - let newmetasenv = - other_menv @ - List.filter - (fun x,_,_ -> not (List.exists (fun y,_,_ -> x=y) other_menv)) metasenv - in - let proof = uri, newmetasenv, subst, meta_proof, term_to_prove, attrs in - (subst, proof,gl)) subsumed_or_id - in - res -;; - - -let given_clause - bag status active passive goal_steps saturation_steps max_time -= - reset_refs(); - let active_l = fst active in - let proof, goalno = status in - let uri, metasenv, _subst, meta_proof, term_to_prove, attrs = proof in - let _, context, type_of_goal = CicUtil.lookup_meta goalno metasenv in - let eq_uri = eq_of_goal type_of_goal in - let cleaned_goal = Utils.remove_local_context type_of_goal in - let metas_occurring_in_goal = CicUtil.metas_of_term cleaned_goal in - let canonical_menv,other_menv = - List.partition (fun (_,c,_) -> c = context) metasenv in - Utils.set_goal_symbols cleaned_goal; (* DISACTIVATED *) - let canonical_menv = - List.map - (fun (i,_,ty)-> (i,[],Utils.remove_local_context ty)) canonical_menv - in - let metasenv' = - List.filter - (fun (i,_,_)-> i<>goalno && List.mem_assoc i metas_occurring_in_goal) - canonical_menv - in - let goal = [], metasenv', cleaned_goal in - let env = metasenv,context,CicUniv.empty_ugraph in - debug_print (lazy ">>>>>> ACTIVES >>>>>>>>"); - List.iter (fun e -> debug_print (lazy (Equality.string_of_equality ~env e))) - active_l; - debug_print (lazy ">>>>>>>>>>>>>>"); - let goals = make_goal_set goal in - match - given_clause bag eq_uri env goals passive active - goal_steps saturation_steps max_time - with - | ParamodulationFailure (msg,a,p,b) -> - if Utils.debug then prerr_endline msg; - None, a, p, b - | ParamodulationSuccess - ((goalproof,newproof,subsumption_id,subsumption_subst, proof_menv),a,p,b) -> - let subst, proof, gl = - build_proof b - status goalproof newproof subsumption_id subsumption_subst proof_menv - in - let uri, metasenv, subst, meta_proof, term_to_prove, attrs = proof in - let proof = uri, other_menv@metasenv, subst, meta_proof, term_to_prove, attrs in - Some (subst, proof,gl),a,p, b -;; - -let solve_narrowing bag status active passive goal_steps = - let proof, goalno = status in - let uri, metasenv, _subst, meta_proof, term_to_prove, attrs = proof in - let _, context, type_of_goal = CicUtil.lookup_meta goalno metasenv in - let cleaned_goal = Utils.remove_local_context type_of_goal in - let metas_occurring_in_goal = CicUtil.metas_of_term cleaned_goal in - let canonical_menv,other_menv = - List.partition (fun (_,c,_) -> c = context) metasenv in - let canonical_menv = - List.map - (fun (i,_,ty)-> (i,[],Utils.remove_local_context ty)) canonical_menv - in - let metasenv' = - List.filter - (fun (i,_,_)-> i<>goalno && List.mem_assoc i metas_occurring_in_goal) - canonical_menv - in - let goal = [], metasenv', cleaned_goal in - let env = metasenv,context,CicUniv.empty_ugraph in - let goals = - let table = List.fold_left Indexing.index (last passive) (fst active) in - goal :: Indexing.demodulation_all_goal bag env table goal 4 - in - let rec aux newactives newpassives bag = function - | [] -> bag, (newactives, newpassives) - | hd::tl -> - let selected = hd in - let (_,m1,t1) = selected in - let already_in = - List.exists (fun (_,_,t) -> Equality.meta_convertibility t t1) - newactives - in - if already_in then - aux newactives newpassives bag tl - else - let bag, newpassives = - if Utils.metas_of_term t1 = [] then - bag, newpassives - else - let bag, new' = - Indexing.superposition_left bag env (snd active) selected - in - let new' = - List.map - (fun x -> let b, x = simplify_goal bag env x active in x) - new' - in - bag, newpassives @ new' - in - aux (selected::newactives) newpassives bag tl - in - let rec do_n bag ag pg = function - | 0 -> None, active, passive, bag - | n -> - let bag, (ag, pg) = aux [] [] bag (ag @ pg) in - match check_if_goals_set_is_solved bag env active passive (ag,pg) with - | bag, None -> do_n bag ag pg (n-1) - | bag, Some (gproof,newproof,subsumption_id,subsumption_subst,pmenv)-> - let subst, proof, gl = - build_proof bag - status gproof newproof subsumption_id subsumption_subst pmenv - in - let uri,metasenv,subst,meta_proof,term_to_prove,attrs = proof in - let proof = - uri, other_menv@metasenv, subst, meta_proof, term_to_prove, attrs - in - Some (subst, proof,gl),active,passive, bag - in - do_n bag [] goals goal_steps -;; - - -let add_to_passive eql passives = - add_to_passive passives eql eql -;; - - diff --git a/matita/components/tactics/paramodulation/saturation.mli b/matita/components/tactics/paramodulation/saturation.mli deleted file mode 100644 index d890a719d..000000000 --- a/matita/components/tactics/paramodulation/saturation.mli +++ /dev/null @@ -1,86 +0,0 @@ -(* Copyright (C) 2006, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -type passive_table -type active_table = Equality.equality list * Indexing.Index.t - -val reset_refs : unit -> unit - -val make_active: Equality.equality list -> active_table -val make_passive: Equality.equality list -> passive_table -val add_to_passive: Equality.equality list -> passive_table -> passive_table -val add_to_active: - Equality.equality_bag -> - active_table -> passive_table -> - Utils.environment -> Cic.term (* ty *) -> Cic.term -> Cic.metasenv -> - active_table * passive_table * Equality.equality_bag -val list_of_passive: passive_table -> Equality.equality list -val list_of_active: active_table -> Equality.equality list - -val simplify_equalities : - Equality.equality_bag -> - UriManager.uri -> - Utils.environment -> - Equality.equality list -> - Equality.equality_bag * Equality.equality list -val pump_actives : - Cic.context -> - Equality.equality_bag -> - active_table -> - passive_table -> - int -> - float -> - active_table * passive_table * Equality.equality_bag -val all_subsumed : - Equality.equality_bag -> - ProofEngineTypes.status -> - active_table -> - passive_table -> - (Cic.substitution * - ProofEngineTypes.proof * - ProofEngineTypes.goal list) list -val given_clause: - Equality.equality_bag -> - ProofEngineTypes.status -> - active_table -> - passive_table -> - int -> int -> float -> - (Cic.substitution * - ProofEngineTypes.proof * - ProofEngineTypes.goal list) option * - active_table * passive_table * Equality.equality_bag - -val solve_narrowing: - Equality.equality_bag -> - ProofEngineTypes.status -> - active_table -> - passive_table -> - int -> - (Cic.substitution * - ProofEngineTypes.proof * - ProofEngineTypes.goal list) option * - active_table * passive_table * Equality.equality_bag diff --git a/matita/components/tactics/paramodulation/subst.ml b/matita/components/tactics/paramodulation/subst.ml deleted file mode 100644 index fb8e3b78e..000000000 --- a/matita/components/tactics/paramodulation/subst.ml +++ /dev/null @@ -1,217 +0,0 @@ -(* cOpyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id: inference.ml 6245 2006-04-05 12:07:51Z tassi $ *) - - -(******* CIC substitution ***************************************************) - -type cic_substitution = Cic.substitution -let cic_apply_subst = CicMetaSubst.apply_subst -let cic_apply_subst_metasenv = CicMetaSubst.apply_subst_metasenv -let cic_ppsubst = CicMetaSubst.ppsubst -let cic_buildsubst n context t ty tail = (n,(context,t,ty)) :: tail -let cic_flatten_subst subst = - List.map - (fun (i, (context, term, ty)) -> - let context = (* cic_apply_subst_context subst*) context in - let term = cic_apply_subst subst term in - let ty = cic_apply_subst subst ty in - (i, (context, term, ty))) subst -let rec cic_lookup_subst meta subst = - match meta with - | Cic.Meta (i, _) -> ( - try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst - in cic_lookup_subst t subst - with Not_found -> meta - ) - | _ -> meta -;; - -let cic_merge_subst_if_possible s1 s2 = - let already_in = Hashtbl.create 13 in - let rec aux acc = function - | ((i,_,x) as s)::tl -> - (try - let x' = Hashtbl.find already_in i in - if x = x' then aux acc tl else None - with - | Not_found -> - Hashtbl.add already_in i x; - aux (s::acc) tl) - | [] -> Some acc - in - aux [] (s1@s2) -;; - -(******** NAIF substitution **************************************************) -(* - * naif version of apply subst; the local context of metas is ignored; - * we assume the substituted term must be lifted according to the nesting - * depth of the meta. - * Alternatively, we could used implicit instead of metas - *) - -type naif_substitution = (int * Cic.term) list - -let naif_apply_subst lift subst term = - let rec aux k t = - match t with - Cic.Rel _ -> t - | Cic.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri, t) -> (uri, aux k t)) exp_named_subst - in - Cic.Var (uri, exp_named_subst') - | Cic.Meta (i, l) -> - (try - aux k (CicSubstitution.lift (k+lift) (List.assoc i subst)) - with Not_found -> t) - | Cic.Sort _ - | Cic.Implicit _ -> t - | Cic.Cast (te,ty) -> Cic.Cast (aux k te, aux k ty) - | Cic.Prod (n,s,t) -> Cic.Prod (n, aux k s, aux (k+1) t) - | Cic.Lambda (n,s,t) -> Cic.Lambda (n, aux k s, aux (k+1) t) - | Cic.LetIn (n,s,ty,t) -> Cic.LetIn (n, aux k s, aux k ty, aux (k+1) t) - | Cic.Appl [] -> assert false - | Cic.Appl l -> Cic.Appl (List.map (aux k) l) - | Cic.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri, t) -> (uri, aux k t)) exp_named_subst - in - if exp_named_subst' != exp_named_subst then - Cic.Const (uri, exp_named_subst') - else - t (* TODO: provare a mantenere il piu' possibile sharing *) - | Cic.MutInd (uri,typeno,exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri, t) -> (uri, aux k t)) exp_named_subst - in - Cic.MutInd (uri,typeno,exp_named_subst') - | Cic.MutConstruct (uri,typeno,consno,exp_named_subst) -> - let exp_named_subst' = - List.map (fun (uri, t) -> (uri, aux k t)) exp_named_subst - in - Cic.MutConstruct (uri,typeno,consno,exp_named_subst') - | Cic.MutCase (sp,i,outty,t,pl) -> - let pl' = List.map (aux k) pl in - Cic.MutCase (sp, i, aux k outty, aux k t, pl') - | Cic.Fix (i, fl) -> - let len = List.length fl in - let fl' = - List.map - (fun (name, i, ty, bo) -> (name, i, aux k ty, aux (k+len) bo)) fl - in - Cic.Fix (i, fl') - | Cic.CoFix (i, fl) -> - let len = List.length fl in - let fl' = - List.map (fun (name, ty, bo) -> (name, aux k ty, aux (k+len) bo)) fl - in - Cic.CoFix (i, fl') -in - aux 0 term -;; - -(* naif version of apply_subst_metasenv: we do not apply the -substitution to the context *) - -let naif_apply_subst_metasenv subst metasenv = - List.map - (fun (n, context, ty) -> - (n, context, naif_apply_subst 0 subst ty)) - (List.filter - (fun (i, _, _) -> not (List.mem_assoc i subst)) - metasenv) - -let naif_ppsubst names subst = - "{" ^ String.concat "; " - (List.map - (fun (idx, t) -> - Printf.sprintf "%d:= %s" idx (CicPp.pp t names)) - subst) ^ "}" -;; - -let naif_buildsubst n context t ty tail = (n,t) :: tail ;; - -let naif_flatten_subst subst = - List.map (fun (i,t) -> i, naif_apply_subst 0 subst t ) subst -;; - -let rec naif_lookup_subst meta subst = - match meta with - | Cic.Meta (i, _) -> - (try - naif_lookup_subst (List.assoc i subst) subst - with - Not_found -> meta) - | _ -> meta -;; - -let naif_merge_subst_if_possible s1 s2 = - let already_in = Hashtbl.create 13 in - let rec aux acc = function - | ((i,x) as s)::tl -> - (try - let x' = Hashtbl.find already_in i in - if x = x' then aux acc tl else None - with - | Not_found -> - Hashtbl.add already_in i x; - aux (s::acc) tl) - | [] -> Some acc - in - aux [] (s1@s2) -;; - -(********** ACTUAL SUBSTITUTION IMPLEMENTATION *******************************) - -type substitution = naif_substitution -let apply_subst = naif_apply_subst 0 -let apply_subst_lift = naif_apply_subst -let apply_subst_metasenv = naif_apply_subst_metasenv -let ppsubst ?(names=[]) l = naif_ppsubst names l -let buildsubst = naif_buildsubst -let flatten_subst = naif_flatten_subst -let lookup_subst = naif_lookup_subst - -(* filter out from metasenv the variables in substs *) -let filter subst metasenv = - List.filter - (fun (m, _, _) -> - try let _ = List.find (fun (i, _) -> m = i) subst in false - with Not_found -> true) - metasenv -;; - -let is_in_subst i subst = List.mem_assoc i subst;; - -let merge_subst_if_possible = naif_merge_subst_if_possible;; - -let empty_subst = [];; - -let concat x y = x @ y;; - - diff --git a/matita/components/tactics/paramodulation/subst.mli b/matita/components/tactics/paramodulation/subst.mli deleted file mode 100644 index 6627bf067..000000000 --- a/matita/components/tactics/paramodulation/subst.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* Copyright (C) 2006, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -type substitution - -val empty_subst : substitution -val apply_subst : substitution -> Cic.term -> Cic.term -val apply_subst_lift : int -> substitution -> Cic.term -> Cic.term -val apply_subst_metasenv : substitution -> Cic.metasenv -> Cic.metasenv -val ppsubst : ?names:(Cic.name option list) -> substitution -> string -val buildsubst : - int -> Cic.context -> Cic.term -> Cic.term -> substitution -> - substitution -val flatten_subst : substitution -> substitution -val lookup_subst : Cic.term -> substitution -> Cic.term -val filter : substitution -> Cic.metasenv -> Cic.metasenv -val is_in_subst : int -> substitution -> bool -val merge_subst_if_possible: - substitution -> substitution -> - substitution option -val concat: substitution -> substitution -> substitution diff --git a/matita/components/tactics/paramodulation/test_indexing.ml b/matita/components/tactics/paramodulation/test_indexing.ml deleted file mode 100644 index 02dbf69e0..000000000 --- a/matita/components/tactics/paramodulation/test_indexing.ml +++ /dev/null @@ -1,253 +0,0 @@ -(* $Id$ *) - -open Path_indexing - -(* -let build_equality term = - let module C = Cic in - C.Implicit None, (C.Implicit None, term, C.Rel 1, Utils.Gt), [], [] -;; - - -(* - f = Rel 1 - g = Rel 2 - a = Rel 3 - b = Rel 4 - c = Rel 5 -*) -let path_indexing_test () = - let module C = Cic in - let terms = [ - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Meta (1, [])]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 5]; C.Rel 4]; - C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])] - ] in - let path_strings = List.map (path_strings_of_term 0) terms in - let table = - List.fold_left index PSTrie.empty (List.map build_equality terms) in - let query = - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Rel 5] in - let matches = retrieve_generalizations table query in - let unifications = retrieve_unifiables table query in - let eq1 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])]) - and eq2 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (2, [])]) in - let res1 = in_index table eq1 - and res2 = in_index table eq2 in - let print_results res = - String.concat "\n" - (PosEqSet.fold - (fun (p, e) l -> - let s = - "(" ^ (Utils.string_of_pos p) ^ ", " ^ - (Inference.string_of_equality e) ^ ")" - in - s::l) - res []) - in - Printf.printf "path_strings:\n%s\n\n" - (String.concat "\n" - (List.map - (fun l -> - "{" ^ (String.concat "; " (List.map string_of_path_string l)) ^ "}" - ) path_strings)); - Printf.printf "table:\n%s\n\n" (string_of_pstrie table); - Printf.printf "matches:\n%s\n\n" (print_results matches); - Printf.printf "unifications:\n%s\n\n" (print_results unifications); - Printf.printf "in_index %s: %s\n" - (Inference.string_of_equality eq1) (string_of_bool res1); - Printf.printf "in_index %s: %s\n" - (Inference.string_of_equality eq2) (string_of_bool res2); -;; - - -let differing () = - let module C = Cic in - let t1 = - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5] - and t2 = - C.Appl [C.Rel 1; C.Appl [C.Rel 5; C.Rel 4; C.Meta (1, [])]; C.Rel 5] - in - let res = Inference.extract_differing_subterms t1 t2 in - match res with - | None -> prerr_endline "NO DIFFERING SUBTERMS???" - | Some (t1, t2) -> - Printf.printf "OK: %s, %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2); -;; - - -let next_after () = - let module C = Cic in - let t = - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5] - in - let pos1 = Discrimination_tree.next_t [1] t in - let pos2 = Discrimination_tree.after_t [1] t in - Printf.printf "next_t 1: %s\nafter_t 1: %s\n" - (CicPp.ppterm (Discrimination_tree.subterm_at_pos pos1 t)) - (CicPp.ppterm (Discrimination_tree.subterm_at_pos pos2 t)); -;; - - -let discrimination_tree_test () = - let module C = Cic in - let terms = [ - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Meta (1, [])]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 5]; C.Rel 4]; - C.Appl [C.Rel 10; C.Meta (5, []); C.Rel 11] - ] in - let path_strings = - List.map Discrimination_tree.path_string_of_term terms in - let table = - List.fold_left - Discrimination_tree.index - Discrimination_tree.DiscriminationTree.empty - (List.map build_equality terms) - in -(* let query = *) -(* C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Rel 5] in *) - let query = C.Appl [C.Rel 10; C.Meta (14, []); C.Meta (13, [])] in - let matches = Discrimination_tree.retrieve_generalizations table query in - let unifications = Discrimination_tree.retrieve_unifiables table query in - let eq1 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])]) - and eq2 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (2, [])]) in - let res1 = Discrimination_tree.in_index table eq1 - and res2 = Discrimination_tree.in_index table eq2 in - let print_results res = - String.concat "\n" - (Discrimination_tree.PosEqSet.fold - (fun (p, e) l -> - let s = - "(" ^ (Utils.string_of_pos p) ^ ", " ^ - (Inference.string_of_equality e) ^ ")" - in - s::l) - res []) - in - Printf.printf "path_strings:\n%s\n\n" - (String.concat "\n" - (List.map Discrimination_tree.string_of_path_string path_strings)); - Printf.printf "table:\n%s\n\n" - (Discrimination_tree.string_of_discrimination_tree table); - Printf.printf "matches:\n%s\n\n" (print_results matches); - Printf.printf "unifications:\n%s\n\n" (print_results unifications); - Printf.printf "in_index %s: %s\n" - (Inference.string_of_equality eq1) (string_of_bool res1); - Printf.printf "in_index %s: %s\n" - (Inference.string_of_equality eq2) (string_of_bool res2); -;; - - -let test_subst () = - let module C = Cic in - let module M = CicMetaSubst in - let term = C.Appl [ - C.Rel 1; - C.Appl [C.Rel 11; - C.Meta (43, []); - C.Appl [C.Rel 15; C.Rel 12; C.Meta (41, [])]]; - C.Appl [C.Rel 11; - C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (11, [])]; - C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (12, [])]] - ] in - let subst1 = [ - (43, ([], C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (11, [])], C.Rel 16)); - (10, ([], C.Rel 12, C.Rel 16)); - (12, ([], C.Meta (41, []), C.Rel 16)) - ] - and subst2 = [ - (43, ([], C.Appl [C.Rel 15; C.Rel 12; C.Meta (11, [])], C.Rel 16)); - (10, ([], C.Rel 12, C.Rel 16)); - (12, ([], C.Meta (41, []), C.Rel 16)) - ] in - let t1 = M.apply_subst subst1 term - and t2 = M.apply_subst subst2 term in - Printf.printf "t1 = %s\nt2 = %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2); -;; -*) - - -let test_refl () = - let module C = Cic in - let context = [ - Some (C.Name "H", C.Decl ( - C.Prod (C.Name "z", C.Rel 3, - C.Appl [ - C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); - C.Rel 4; C.Rel 3; C.Rel 1]))); - Some (C.Name "x", C.Decl (C.Rel 2)); - Some (C.Name "y", C.Decl (C.Rel 1)); - Some (C.Name "A", C.Decl (C.Sort C.Set)) - ] - in - let term = C.Appl [ - C.Const (HelmLibraryObjects.Logic.eq_ind_URI, []); C.Rel 4; - C.Rel 2; - C.Lambda (C.Name "z", C.Rel 4, - C.Appl [ - C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); - C.Rel 5; C.Rel 1; C.Rel 3 - ]); - C.Appl [C.MutConstruct - (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); (* reflexivity *) - C.Rel 4; C.Rel 2]; - C.Rel 3; -(* C.Appl [C.Const (HelmLibraryObjects.Logic.sym_eq_URI, []); (\* symmetry *\) *) -(* C.Rel 4; C.Appl [C.Rel 1; C.Rel 2]] *) - C.Appl [ - C.Const (HelmLibraryObjects.Logic.eq_ind_URI, []); - C.Rel 4; C.Rel 3; - C.Lambda (C.Name "z", C.Rel 4, - C.Appl [ - C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); - C.Rel 5; C.Rel 1; C.Rel 4 - ]); - C.Appl [C.MutConstruct (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); - C.Rel 4; C.Rel 3]; - C.Rel 2; C.Appl [C.Rel 1; C.Rel 2] - ] - ] in - let ens = [ - (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/A.var", - C.Rel 4); - (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/x.var", - C.Rel 3); - (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/y.var", - C.Rel 2); - ] in - let term2 = C.Appl [ - C.Const (HelmLibraryObjects.Logic.sym_eq_URI, ens); - C.Appl [C.Rel 1; C.Rel 2] - ] in - let ty, ug = - CicTypeChecker.type_of_aux' [] context term CicUniv.empty_ugraph - in - Printf.printf "OK, %s ha tipo %s\n" (CicPp.ppterm term) (CicPp.ppterm ty); - let ty, ug = - CicTypeChecker.type_of_aux' [] context term2 CicUniv.empty_ugraph - in - Printf.printf "OK, %s ha tipo %s\n" (CicPp.ppterm term2) (CicPp.ppterm ty); -;; - - -let test_lib () = - let uri = Sys.argv.(1) in - let t = CicUtil.term_of_uri (UriManager.uri_of_string uri) in - let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in - Printf.printf "Term of %s: %s\n" uri (CicPp.ppterm t); - Printf.printf "type: %s\n" (CicPp.ppterm ty); -;; - - -(* differing ();; *) -(* next_after ();; *) -(* discrimination_tree_test ();; *) -(* path_indexing_test ();; *) -(* test_subst ();; *) -Helm_registry.load_from "../../matita/matita.conf.xml"; -(* test_refl ();; *) -test_lib ();; diff --git a/matita/components/tactics/paramodulation/utils.ml b/matita/components/tactics/paramodulation/utils.ml deleted file mode 100644 index 86c9c1430..000000000 --- a/matita/components/tactics/paramodulation/utils.ml +++ /dev/null @@ -1,783 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -let time = false;; -let debug = false;; -let debug_metas = false;; -let debug_res = false;; - -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" - -type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph - -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 - | C.Lambda(n,s,t) -> - TermSet.union (aux s) (aux t) - | C.Prod(n,s,t) -> - TermSet.union (aux s) (aux t) - | C.LetIn(n,s,ty,t) -> - TermSet.union (aux s) (TermSet.union (aux ty) (aux t)) - | t -> TermSet.empty (* TODO: maybe add other cases? *) - in - aux term -;; - -let rec remove_local_context = - function - | Cic.Meta (i,_) -> Cic.Meta (i,[]) - | Cic.Appl l -> - Cic.Appl(List.map remove_local_context l) - | Cic.Prod (n,s,t) -> - Cic.Prod (n,remove_local_context s, remove_local_context t) - | t -> t - - -(************************* 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) ?(count_metas_occurrences=false) 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); - if count_metas_occurrences then 1 else 0 - | C.Meta _ -> (* "variables" are lighter than constants and functions...*) - if count_metas_occurrences then 1 else 0 - | 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 goal_symbols = ref TermSet.empty - -let set_of_map m = - TermMap.fold (fun k _ s -> TermSet.add k s) m TermSet.empty -;; - -let set_goal_symbols term = - let m = symbols_of_term term in - goal_symbols := (set_of_map m) -;; - -let symbols_of_eq (ty,left,right,_) = - let sty = set_of_map (symbols_of_term ty) in - let sl = set_of_map (symbols_of_term left) in - let sr = set_of_map (symbols_of_term right) in - TermSet.union sty (TermSet.union sl sr) -;; - -let distance sgoal seq = - let s = TermSet.diff seq sgoal in - TermSet.cardinal s -;; - -let compute_equality_weight (ty,left,right,o) = - let factor = 2 in - match o with - | Lt -> - let w, m = (weight_of_term - ~consider_metas:true ~count_metas_occurrences:false right) in - w + (factor * (List.length m)) ; - | Le -> assert false - | Gt -> - let w, m = (weight_of_term - ~consider_metas:true ~count_metas_occurrences:false left) in - w + (factor * (List.length m)) ; - | Ge -> assert false - | Eq - | Incomparable -> - let w1, m1 = (weight_of_term - ~consider_metas:true ~count_metas_occurrences:false right) in - let w2, m2 = (weight_of_term - ~consider_metas:true ~count_metas_occurrences:false left) in - w1 + w2 + (factor * (List.length m1)) + (factor * (List.length m2)) -;; - -let compute_equality_weight e = - let w = compute_equality_weight e in - let d = 0 in (* distance !goal_symbols (symbols_of_eq e) in *) -(* - prerr_endline (Printf.sprintf "dist %s --- %s === %d" - (String.concat ", " (List.map (CicPp.ppterm) (TermSet.elements - !goal_symbols))) - (String.concat ", " (List.map (CicPp.ppterm) (TermSet.elements - (symbols_of_eq e)))) - d - ); -*) - w + d -;; - -(* old -let compute_equality_weight (ty,left,right,o) = - let metasw = ref 0 in - let weight_of t = - let w, m = (weight_of_term - ~consider_metas:true ~count_metas_occurrences:false t) in - metasw := !metasw + (1 * (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 - (* let w = weight_of (Cic.Appl [ty;left;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, tno1, _), C.MutInd (u2, tno2, _) -> - let res = compare_uris u1 u2 in - if res <> Eq then res - else - let res = compare tno1 tno2 in - if res = 0 then Eq else if res < 0 then Lt else Gt - | C.MutInd _, _ -> Lt - | _, C.MutInd _ -> Gt - - | C.MutConstruct (u1, tno1, cno1, _), C.MutConstruct (u2, tno2, cno2, _) -> - let res = compare_uris u1 u2 in - if res <> Eq then res - else - let res = compare (tno1,cno1) (tno2,cno2) in - if res = 0 then Eq else if res < 0 then Lt else Gt - | 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 - debug_print (lazy ("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 pos = Left | Right - -let string_of_pos = function - | Left -> "Left" - | Right -> "Right" -;; - -let metas_of_term t = - List.map fst (CicUtil.metas_of_term t) -;; - diff --git a/matita/components/tactics/paramodulation/utils.mli b/matita/components/tactics/paramodulation/utils.mli deleted file mode 100644 index 2f25415ac..000000000 --- a/matita/components/tactics/paramodulation/utils.mli +++ /dev/null @@ -1,89 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* (weight of constants, [(meta, weight_of_meta)]) *) - -val time : bool -val debug : bool -val debug_metas: bool -val debug_res: bool - -type weight = int * (int * int) list;; - -type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;; - -type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph - -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 -> - ?count_metas_occurrences: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 set_goal_symbols: Cic.term -> unit - -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 pos = Left | Right - -val string_of_pos: pos -> string - -val compute_equality_weight: Cic.term * Cic.term * Cic.term * comparison -> int - -val debug_print: string Lazy.t -> unit - -val metas_of_term: Cic.term -> int list - -val remove_local_context: Cic.term -> Cic.term diff --git a/matita/components/tactics/primitiveTactics.ml b/matita/components/tactics/primitiveTactics.ml deleted file mode 100644 index 2862d3c5d..000000000 --- a/matita/components/tactics/primitiveTactics.ml +++ /dev/null @@ -1,1072 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -exception TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple -exception NotAnInductiveTypeToEliminate -exception WrongUriToVariable of string -exception NotAnEliminator - -module PET = ProofEngineTypes - -(* 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 do_whd 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 do_whd te - | C.Prod (n,s,t) -> - let n' = mk_fresh_name metasenv context n ~typ:s in - let (context',ty,bo) = - let entry = match n' with - | C.Name _ -> Some (n',(C.Decl s)) - | C.Anonymous -> None - in - let ctx = entry :: context in - collect_context ctx (howmany - 1) do_whd t - in - (context',ty,C.Lambda(n',s,bo)) - | C.LetIn (n,s,sty,t) -> - let (context',ty,bo) = - collect_context ((Some (n,(C.Def (s,sty))))::context) (howmany - 1) do_whd t - in - (context',ty,C.LetIn(n,s,sty,bo)) - | _ as t -> - if howmany <= 0 then - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context - in - context, t, (C.Meta (newmeta,irl)) - else if do_whd then - let t = CicReduction.whd ~delta:true context t in - collect_context context howmany false t - else - raise (PET.Fail (lazy "intro(s): not enough products or let-ins")) - in - collect_context context howmany true 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,ty,t) -> C.LetIn (nn, aux n s, aux n ty, 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.oblivion_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)) - | None -> None - | Some (n,Cic.Def (bo,ty)) -> - Some - (n, - Cic.Def - (subst_in canonical_context' bo, - 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.oblivion_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.oblivion_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' subst context term' ty termty goal_arity = - let (consthead,newmetasenv,arguments,_) = - TermUtil.saturate_term newmeta' metasenv' context termty - goal_arity in - let subst,newmetasenv',_ = - CicUnification.fo_unif_subst - subst context newmetasenv consthead ty CicUniv.oblivion_ugraph - in - let t = - if List.length arguments = 0 then term' else Cic.Appl (term'::arguments) - in - subst,newmetasenv',t - -let rec count_prods subst context ty = - match CicReduction.whd ~subst context ty with - Cic.Prod (n,s,t) -> 1 + count_prods subst (Some (n,Cic.Decl s)::context) t - | _ -> 0 - -let apply_with_subst ~term ~maxmeta (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,subst,_,_, _) = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let newmeta = max (CicMkImplicit.new_meta metasenv subst) maxmeta 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' ~subst context term' CicUniv.oblivion_ugraph - in - let termty = - CicSubstitution.subst_vars exp_named_subst_diff termty in - let goal_arity = count_prods subst context ty in - let subst,newmetasenv',t = - let rec add_one_argument n = - try - new_metasenv_and_unify_and_t newmeta' metasenv' subst 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 *) - ((metano,(context,bo',Cic.Implicit None))::subst) - in - let (newproof, newmetasenv''') = - ProofEngineHelpers.subst_meta_and_metasenv_in_proof proof metano subst_in - newmetasenv'' - in - let subst = ((metano,(context,bo',ty))::subst) in - let newproof = - let u,m,_,p,t,l = newproof in - u,m,subst,p,t,l - in - subst, - (newproof, List.map (function (i,_,_) -> i) new_uninstantiatedmetas), - max maxmeta (CicMkImplicit.new_meta newmetasenv''' subst) - - -(* ALB *) -let apply_with_subst ~term ?(subst=[]) ?(maxmeta=0) status = - try - let status = - if subst <> [] then - let (u,m,_,p,t,l), g = status in (u,m,subst,p,t,l), g - else status - in - apply_with_subst ~term ~maxmeta status - with - | CicUnification.UnificationFailure msg - | CicTypeChecker.TypeCheckerFailure msg -> raise (PET.Fail msg) - -(* ALB *) -let apply_tac_verbose ~term status = - let subst, status, _ = apply_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 (PET.Fail msg) - in - PET.mk_tactic (apply_tac ~term) - -let applyP_tac ~term = - let applyP_tac status = - let res = PET.apply_tactic (apply_tac ~term) status in res - in - PET.mk_tactic applyP_tac - -let intros_tac ?howmany ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) ()= - let intros_tac (proof, goal) - = - let module C = Cic in - let module R = CicReduction in - let (_,metasenv,_subst,_,_, _) = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let newmeta = ProofEngineHelpers.new_meta_of_proof ~proof in - let (context',ty',bo') = - lambda_abstract ?howmany metasenv context newmeta ty mk_fresh_name_callback - in - let (newproof, _) = - ProofEngineHelpers.subst_meta_in_proof proof metano bo' - [newmeta,context',ty'] - in - (newproof, [newmeta]) - in - PET.mk_tactic intros_tac - -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,_subst,pbo,pty, attrs = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let newmeta1 = ProofEngineHelpers.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' = - Cic.LetIn (fresh_name, C.Meta (newmeta2,irl2), term, C.Meta (newmeta1,irl1)) - in - let (newproof, _) = - ProofEngineHelpers.subst_meta_in_proof proof metano bo' - [newmeta2,context,term; newmeta1,context_for_newmeta1,newmeta1ty]; - in - (newproof, [newmeta1 ; newmeta2]) - in - PET.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,_subst,pbo,pty, attrs = proof in - (* occur check *) - let occur i t = - let m = CicUtil.metas_of_term t in - List.exists (fun (j,_) -> i=j) m - in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - if occur metano term then - raise - (ProofEngineTypes.Fail (lazy - "You can't letin a term containing the current goal")); - let tty,_ = - CicTypeChecker.type_of_aux' metasenv context term CicUniv.oblivion_ugraph in - let newmeta = ProofEngineHelpers.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,tty)))::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,tty,C.Meta (newmeta,irl)) in - let (newproof, _) = - ProofEngineHelpers.subst_meta_in_proof - proof metano bo'[newmeta,context_for_newmeta,newmetaty] - in - (newproof, [newmeta]) - in - PET.mk_tactic (letin_tac ~mk_fresh_name_callback term) - -(* FG: exact_tac := apply_tac as in NTactics *) -let exact_tac ~term = apply_tac ~term - -(* not really "primitive" tactics .... *) - -module TC = CicTypeChecker -module UM = UriManager -module R = CicReduction -module C = Cic -module PEH = ProofEngineHelpers -module PER = ProofEngineReduction -module MS = CicMetaSubst -module S = CicSubstitution -module T = Tacticals -module RT = ReductionTactics - -let rec args_init n f = - if n <= 0 then [] else f n :: args_init (pred n) f - -let mk_predicate_for_elim - ~context ~metasenv ~subst ~ugraph ~goal ~arg ~using ~cpattern ~args_no -= - let instantiated_eliminator = - let f n = if n = 1 then arg else C.Implicit None in - C.Appl (using :: args_init args_no f) - in - let _actual_arg, iety, _metasenv', _ugraph = - CicRefine.type_of_aux' metasenv context instantiated_eliminator ugraph - in - let _actual_meta, actual_args = match iety with - | C.Meta (i, _) -> i, [] - | C.Appl (C.Meta (i, _) :: args) -> i, args - | _ -> assert false - in -(* let _, upto = PEH.split_with_whd (List.nth splits pred_pos) in *) - let rec mk_pred metasenv subst context' pred arg' cpattern' = function - | [] -> metasenv, subst, pred, arg' - | arg :: tail -> -(* FG: we find the predicate for the eliminator as in the rewrite tactic ****) - let argty, _ = TC.type_of_aux' metasenv ~subst context arg ugraph in - let argty = CicReduction.whd ~subst context argty in - let fresh_name = - FreshNamesGenerator.mk_fresh_name - ~subst metasenv context' C.Anonymous ~typ:argty in - let hyp = Some (fresh_name, C.Decl argty) in - let lazy_term c m u = - let distance = List.length c - List.length context in - S.lift distance arg, m, u in - let pattern = Some lazy_term, [], Some cpattern' in - let subst, metasenv, _ugraph, _conjecture, selected_terms = - ProofEngineHelpers.select ~subst ~metasenv ~ugraph - ~conjecture:(0, context, pred) ~pattern in - let metasenv = MS.apply_subst_metasenv subst metasenv in - let map (_context_of_t, t) l = t :: l in - let what = List.fold_right map selected_terms [] in - let arg' = MS.apply_subst subst arg' in - let pred = PER.replace_with_rel_1_from ~equality:(==) ~what 1 pred in - let pred = MS.apply_subst subst pred in - let pred = C.Lambda (fresh_name, C.Implicit None, pred) in - let cpattern' = C.Lambda (C.Anonymous, C.Implicit None, cpattern') in - mk_pred metasenv subst (hyp :: context') pred arg' cpattern' tail - in - let metasenv, subst, pred, arg = - mk_pred metasenv subst context goal arg cpattern (List.rev actual_args) - in - HLog.debug ("PREDICATE CONTEXT:\n" ^ CicPp.ppcontext ~metasenv context); - HLog.debug ("PREDICATE: " ^ CicPp.ppterm ~metasenv pred ^ " ARGS: " ^ String.concat " " (List.map (CicPp.ppterm ~metasenv) actual_args)); - metasenv, subst, pred, arg, actual_args - -let beta_after_elim_tac upto predicate = - let beta_after_elim_tac status = - let proof, goal = status in - let _, metasenv, _subst, _, _, _ = proof in - let _, _, ty = CicUtil.lookup_meta goal metasenv in - let mk_pattern ~equality ~upto ~predicate ty = - (* code adapted from ProceduralConversion.generalize *) - let meta = C.Implicit None in - let hole = C.Implicit (Some `Hole) in - let anon = C.Anonymous in - let is_meta = - let map b = function - | C.Implicit None when b -> b - | _ -> false - in - List.fold_left map true - in - let rec gen_fix len k (name, i, ty, bo) = - name, i, gen_term k ty, gen_term (k + len) bo - and gen_cofix len k (name, ty, bo) = - name, gen_term k ty, gen_term (k + len) bo - and gen_term k = function - | C.Sort _ - | C.Implicit _ - | C.Const (_, _) - | C.Var (_, _) - | C.MutInd (_, _, _) - | C.MutConstruct (_, _, _, _) - | C.Meta (_, _) - | C.Rel _ -> meta - | C.Appl (hd :: tl) when equality hd (S.lift k predicate) -> - assert (List.length tl = upto); - hole - | C.Appl ts -> - let ts = List.map (gen_term k) ts in - if is_meta ts then meta else C.Appl ts - | C.Cast (te, ty) -> - let te, ty = gen_term k te, gen_term k ty in - if is_meta [te; ty] then meta else C.Cast (te, ty) - | C.MutCase (sp, i, outty, t, pl) -> - let outty, t, pl = gen_term k outty, gen_term k t, List.map (gen_term k) pl in - if is_meta (outty :: t :: pl) then meta else hole (* C.MutCase (sp, i, outty, t, pl) *) - | C.Prod (_, s, t) -> - let s, t = gen_term k s, gen_term (succ k) t in - if is_meta [s; t] then meta else C.Prod (anon, s, t) - | C.Lambda (_, s, t) -> - let s, t = gen_term k s, gen_term (succ k) t in - if is_meta [s; t] then meta else C.Lambda (anon, s, t) - | C.LetIn (_, s, ty, t) -> - let s,ty,t = gen_term k s, gen_term k ty, gen_term (succ k) t in - if is_meta [s; t] then meta else C.LetIn (anon, s, ty, t) - | C.Fix (i, fl) -> C.Fix (i, List.map (gen_fix (List.length fl) k) fl) - | C.CoFix (i, fl) -> C.CoFix (i, List.map (gen_cofix (List.length fl) k) fl) - in - None, [], Some (gen_term 0 ty) - in - let equality = CicUtil.alpha_equivalence in - let pattern = mk_pattern ~equality ~upto ~predicate ty in - let tactic = RT.head_beta_reduce_tac ~delta:false ~upto ~pattern in - PET.apply_tactic tactic status - in - PET.mk_tactic beta_after_elim_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,_) status - = - if hyps_pat <> [] then raise GeneralizationInHypothesesNotImplementedYet; - let (proof, goal) = status in - let module C = Cic in - let module T = Tacticals in - let uri,metasenv,subst,pbo,pty, attrs = 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 ~subst ~ugraph:CicUniv.oblivion_ugraph - ~conjecture ~pattern in - let context = CicMetaSubst.apply_subst_context subst context in - let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in - let pbo = lazy (CicMetaSubst.apply_subst subst (Lazy.force 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,e_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 (e_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',subst,pbo,pty, attrs),goal in - let proof,goals = - PET.apply_tactic - (T.thens - ~start: - (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: - [(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) -;; - -let generalize_pattern_tac pattern = - let generalize_pattern_tac (proof,goal) = - let _,metasenv,_,_,_,_ = proof in - let conjecture = CicUtil.lookup_meta goal metasenv in - let _,context,_ = conjecture in - let generalize_hyps = - let _,hpatterns,_ = ProofEngineHelpers.sort_pattern_hyps context pattern in - List.map fst hpatterns in - let ids_and_patterns = - List.map - (fun id -> - let rel,_ = ProofEngineHelpers.find_hyp id context in - id,(Some (fun ctx m u -> CicSubstitution.lift (List.length ctx - List.length context) rel,m,u), [], Some (ProofEngineTypes.hole)) - ) generalize_hyps in - let tactics = - List.map - (function (id,pattern) -> - Tacticals.then_ ~start:(generalize_tac pattern) - ~continuation:(Tacticals.try_tactic - (ProofEngineStructuralRules.clear [id])) - ) ids_and_patterns - in - PET.apply_tactic (Tacticals.seq tactics) (proof,goal) - in - PET.mk_tactic (generalize_pattern_tac) -;; - -let pattern_after_generalize_pattern_tac (tp, hpatterns, cpattern) = - let cpattern = - match cpattern with - None -> ProofEngineTypes.hole - | Some t -> t - in - let cpattern = - List.fold_left - (fun t (_,ty) -> Cic.Prod (Cic.Anonymous, ty, t)) cpattern hpatterns - in - tp, [], Some cpattern -;; - -let elim_tac ?using ?(pattern = PET.conclusion_pattern None) term = - let elim_tac pattern (proof, goal) = - let ugraph = CicUniv.oblivion_ugraph in - let curi, metasenv, subst, proofbo, proofty, attrs = proof in - let conjecture = CicUtil.lookup_meta goal metasenv in - let metano, context, ty = conjecture in - let pattern = pattern_after_generalize_pattern_tac pattern in - let cpattern = - match pattern with - | None, [], Some cpattern -> cpattern - | _ -> raise (PET.Fail (lazy "not implemented")) in - let termty,_ugraph = TC.type_of_aux' metasenv ~subst context term ugraph in - let termty = CicReduction.whd ~subst context termty in - let termty, metasenv', arguments, _fresh_meta = - TermUtil.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 = UM.buri_of_uri uri in - let name = - let o,_ugraph = CicEnvironment.get_obj ugraph uri in - match o with - C.InductiveDefinition (tys,_,_,_) -> - let (name,_,_,_) = List.nth tys typeno in - name - | _ -> assert false - in - let ty_ty,_ugraph = TC.type_of_aux' metasenv' ~subst context ty ugraph in - let ext = - match ty_ty with - C.Sort C.Prop -> "_ind" - | C.Sort C.Set -> "_rec" - | C.Sort (C.CProp _) -> "_rect" - | C.Sort (C.Type _)-> "_rect" - | C.Meta (_,_) -> raise TheTypeOfTheCurrentGoalIsAMetaICannotChooseTheRightElimiantionPrinciple - | _ -> assert false - in - UM.uri_of_string (buri ^ "/" ^ name ^ ext ^ ".con") - in - let eliminator_ref = match using with - | None -> C.Const (eliminator_uri, exp_named_subst) - | Some t -> t - in - let ety, _ugraph = - TC.type_of_aux' metasenv' ~subst context eliminator_ref ugraph in -(* FG: ADDED PART ***********************************************************) -(* FG: we can not assume eliminator is the default eliminator ***************) - let splits, args_no = PEH.split_with_whd (context, ety) in - let pred_pos = match List.hd splits with - | _, C.Rel i when i > 1 && i <= args_no -> i - | _, C.Appl (C.Rel i :: _) when i > 1 && i <= args_no -> i - | _ -> raise NotAnEliminator - in - let metasenv', subst, pred, term, actual_args = match pattern with - | None, [], Some (C.Implicit (Some `Hole)) -> - metasenv', subst, C.Implicit None, term, [] - | _ -> - mk_predicate_for_elim - ~args_no ~context ~ugraph ~cpattern - ~metasenv:metasenv' ~subst ~arg:term ~using:eliminator_ref ~goal:ty - in -(* FG: END OF ADDED PART ****************************************************) - let term_to_refine = - let f n = - if n = pred_pos then pred else - if n = 1 then term else C.Implicit None - in - C.Appl (eliminator_ref :: args_init args_no f) - in - let refined_term,_refined_termty,metasenv'',subst,_ugraph = - CicRefine.type_of metasenv' subst context term_to_refine ugraph - in - let ipred = match refined_term with - | C.Appl ts -> List.nth ts (List.length ts - pred_pos) - | _ -> assert false - in - let new_goals = - ProofEngineHelpers.compare_metasenvs - ~oldmetasenv:metasenv ~newmetasenv:metasenv'' - in - let proof' = curi,metasenv'',subst,proofbo,proofty, attrs in - let proof'', new_goals' = - PET.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 - let res = proof'', patched_new_goals in - let upto = List.length actual_args in - if upto = 0 then res else -(* FG: we use ipred (instantiated pred) instead of pred (not instantiated) *) - let continuation = beta_after_elim_tac upto ipred in - let dummy_status = proof,goal in - PET.apply_tactic - (T.then_ ~start:(PET.mk_tactic (fun _ -> res)) ~continuation) - dummy_status - in - let reorder_pattern ((proof, goal) as status) = - let _,metasenv,_,_,_,_ = proof in - let conjecture = CicUtil.lookup_meta goal metasenv in - let _,context,_ = conjecture in - let pattern = ProofEngineHelpers.sort_pattern_hyps context pattern in - PET.apply_tactic - (Tacticals.then_ ~start:(generalize_pattern_tac pattern) - ~continuation:(PET.mk_tactic (elim_tac pattern))) status - in - PET.mk_tactic reorder_pattern -;; - -let cases_intros_tac ?(howmany=(-1)) ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) ?(pattern = PET.conclusion_pattern None) term = - let cases_tac pattern (proof, goal) = - let module TC = CicTypeChecker in - let module U = UriManager in - let module R = CicReduction in - let module C = Cic in - let (curi,metasenv,_subst, proofbo,proofty, attrs) = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - let pattern = pattern_after_generalize_pattern_tac pattern in - let _cpattern = - match pattern with - | None, [], Some cpattern -> - let rec is_hole = - function - Cic.Implicit (Some `Hole) -> true - | Cic.Prod (Cic.Anonymous,so,tgt) -> is_hole so && is_hole tgt - | _ -> false - in - if not (is_hole cpattern) then - raise (PET.Fail (lazy "not implemented")) - | _ -> raise (PET.Fail (lazy "not implemented")) in - let termty,_ = TC.type_of_aux' metasenv context term CicUniv.oblivion_ugraph in - let termty = CicReduction.whd context termty in - let (termty,metasenv',arguments,fresh_meta) = - TermUtil.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 paramsno,itty,patterns,right_args = - match CicEnvironment.get_obj CicUniv.oblivion_ugraph uri with - | C.InductiveDefinition (tys,_,paramsno,_),_ -> - let _,left_parameters,right_args = - List.fold_right - (fun x (n,acc1,acc2) -> - if n > 0 then (n-1,acc1,x::acc2) else (n,x::acc1,acc2)) - args (List.length args - paramsno, [],[]) - in - let _,_,itty,cl = List.nth tys typeno in - let rec aux left_parameters context t = - match left_parameters,CicReduction.whd context t with - | [],C.Prod (name,source,target) -> - let fresh_name = - mk_fresh_name_callback metasenv' context name ~typ:source - in - C.Lambda (fresh_name,C.Implicit None, - aux [] (Some (fresh_name,C.Decl source)::context) target) - | hd::tl,C.Prod (name,source,target) -> - (* left parameters instantiation *) - aux tl context (CicSubstitution.subst hd target) - | [],_ -> C.Implicit None - | _ -> assert false - in - paramsno,itty, - List.map (function (_,cty) -> aux left_parameters context cty) cl, - right_args - | _ -> assert false - in - let outtypes = - let n_right_args = List.length right_args in - let n_lambdas = n_right_args + 1 in - let lifted_ty = CicSubstitution.lift n_lambdas ty in - let captured_ty = - let what = - List.map (CicSubstitution.lift n_lambdas) (right_args) - in - let with_what meta = - let rec mkargs = function - | 0 -> assert false - | 1 -> [] - | n -> - (if meta then Cic.Implicit None else Cic.Rel n)::(mkargs (n-1)) - in - mkargs n_lambdas - in - let replaced = ref false in - let replace = ProofEngineReduction.replace_lifting - ~equality:(fun _ a b -> let rc = CicUtil.alpha_equivalence a b in - if rc then replaced := true; rc) - ~context:[] - in - let captured = - replace ~what:[CicSubstitution.lift n_lambdas term] - ~with_what:[Cic.Rel 1] ~where:lifted_ty - in - if not !replaced then - (* this means the matched term is not there, - * but maybe right params are: we user rels (to right args lambdas) *) - [replace ~what ~with_what:(with_what false) ~where:captured] - else - (* since the matched is there, rights should be inferrable *) - [replace ~what ~with_what:(with_what false) ~where:captured; - replace ~what ~with_what:(with_what true) ~where:captured] - in - let captured_term_ty = - let term_ty = CicSubstitution.lift n_right_args termty in - let rec mkrels = function 0 -> []|n -> (Cic.Rel n)::(mkrels (n-1)) in - let rec fstn acc l n = - if n = 0 then acc else fstn (acc@[List.hd l]) (List.tl l) (n-1) - in - match term_ty with - | C.MutInd _ -> term_ty - | C.Appl ((C.MutInd (a,b,c))::args) -> - C.Appl ((C.MutInd (a,b,c)):: - fstn [] args paramsno @ mkrels n_right_args) - | _ -> raise NotAnInductiveTypeToEliminate - in - let rec add_lambdas captured_ty = function - | 0 -> captured_ty - | 1 -> - C.Lambda (C.Name "matched", captured_term_ty, (add_lambdas captured_ty 0)) - | n -> - C.Lambda (C.Name ("right_"^(string_of_int (n-1))), - C.Implicit None, (add_lambdas captured_ty (n-1))) - in - List.map (fun x -> add_lambdas x n_lambdas) captured_ty - in - let rec first = (* easier than using tacticals *) - function - | [] -> raise (PET.Fail (lazy ("unable to generate a working outtype"))) - | outtype::rest -> - let term_to_refine = C.MutCase (uri,typeno,outtype,term,patterns) in - try - let refined_term,_,metasenv'',_ = - CicRefine.type_of_aux' metasenv' context term_to_refine - CicUniv.oblivion_ugraph - in - let new_goals = - ProofEngineHelpers.compare_metasenvs - ~oldmetasenv:metasenv ~newmetasenv:metasenv'' - in - let proof' = curi,metasenv'',_subst,proofbo,proofty, attrs in - let proof'', new_goals' = - PET.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''',_subst,_,_,_) = proof'' in - List.filter - (function i -> List.exists (function (j,_,_) -> j=i) metasenv''') - new_goals @ new_goals' - in - proof'', patched_new_goals - with PET.Fail _ | CicRefine.RefineFailure _ | CicRefine.Uncertain _ -> first rest - in - first outtypes - in - let reorder_pattern ((proof, goal) as status) = - let _,metasenv,_,_,_,_ = proof in - let conjecture = CicUtil.lookup_meta goal metasenv in - let _,context,_ = conjecture in - let pattern = ProofEngineHelpers.sort_pattern_hyps context pattern in - PET.apply_tactic - (Tacticals.then_ ~start:(generalize_pattern_tac pattern) - ~continuation:(PET.mk_tactic (cases_tac pattern))) status - in - PET.mk_tactic reorder_pattern -;; - - -let elim_intros_tac ?(mk_fresh_name_callback = FreshNamesGenerator.mk_fresh_name ~subst:[]) - ?depth ?using ?pattern what = - Tacticals.then_ ~start:(elim_tac ?using ?pattern 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 ?pattern what = - Tacticals.then_ ~start:(elim_tac ?using ?pattern what) - ~continuation: - (Tacticals.thens - ~start:(intros_tac ~mk_fresh_name_callback ?howmany:depth ()) - ~continuations: - [ReductionTactics.simpl_tac - ~pattern:(ProofEngineTypes.conclusion_pattern None)]) -;; diff --git a/matita/components/tactics/primitiveTactics.mli b/matita/components/tactics/primitiveTactics.mli deleted file mode 100644 index f2178fb38..000000000 --- a/matita/components/tactics/primitiveTactics.mli +++ /dev/null @@ -1,103 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(**** useful only to implement tactics similar to apply ****) - -val generalize_exp_named_subst_with_fresh_metas : - Cic.context -> - int -> - UriManager.uri -> - (UriManager.uri * Cic.term) list -> - int * Cic.metasenv * - Cic.term Cic.explicit_named_substitution * - Cic.term Cic.explicit_named_substitution - -val classify_metas : - Cic.term -> - (Cic.term -> bool) -> - (Cic.context -> Cic.term -> Cic.term) -> - (Cic.term * Cic.context * Cic.term) list -> - (Cic.term * Cic.context * Cic.term) list * - (Cic.term * Cic.context * Cic.term) list - -(* Not primitive, but useful for elim *) - -exception AllSelectedTermsMustBeConvertible;; - -val generalize_tac: - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ProofEngineTypes.lazy_pattern -> - ProofEngineTypes.tactic - -(* not a real tactic *) -val apply_tac_verbose : - term:Cic.term -> - ProofEngineTypes.proof * int -> - (Cic.term -> Cic.term) * (ProofEngineTypes.proof * int list) - -(* the proof status has a subst now, and apply_tac honors it *) -val apply_tac: - term: Cic.term -> ProofEngineTypes.tactic -val applyP_tac: (* apply for procedural reconstruction *) - 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 -> - ?pattern:ProofEngineTypes.lazy_pattern -> Cic.term -> - ProofEngineTypes.tactic -val elim_intros_tac: - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?depth:int -> ?using:Cic.term -> - ?pattern:ProofEngineTypes.lazy_pattern -> Cic.term -> - ProofEngineTypes.tactic - -val cases_intros_tac: - ?howmany:int -> - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?pattern:ProofEngineTypes.lazy_pattern -> Cic.term -> - ProofEngineTypes.tactic - -(* FG *) - -val mk_predicate_for_elim: - context:Cic.context -> metasenv:Cic.metasenv -> subst:Cic.substitution -> - ugraph:CicUniv.universe_graph -> goal:Cic.term -> - arg:Cic.term -> using:Cic.term -> cpattern:Cic.term -> args_no:int -> - Cic.metasenv * Cic.substitution * Cic.term * Cic.term * Cic.term list diff --git a/matita/components/tactics/proofEngineHelpers.ml b/matita/components/tactics/proofEngineHelpers.ml deleted file mode 100644 index d95d37d8c..000000000 --- a/matita/components/tactics/proofEngineHelpers.ml +++ /dev/null @@ -1,735 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -exception Bad_pattern of string Lazy.t - -let new_meta_of_proof ~proof:(_, metasenv, subst, _, _, _) = - CicMkImplicit.new_meta metasenv subst - -let subst_meta_in_proof proof meta term newmetasenv = - let uri,metasenv,initial_subst,bo,ty, attrs = 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)) - | None -> None - | Some (n,Cic.Def (bo,ty)) -> - Some (n,Cic.Def (subst_in bo,subst_in ty)) - ) canonical_context - in - i,canonical_context',(subst_in ty) - ) metasenv' - in - let bo' = lazy (subst_in (Lazy.force 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'',initial_subst,bo',ty', attrs 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 newmetasenv = - let (uri,_,initial_subst,bo,ty, attrs) = proof in - let subst_in = CicMetaSubst.apply_subst subst in - let bo' = lazy (subst_in (Lazy.force 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 (bo,ty)) -> - Some (i,Cic.Def (subst_in bo,subst_in ty)) - ) canonical_context - in - (m,canonical_context',subst_in ty)::i - | _ -> i - ) newmetasenv [] - in - (* qui da capire se per la fase transitoria si fa initial_subst @ subst - * oppure subst *) - let newproof = uri,metasenv',subst,bo',ty', attrs 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, t3) -> - let subst,metasenv,ugraph,rest1 = - find subst metasenv ugraph context w t1 in - let subst,metasenv,ugraph,rest2 = - find subst metasenv ugraph context w t2 in - let subst,metasenv,ugraph,rest3 = - find subst metasenv ugraph (Some (name, Cic.Def (t1,t2))::context) - (CicSubstitution.lift 1 w) t3 - in - subst,metasenv,ugraph,rest1 @ rest2 @ rest3 - | 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 ~subst ~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, ty1, t1), Cic.LetIn (name, s2, ty2, t2) -> - aux context s1 s2 @ - aux context ty1 ty2 @ - aux (add_ctx context name (Cic.Def (s2,ty2))) t1 t2 - | Cic.LetIn (Cic.Name n1, s1, ty1, t1), - Cic.LetIn ((Cic.Name n2) as name, s2, ty2, t2) when n1 = n2-> - aux context s1 s2 @ - aux context ty1 ty2 @ - aux (add_ctx context name (Cic.Def (s2,ty2))) t1 t2 - | Cic.LetIn (name1, s1, ty1, t1), Cic.LetIn (name2, s2, ty2, 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 -> subst,metasenv,ugraph,roots - | Some wanted -> - let rec find_in_roots subst = - function - [] -> subst,metasenv,ugraph,[] - | (context',where)::tl -> - let subst,metasenv,ugraph,tl' = find_in_roots subst 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 subst 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 (_, s, t) -> - let b1,s = aux s in - let b2,t = aux t in - if b1||b2 then - true, Cic.Prod (Cic.Anonymous, s, t) - else - not_found - | Cic.Lambda (_, s, t) -> - let b1,s = aux s in - let b2,t = aux t in - if b1||b2 then - true, Cic.Lambda (Cic.Anonymous, s, t) - else - not_found - | Cic.LetIn (_, s, ty, t) -> - let b1,s = aux s in - let b2,ty = aux ty in - let b3,t = aux t in - if b1||b2||b3 then - true, Cic.LetIn (Cic.Anonymous, s, ty, 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 ~subst ~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 - (* Multiple hypotheses with the same name can be in the context. - In this case we need to pick the last one, but we will perform - a fold_right on the context. Thus we pre-process hyp_patterns. *) - let full_hyp_pattern = - let rec aux blacklist = - function - [] -> [] - | None::tl -> None::aux blacklist tl - | Some (name,_)::tl -> - if List.mem name blacklist then - None::aux blacklist tl - else - find_pattern_for name::aux (name::blacklist) tl - in - aux [] context - in - let subst,metasenv,ugraph,ty_terms = - select_in_term ~metasenv ~subst ~context ~ugraph ~term:ty - ~pattern:(what,goal_pattern) - in - let subst,metasenv,ugraph,context_terms = - let subst,metasenv,ugraph,res,_ = - (List.fold_right - (fun (pattern,entry) (subst,metasenv,ugraph,res,context) -> - match entry with - None -> subst,metasenv,ugraph,None::res,None::context - | Some (name,Cic.Decl term) -> - (match pattern with - | None -> - subst,metasenv,ugraph,((Some (`Decl []))::res),(entry::context) - | Some pat -> - let subst,metasenv,ugraph,terms = - select_in_term ~subst ~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 pattern with - | None -> - let selected_ty = [] in - subst,metasenv,ugraph,((Some (`Def ([],selected_ty)))::res), - (entry::context) - | Some pat -> - let subst,metasenv,ugraph,terms_bo = - select_in_term ~subst ~metasenv ~context ~ugraph ~term:bo - ~pattern:(what, Some pat) in - let subst,metasenv,ugraph,terms_ty = - let subst,metasenv,ugraph,res = - select_in_term ~subst ~metasenv ~context ~ugraph ~term:ty - ~pattern:(what, Some pat) - in - subst,metasenv,ugraph,res - in - subst,metasenv,ugraph,((Some (`Def (terms_bo,terms_ty)))::res), - (entry::context)) - ) (List.combine full_hyp_pattern 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, ty, t) -> - aux context s @ - aux context ty @ - aux (add_ctx context name (Cic.Def (s,ty))) 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 = 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 - -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 (_,t)) :: _ when name = hyp -> p, t - | _ :: tail -> aux (succ p) tail - | [] -> raise (ProofEngineTypes.Fail (lazy "lookup_type: not premise in the current goal")) - in - aux 1 context - -let find_hyp name = - 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 _)::_ when name = s -> assert false (*CSC: not implemented yet! But does this make any sense?*) - | _::tl -> find_hyp (n+1) tl - in - find_hyp 1 -;; - -(* sort pattern hypotheses from the smallest to the highest Rel *) -let sort_pattern_hyps context (t,hpatterns,cpattern) = - let hpatterns = - List.sort - (fun (id1,_) (id2,_) -> - let t1,_ = find_hyp id1 context in - let t2,_ = find_hyp id2 context in - match t1,t2 with - Cic.Rel n1, Cic.Rel n2 -> compare n1 n2 - | _,_ -> assert false) hpatterns - in - t,hpatterns,cpattern -;; - -(* FG: **********************************************************************) - -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 get_rel context name = - let rec aux i = function - | [] -> None - | Some (Cic.Name s, _) :: _ when s = name -> Some (Cic.Rel i) - | _ :: tl -> aux (succ i) tl - in - aux 1 context - -let split_with_whd (c, t) = - let add s v c = Some (s, Cic.Decl v) :: c in - let rec aux whd a n c = function - | Cic.Prod (s, v, t) -> aux false ((c, v) :: a) (succ n) (add s v c) t - | v when whd -> (c, v) :: a, n - | v -> aux true a n c (CicReduction.whd c v) - in - aux false [] 0 c t - -let split_with_normalize (c, t) = - let add s v c = Some (s, Cic.Decl v) :: c in - let rec aux a n c = function - | Cic.Prod (s, v, t) -> aux ((c, v) :: a) (succ n) (add s v c) t - | v -> (c, v) :: a, n - in - aux [] 0 c (CicReduction.normalize c t) - - (* menv sorting *) -module OT = - struct - type t = Cic.conjecture - let compare (i,_,_) (j,_,_) = Pervasives.compare i j - end -module MS = HTopoSort.Make(OT) -let relations_of_menv m c = - let i, ctx, ty = c in - let m = List.filter (fun (j,_,_) -> j <> i) m in - let m_ty = List.map fst (CicUtil.metas_of_term ty) in - let m_ctx = - List.flatten - (List.map - (function - | None -> [] - | Some (_,Cic.Decl t) -> - List.map fst (CicUtil.metas_of_term ty) - | Some (_,Cic.Def (t,ty)) -> - List.map fst (CicUtil.metas_of_term ty) @ - List.map fst (CicUtil.metas_of_term t)) - ctx) - in - let metas = HExtlib.list_uniq (List.sort compare (m_ty @ m_ctx)) in - List.filter (fun (i,_,_) -> List.exists ((=) i) metas) m -;; -let sort_metasenv (m : Cic.metasenv) = - (MS.topological_sort m (relations_of_menv m) : Cic.metasenv) -;; diff --git a/matita/components/tactics/proofEngineHelpers.mli b/matita/components/tactics/proofEngineHelpers.mli deleted file mode 100644 index c57efff5d..000000000 --- a/matita/components/tactics/proofEngineHelpers.mli +++ /dev/null @@ -1,138 +0,0 @@ -(* Copyright (C) 2000-2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception Bad_pattern of string Lazy.t - -(* Returns the first meta whose number is above the *) -(* number of the higher meta. *) -val new_meta_of_proof : proof:ProofEngineTypes.proof -> int - -val subst_meta_in_proof : - ProofEngineTypes.proof -> - int -> Cic.term -> Cic.metasenv -> - ProofEngineTypes.proof * Cic.metasenv -val subst_meta_and_metasenv_in_proof : - ProofEngineTypes.proof -> - int -> Cic.substitution -> 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 -> - subst:Cic.substitution -> - 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 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 - -(* returns the index and the type of a premise in a context *) -val lookup_type: Cic.metasenv -> Cic.context -> string -> int * Cic.term - -(* orders a metasenv w.r.t. dependency among metas *) -val sort_metasenv: Cic.metasenv -> Cic.metasenv - -(* finds an hypothesis by name in the context *) -val find_hyp: string -> Cic.context -> Cic.term * Cic.term - -(* sort pattern hypotheses from the smallest to the highest Rel *) -val sort_pattern_hyps: - Cic.context -> ProofEngineTypes.lazy_pattern -> ProofEngineTypes.lazy_pattern - - -(* FG: some helper functions ************************************************) - -val get_name: Cic.context -> int -> string option - -val get_rel: Cic.context -> string -> Cic.term option - -(* split_with_whd (c, t) takes a type t typed in the context c and returns - [(c_0, t_0); (c_1, t_1); ...; (c_n, t_n)], n where t_0 is the conclusion of - t and t_i is the premise of t accessed by Rel i in t_0. - Performes a whd on the conclusion before giving up. - Each t_i is returned with a context c_i in wich it is typed - split_with_normalize (c, t) normalizes t before operating the split - whd is useless here -*) -val split_with_whd: Cic.context * Cic.term -> - (Cic.context * Cic.term) list * int -val split_with_normalize: Cic.context * Cic.term -> - (Cic.context * Cic.term) list * int diff --git a/matita/components/tactics/proofEngineReduction.ml b/matita/components/tactics/proofEngineReduction.ml deleted file mode 100644 index d5dbf9f35..000000000 --- a/matita/components/tactics/proofEngineReduction.ml +++ /dev/null @@ -1,926 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(******************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 12/04/2002 *) -(* *) -(* *) -(******************************************************************************) - -(* $Id$ *) - -(* The code of this module is derived from the code of CicReduction *) - -exception Impossible of int;; -exception ReferenceToConstant;; -exception ReferenceToVariable;; -exception ReferenceToCurrentProof;; -exception ReferenceToInductiveDefinition;; -exception WrongUriToInductiveDefinition;; -exception WrongUriToConstant;; -exception RelToHiddenHypothesis;; - -module C = Cic -module S = CicSubstitution - -let debug = false -let prerr_endline = - if debug then prerr_endline else (fun x -> ()) -;; - -exception WhatAndWithWhatDoNotHaveTheSameLength;; - -(* Replaces "textually" in "where" every term in "what" with the corresponding - term in "with_what". The terms in "what" ARE NOT lifted when binders are - crossed. The terms in "with_what" ARE NOT lifted when binders are crossed. - Every free variable in "where" IS NOT lifted by nnn. -*) -let replace ~equality ~what ~with_what ~where = - 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,ty,t) -> C.LetIn (n, aux s, aux ty, 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 "where" every term in "what" with the corresponding - term in "with_what". The terms in "what" ARE lifted when binders are - crossed. The terms in "with_what" ARE lifted when binders are crossed. - Every free variable in "where" IS NOT lifted by nnn. - Thus "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]" is the - inverse of subst up to the fact that free variables in "where" are NOT - lifted. *) -let replace_lifting ~equality ~context ~what ~with_what ~where = - let find_image ctx what t = - let rec find_image_aux = - function - [],[] -> raise Not_found - | what::tl1,with_what::tl2 -> - if equality ctx what t then with_what else find_image_aux (tl1,tl2) - | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength - in - find_image_aux (what,with_what) - in - let add_ctx ctx n s = (Some (n, Cic.Decl s))::ctx in - let add_ctx1 ctx n s ty = (Some (n, Cic.Def (s,ty)))::ctx in - let rec substaux k ctx what t = - try - S.lift (k-1) (find_image ctx 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 ctx 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 ctx 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 ctx what te, substaux k ctx what ty) - | C.Prod (n,s,t) -> - C.Prod - (n, substaux k ctx what s, substaux (k + 1) (add_ctx ctx n s) (List.map (S.lift 1) what) t) - | C.Lambda (n,s,t) -> - C.Lambda - (n, substaux k ctx what s, substaux (k + 1) (add_ctx ctx n s) (List.map (S.lift 1) what) t) - | C.LetIn (n,s,ty,t) -> - C.LetIn - (n, substaux k ctx what s, substaux k ctx what ty, substaux (k + 1) (add_ctx1 ctx n s ty) (List.map (S.lift 1) what) t) - | C.Appl (he::tl) -> - (* Invariant: no Appl applied to another Appl *) - let tl' = List.map (substaux k ctx what) tl in - begin - match substaux k ctx 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 ctx 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 ctx 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 ctx 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 ctx what outt, substaux k ctx what t, - List.map (substaux k ctx what) pl) - | C.Fix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,i,ty,bo) -> (* WRONG CTX *) - (name, i, substaux k ctx what ty, - substaux (k+len) ctx (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) -> (* WRONG CTX *) - (name, substaux k ctx what ty, - substaux (k+len) ctx (List.map (S.lift len) what) bo) - ) fl - in - C.CoFix (i, substitutedfl) - in - substaux 1 context what where -;; - -(* Replaces in "where" every term in "what" with the corresponding - term in "with_what". The terms in "what" ARE NOT lifted when binders are - crossed. The terms in "with_what" ARE lifted when binders are crossed. - Every free variable in "where" IS lifted by nnn. - Thus "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]" is the - inverse of subst up to the fact that "what" terms are NOT lifted. *) -let replace_lifting_csc nnn ~equality ~what ~with_what ~where = - 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,ty,t) -> - C.LetIn (n, substaux k s, substaux k ty, 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 -;; - -(* This is like "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]" - up to the fact that the index to start from can be specified *) -let replace_with_rel_1_from ~equality ~what = - let rec find_image t = function - | [] -> false - | hd :: tl -> equality t hd || find_image t tl - in - let rec subst_term k t = - if find_image t what then C.Rel k else inspect_term k t - and inspect_term k = function - | C.Rel i -> if i < k then C.Rel i else C.Rel (succ i) - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Var (uri, enss) -> - let enss = List.map (subst_ens k) enss in - C.Var (uri, enss) - | C.Const (uri ,enss) -> - let enss = List.map (subst_ens k) enss in - C.Const (uri, enss) - | C.MutInd (uri, tyno, enss) -> - let enss = List.map (subst_ens k) enss in - C.MutInd (uri, tyno, enss) - | C.MutConstruct (uri, tyno, consno, enss) -> - let enss = List.map (subst_ens k) enss in - C.MutConstruct (uri, tyno, consno, enss) - | C.Meta (i, mss) -> - let mss = List.map (subst_ms k) mss in - C.Meta(i, mss) - | C.Cast (t, v) -> C.Cast (subst_term k t, subst_term k v) - | C.Appl ts -> - let ts = List.map (subst_term k) ts in - C.Appl ts - | C.MutCase (uri, tyno, outty, t, cases) -> - let cases = List.map (subst_term k) cases in - C.MutCase (uri, tyno, subst_term k outty, subst_term k t, cases) - | C.Prod (n, v, t) -> - C.Prod (n, subst_term k v, subst_term (succ k) t) - | C.Lambda (n, v, t) -> - C.Lambda (n, subst_term k v, subst_term (succ k) t) - | C.LetIn (n, v, ty, t) -> - C.LetIn (n, subst_term k v, subst_term k ty, subst_term (succ k) t) - | C.Fix (i, fixes) -> - let fixesno = List.length fixes in - let fixes = List.map (subst_fix fixesno k) fixes in - C.Fix (i, fixes) - | C.CoFix (i, cofixes) -> - let cofixesno = List.length cofixes in - let cofixes = List.map (subst_cofix cofixesno k) cofixes in - C.CoFix (i, cofixes) - and subst_ens k (uri, t) = uri, subst_term k t - and subst_ms k = function - | None -> None - | Some t -> Some (subst_term k t) - and subst_fix fixesno k (n, ind, ty, bo) = - n, ind, subst_term k ty, subst_term (k + fixesno) bo - and subst_cofix cofixesno k (n, ty, bo) = - n, subst_term k ty, subst_term (k + cofixesno) bo -in -subst_term - -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.oblivion_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.oblivion_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 -;; - -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 = - (* a simplified term is active if it can create a redex when used as an *) - (* actual parameter *) - let rec is_active = - function - C.Lambda _ - | C.MutConstruct _ - | C.Appl (C.MutConstruct _::_) - | C.CoFix _ -> true - | C.Cast (bo,_) -> is_active bo - | C.LetIn _ -> assert false - | _ -> false - in - (* reduceaux is equal to the reduceaux locally defined inside *) - (* reduce, but for the const case. *) - (**** Step 1 ****) - let rec reduceaux context l = - 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.oblivion_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,ty,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.oblivion_ugraph uri in - match o with - C.Constant (_,Some body,_,_,_) -> - if List.exists is_active l then - try_delta_expansion context l - (C.Const (uri,exp_named_subst')) - (CicSubstitution.subst_vars exp_named_subst' body) - else - let t' = C.Const (uri,exp_named_subst') in - if l = [] then t' else C.Appl (t'::l) - | 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 (reduceaux context [] term) (*(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.oblivion_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.fold_left - (fun (types,len) (n,_,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) 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.fold_left - (fun (types,len) (n,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) 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 reduce_with_no_hope_to_fold_back t l = - prerr_endline "reduce_with_no_hope_to_fold_back"; - let simplified = reduceaux context l t in - let t' = if l = [] then t else C.Appl (t::l) in - if t' = simplified then - raise AlreadySimplified - else - simplified - - and try_delta_expansion context l term body = - 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 reduceaux context [] recparam (*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_lifting ~equality:(fun _ x y -> x = y) ~context - ~what:[simplified_term_to_fold] ~with_what:[term_to_fold] ~where:res - with - WrongShape -> - let rec skip_lambda n = function - | Cic.Lambda (_,_,t) -> skip_lambda (n+1) t | t -> t, n - in - let is_fix uri = - match fst(CicEnvironment.get_obj CicUniv.oblivion_ugraph uri) with - | Cic.Constant (_,Some bo, _, _,_) -> - (let t, _ = skip_lambda 0 bo in - match t with | Cic.Fix _ -> true | _ -> false) - | _ -> false - in - let guess_recno uri = - prerr_endline ("GUESS: " ^ UriManager.string_of_uri uri); - match fst(CicEnvironment.get_obj CicUniv.oblivion_ugraph uri) with - | Cic.Constant (_,Some bo, _, _,_ ) -> - let t, n = skip_lambda 0 bo in - (match t with - | Cic.Fix (i,fl) -> - let _,recno,_,_ = List.nth fl i in - prerr_endline ("GUESSED: " ^ string_of_int recno ^ " after " ^ - string_of_int n ^ " lambdas"); - recno + n - | _ -> assert false) - | _ -> assert false - in - let original_args = l in - (**** 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) - | Cic.Appl (Cic.Const (uri,_) :: args) as t when is_fix uri -> - let recno = - prerr_endline ("cerco : " ^ string_of_int (guess_recno uri) - ^ " in: " ^ String.concat " " - (List.map (fun x -> CicPp.ppterm x) args)); - prerr_endline ("e piglio il rispettivo in :"^String.concat " " - (List.map (fun x -> CicPp.ppterm x) original_args)); - (* look for args[regno] in saved_args *) - let wanted = List.nth (args@l) (guess_recno uri) in - let rec aux n = function - | [] -> n (* DA CAPIRE *) - | t::_ when t = wanted -> n - | _::tl -> aux (n+1) tl - in - aux 0 original_args - in - if recno = List.length original_args then - reduce_with_no_hope_to_fold_back t l - else - let simplified = reduceaux context l t in - let rec mk_implicits = function - | n,_::tl when n = recno -> - Cic.Implicit None :: (mk_implicits (n+1,tl)) - | n,arg::tl -> arg :: (mk_implicits (n+1,tl)) - | _,[] -> [] - in - (* we try to fold back constant that do not expand to Fix *) - let _ = prerr_endline - ("INIZIO (" ^ string_of_int recno ^ ") : " ^ CicPp.ppterm - simplified) in - let term_to_fold = - Cic.Appl (term:: mk_implicits (0,original_args)) - in - (try - let term_to_fold, _, metasenv, _ = - CicRefine.type_of_aux' [] context term_to_fold - CicUniv.oblivion_ugraph - in - let _ = - prerr_endline ("RAFFINA: "^CicPp.ppterm term_to_fold) in - let _ = - prerr_endline - ("RAFFINA: "^CicMetaSubst.ppmetasenv [] metasenv) in - let simplified_term_to_fold = unfold context term_to_fold in - let _ = - prerr_endline ("SEMPLIFICA: " ^ - CicPp.ppterm simplified_term_to_fold) - in - let rec do_n f t = - let t1 = f t in - if t1 = t then t else do_n f t1 - in - do_n - (fun simplified -> - let subst = ref [] in - let myunif ctx t1 t2 = - if !subst <> [] then false - else - try - prerr_endline "MUNIF"; - prerr_endline (CicPp.ppterm t1); - prerr_endline "VS"; - prerr_endline (CicPp.ppterm t2 ^ "\n"); - let subst1, _, _ = - CicUnification.fo_unif metasenv ctx t1 t2 - CicUniv.oblivion_ugraph - in - prerr_endline "UNIFICANO\n\n\n"; - subst := subst1; - true - with - | CicUnification.UnificationFailure s - | CicUnification.Uncertain s - | CicUnification.AssertFailure s -> - prerr_endline (Lazy.force s); false - | CicUtil.Meta_not_found _ -> false - (* - | _ as exn -> - prerr_endline (Printexc.to_string exn); - false*) - in - let t = - replace_lifting myunif context - [simplified_term_to_fold] [term_to_fold] simplified - in - let _ = prerr_endline "UNIFICA" in - if List.length metasenv <> List.length !subst then - let _ = prerr_endline ("SUBST CORTA " ^ - CicMetaSubst.ppsubst !subst ~metasenv) - in - simplified - else - if t = simplified then - let _ = prerr_endline "NULLA DI FATTO" in - simplified - else - let t = CicMetaSubst.apply_subst !subst t in - prerr_endline ("ECCO: " ^ CicPp.ppterm t); t) - simplified - with - | CicRefine.RefineFailure s - | CicRefine.Uncertain s - | CicRefine.AssertFailure s -> - prerr_endline (Lazy.force s); simplified - (*| exn -> prerr_endline (Printexc.to_string exn); simplified*)) - | t -> reduce_with_no_hope_to_fold_back t l - 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 [] -;; diff --git a/matita/components/tactics/proofEngineReduction.mli b/matita/components/tactics/proofEngineReduction.mli deleted file mode 100644 index 5bc5f2458..000000000 --- a/matita/components/tactics/proofEngineReduction.mli +++ /dev/null @@ -1,73 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -exception Impossible of int -exception ReferenceToConstant -exception ReferenceToVariable -exception ReferenceToCurrentProof -exception ReferenceToInductiveDefinition -exception WrongUriToInductiveDefinition -exception RelToHiddenHypothesis -exception WrongShape -exception AlreadySimplified -exception WhatAndWithWhatDoNotHaveTheSameLength;; - -(* Replaces "textually" in "where" every term in "what" with the corresponding - term in "with_what". The terms in "what" ARE NOT lifted when binders are - crossed. The terms in "with_what" ARE NOT lifted when binders are crossed. - Every free variable in "where" IS NOT lifted by nnn. *) -val replace : - equality:('a -> Cic.term -> bool) -> - what:'a list -> with_what:Cic.term list -> where:Cic.term -> Cic.term - -(* Replaces in "where" every term in "what" with the corresponding - term in "with_what". The terms in "what" ARE lifted when binders are - crossed. The terms in "with_what" ARE lifted when binders are crossed. - Every free variable in "where" IS NOT lifted by nnn. - Thus "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]" is the - inverse of subst up to the fact that free variables in "where" are NOT - lifted. *) -val replace_lifting : - equality:(Cic.context -> Cic.term -> Cic.term -> bool) -> - context:Cic.context -> - what:Cic.term list -> with_what:Cic.term list -> where:Cic.term -> Cic.term - -(* Replaces in "where" every term in "what" with the corresponding - term in "with_what". The terms in "what" ARE NOT lifted when binders are - crossed. The terms in "with_what" ARE lifted when binders are crossed. - Every free variable in "where" IS lifted by nnn. - Thus "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]" is the - inverse of subst up to the fact that "what" terms are NOT lifted. *) -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 - -(* This is like "replace_lifting_csc 1 ~with_what:[Rel 1; ... ; Rel 1]" - up to the fact that the index to start from can be specified *) -val replace_with_rel_1_from : - equality:(Cic.term -> Cic.term -> bool) -> - what:Cic.term list -> int -> Cic.term -> Cic.term -val simpl : Cic.context -> Cic.term -> Cic.term -val unfold : ?what:Cic.term -> Cic.context -> Cic.term -> Cic.term diff --git a/matita/components/tactics/proofEngineStructuralRules.ml b/matita/components/tactics/proofEngineStructuralRules.ml deleted file mode 100644 index 479219537..000000000 --- a/matita/components/tactics/proofEngineStructuralRules.ml +++ /dev/null @@ -1,200 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -module PET = ProofEngineTypes -module C = Cic - -let clearbody ~hyp = - let clearbody (proof, goal) = - let curi,metasenv,_subst,pbo,pty, attrs = 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 = Some (C.Name hyp, Cic.Decl ty) in - cleared_entry::context - | None -> None::context - | Some (n,C.Decl t) -> - let _,_ = - try - CicTypeChecker.type_of_aux' metasenv context t - CicUniv.oblivion_ugraph (* TASSI: FIXME *) - with - _ -> - raise - (PET.Fail - (lazy ("The correctness of hypothesis " ^ - string_of_name n ^ - " relies on the body of " ^ hyp) - )) - in - entry::context - | Some (n,Cic.Def (te,ty)) -> - (try - ignore - (CicTypeChecker.type_of_aux' metasenv context te - CicUniv.oblivion_ugraph (* TASSI: FIXME *)); - ignore - (CicTypeChecker.type_of_aux' metasenv context ty - CicUniv.oblivion_ugraph (* TASSI: FIXME *)); - with - _ -> - raise - (PET.Fail - (lazy ("The correctness of hypothesis " ^ - string_of_name n ^ - " relies on the body of " ^ hyp) - ))); - entry::context - ) canonical_context [] - in - let _,_ = - try - CicTypeChecker.type_of_aux' metasenv canonical_context' ty - CicUniv.oblivion_ugraph (* TASSI: FIXME *) - with - _ -> - raise - (PET.Fail - (lazy ("The correctness of the goal relies on the body of " ^ - hyp))) - in - m,canonical_context',ty - | t -> t - ) metasenv - in - (curi,metasenv',_subst,pbo,pty, attrs), [goal] - in - PET.mk_tactic clearbody - -let clear_one ~hyp = - let clear_one (proof, goal) = - let curi,metasenv,_subst,pbo,pty, attrs = 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,_)) -> - if b then - let _,_ = - try - CicTypeChecker.type_of_aux' metasenv context t - CicUniv.oblivion_ugraph - with _ -> - raise - (PET.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 (PET.Fail (lazy ("Hypothesis " ^ hyp ^ " does not exist"))); - let _,_ = - try - CicTypeChecker.type_of_aux' metasenv canonical_context' ty - CicUniv.oblivion_ugraph - with _ -> - raise (PET.Fail (lazy ("Hypothesis " ^ hyp ^ " occurs in the goal"))) - in - m,canonical_context',ty - | t -> t - ) metasenv - in - (curi,metasenv',_subst,pbo,pty, attrs), [goal] - in - PET.mk_tactic clear_one - -let clear ~hyps = - let clear status = - let aux status hyp = - match PET.apply_tactic (clear_one ~hyp) status with - | proof, [g] -> proof, g - | _ -> raise (PET.Fail (lazy "clear: internal error")) - in - let proof, g = List.fold_left aux status hyps in - proof, [g] - in - PET.mk_tactic clear - -(* Warning: this tactic has no effect on the proof term. - It just changes the name of an hypothesis in the current sequent *) -let rename ~froms ~tos = - let rename (proof, goal) = - let error = "rename: lists of different length" in - let assocs = - try List.combine froms tos - with Invalid_argument _ -> raise (PET.Fail (lazy error)) - in - let curi, metasenv, _subst, pbo, pty, attrs = proof in - let metano, _, _ = CicUtil.lookup_meta goal metasenv in - let rename_map = function - | Some (Cic.Name hyp, decl_or_def) as entry -> - begin try Some (Cic.Name (List.assoc hyp assocs), decl_or_def) - with Not_found -> entry end - | entry -> entry - in - let map = function - | m, canonical_context, ty when m = metano -> - let canonical_context = List.map rename_map canonical_context in - m, canonical_context, ty - | conjecture -> conjecture - in - let metasenv = List.map map metasenv in - (curi, metasenv, _subst, pbo, pty, attrs), [goal] - in - PET.mk_tactic rename diff --git a/matita/components/tactics/proofEngineStructuralRules.mli b/matita/components/tactics/proofEngineStructuralRules.mli deleted file mode 100644 index d8e9ed376..000000000 --- a/matita/components/tactics/proofEngineStructuralRules.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val clearbody: hyp:string -> ProofEngineTypes.tactic -val clear: hyps:string list -> 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: froms:string list -> tos:string list -> ProofEngineTypes.tactic diff --git a/matita/components/tactics/proofEngineTypes.ml b/matita/components/tactics/proofEngineTypes.ml deleted file mode 100644 index c60b6fdc0..000000000 --- a/matita/components/tactics/proofEngineTypes.ml +++ /dev/null @@ -1,113 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - - (** - current proof (proof uri * metas * (in)complete proof * term to be prooved) - *) -type proof = - UriManager.uri option * Cic.metasenv * Cic.substitution * Cic.term Lazy.t * Cic.term * Cic.attribute list - (** current goal, integer index *) -type goal = int -type status = proof * goal - -let initial_status ty metasenv attrs = - 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 _subst = [] in - let proof = - None, (newmeta_idx, [], ty) :: metasenv, _subst, - lazy (Cic.Meta (newmeta_idx, [])), ty, attrs - 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 hole = Cic.Implicit (Some `Hole) - -let conclusion_pattern t = - let t' = - match t with - | None -> None - | Some t -> Some (const_lazy_term t) - in - t',[], Some hole - - (** tactic failure *) -exception Fail of string Lazy.t - - (** - calls the opaque tactic on the status - *) -let apply_tactic t status = - let (uri,metasenv,subst,bo,ty, attrs), gl = t status in - match - CicRefine.pack_coercion_obj - (Cic.CurrentProof ("",metasenv,Cic.Rel ~-1,ty,[],attrs)) - with - | Cic.CurrentProof (_,metasenv,_,ty,_, attrs) -> - (uri,metasenv,subst,bo,ty, attrs), gl - | _ -> assert false -;; - - (** 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,_subst,_,_,_) = List.map (fun (g,_,_) -> g) metasenv - diff --git a/matita/components/tactics/proofEngineTypes.mli b/matita/components/tactics/proofEngineTypes.mli deleted file mode 100644 index 7e6f571e4..000000000 --- a/matita/components/tactics/proofEngineTypes.mli +++ /dev/null @@ -1,78 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - - (** - current proof (proof uri * metas * (in)complete proof * term to be prooved) - *) -type proof = - UriManager.uri option * Cic.metasenv * Cic.substitution * Cic.term Lazy.t * Cic.term * Cic.attribute list - (** 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 -> Cic.attribute list -> 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 - -val hole: Cic.term diff --git a/matita/components/tactics/reductionTactics.ml b/matita/components/tactics/reductionTactics.ml deleted file mode 100644 index 2684222d4..000000000 --- a/matita/components/tactics/reductionTactics.ml +++ /dev/null @@ -1,233 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -open ProofEngineTypes - -(* Note: this code is almost identical to change_tac and -* it could be unified by making the change function a callback *) -let reduction_tac ~reduction ~pattern (proof,goal) = - let curi,metasenv,subst,pbo,pty, attrs = 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 ~subst ~metasenv ~ugraph:CicUniv.oblivion_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 = - change subst ty selected_ty metasenv ugraph - 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',subst,pbo,pty, attrs), [metano] -;; - -let simpl_tac ~pattern = - mk_tactic (reduction_tac - ~reduction:(const_lazy_reduction ProofEngineReduction.simpl) ~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 - let unfold ctx t = - try - ProofEngineReduction.unfold ~what ctx t - with - (* Not what we would like to have; however, this is required - right now for the case of a definition in the context: - if it works only in the body (or only in the type), that should - be accepted *) - ProofEngineTypes.Fail _ -> t - in - unfold, 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) - -let head_beta_reduce_tac ?delta ?upto ~pattern = - mk_tactic (reduction_tac - ~reduction: - (const_lazy_reduction - (fun _context -> CicReduction.head_beta_reduce ?delta ?upto)) ~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 ?(with_cast=false) ~pattern with_what = - let change_tac ~pattern ~with_what (proof, goal) = - let curi,metasenv,subst,pbo,pty, attrs = 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 ~subst context_of_t with_what ugraph - in - let b,_ = - CicReduction.are_convertible - ~metasenv ~subst 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 ~subst ~ugraph:CicUniv.oblivion_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 = - change subst ty selected_ty metasenv ugraph - 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 - let proof,goal = (curi,metasenv',subst,pbo,pty, attrs), metano in - if with_cast then - let metano' = ProofEngineHelpers.new_meta_of_proof ~proof in - let (newproof,_) = - let irl= CicMkImplicit.identity_relocation_list_for_metavariable context' - in - ProofEngineHelpers.subst_meta_in_proof - proof metano - (Cic.Cast (Cic.Meta(metano',irl),ty')) [metano',context',ty'] - in - newproof, [metano'] - else - proof,[goal] - in - mk_tactic (change_tac ~pattern ~with_what) -;; - -let fold_tac ~reduction ~term ~pattern = - let fold_tac ~reduction ~term ~pattern:(wanted,hyps_pat,concl_pat) status = - assert (wanted = None); (* this should be checked syntactically *) - let reduced_term = - (fun context metasenv ugraph -> - let term, metasenv, ugraph = term context metasenv ugraph in - let reduction, metasenv, ugraph = reduction context metasenv ugraph in - reduction context term, metasenv, ugraph) - in - apply_tactic - (change_tac ~pattern:(Some reduced_term,hyps_pat,concl_pat) term) status - in - mk_tactic (fold_tac ~reduction ~term ~pattern) -;; - diff --git a/matita/components/tactics/reductionTactics.mli b/matita/components/tactics/reductionTactics.mli deleted file mode 100644 index 004a3b3ee..000000000 --- a/matita/components/tactics/reductionTactics.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val simpl_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val whd_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val normalize_tac: pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val head_beta_reduce_tac: ?delta:bool -> ?upto:int -> 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: - ?with_cast:bool -> - pattern:ProofEngineTypes.lazy_pattern -> - Cic.lazy_term -> - ProofEngineTypes.tactic - -val fold_tac: - reduction:ProofEngineTypes.lazy_reduction -> - term:Cic.lazy_term -> - pattern:ProofEngineTypes.lazy_pattern -> - ProofEngineTypes.tactic - diff --git a/matita/components/tactics/ring.ml b/matita/components/tactics/ring.ml deleted file mode 100644 index 82ef5f4f2..000000000 --- a/matita/components/tactics/ring.ml +++ /dev/null @@ -1,595 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -open CicReduction -open PrimitiveTactics -open ProofEngineTypes -open UriManager - -(** DEBUGGING *) - - (** perform debugging output? *) -let debug = false -let debug_print = fun _ -> () - - (** debugging print *) -let warn s = debug_print (lazy ("RING WARNING: " ^ (Lazy.force s))) - -(** CIC URIS *) - -(** - Note: For constructors URIs aren't really URIs but rather triples of - the form (uri, typeno, consno). This discrepancy is to preserver an - uniformity of invocation of "mkXXX" functions. -*) - -let equality_is_a_congruence_A = - uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/A.var" -let equality_is_a_congruence_x = - uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/x.var" -let equality_is_a_congruence_y = - uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/y.var" - -let apolynomial_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/apolynomial.ind" -let apvar_uri = (apolynomial_uri, 0, 1) -let ap0_uri = (apolynomial_uri, 0, 2) -let ap1_uri = (apolynomial_uri, 0, 3) -let applus_uri = (apolynomial_uri, 0, 4) -let apmult_uri = (apolynomial_uri, 0, 5) -let apopp_uri = (apolynomial_uri, 0, 6) - -let quote_varmap_A_uri = uri_of_string "cic:/Coq/ring/Quote/variables_map/A.var" -let varmap_uri = uri_of_string "cic:/Coq/ring/Quote/varmap.ind" -let empty_vm_uri = (varmap_uri, 0, 1) -let node_vm_uri = (varmap_uri, 0, 2) -let varmap_find_uri = uri_of_string "cic:/Coq/ring/Quote/varmap_find.con" -let index_uri = uri_of_string "cic:/Coq/ring/Quote/index.ind" -let left_idx_uri = (index_uri, 0, 1) -let right_idx_uri = (index_uri, 0, 2) -let end_idx_uri = (index_uri, 0, 3) - -let abstract_rings_A_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/A.var" -let abstract_rings_Aplus_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Aplus.var" -let abstract_rings_Amult_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Amult.var" -let abstract_rings_Aone_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Aone.var" -let abstract_rings_Azero_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Azero.var" -let abstract_rings_Aopp_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Aopp.var" -let abstract_rings_Aeq_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Aeq.var" -let abstract_rings_vm_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/vm.var" -let abstract_rings_T_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/T.var" -let interp_ap_uri = uri_of_string "cic:/Coq/ring/Ring_abstract/interp_ap.con" -let interp_sacs_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/interp_sacs.con" -let apolynomial_normalize_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/apolynomial_normalize.con" -let apolynomial_normalize_ok_uri = - uri_of_string "cic:/Coq/ring/Ring_abstract/apolynomial_normalize_ok.con" - -(** CIC PREDICATES *) - - (** - check whether a term is a constant or not, if argument "uri" is given and is - not "None" also check if the constant correspond to the given one or not - *) -let cic_is_const ?(uri: uri option = None) term = - match uri with - | None -> - (match term with - | Cic.Const _ -> true - | _ -> false) - | Some realuri -> - (match term with - | Cic.Const (u, _) when (eq u realuri) -> true - | _ -> false) - -(** PROOF AND GOAL ACCESSORS *) - - (** - @param proof a proof - @return the uri of a given proof - *) -let uri_of_proof ~proof:(uri, _, _, _, _, _) = uri - - (** - @param status current proof engine status - @raise Failure if proof is None - @return current goal's metasenv - *) -let metasenv_of_status ((_,m,_,_,_, _), _) = m - - (** - @param status a proof engine status - @raise Failure when proof or goal are None - @return context corresponding to current goal - *) -let context_of_status status = - let (proof, goal) = status in - let metasenv = metasenv_of_status status in - let _, context, _ = CicUtil.lookup_meta goal metasenv in - context - -(** CIC TERM CONSTRUCTORS *) - - (** - Create a Cic term consisting of a constant - @param uri URI of the constant - @proof current proof - @exp_named_subst explicit named substitution - *) -let mkConst ~uri ~exp_named_subst = - Cic.Const (uri, exp_named_subst) - - (** - Create a Cic term consisting of a constructor - @param uri triple where uri is the uri of an inductive - type, typeno is the type number in a mutind structure (0 based), consno is - the constructor number (1 based) - @exp_named_subst explicit named substitution - *) -let mkCtor ~uri:(uri, typeno, consno) ~exp_named_subst = - Cic.MutConstruct (uri, typeno, consno, exp_named_subst) - - (** - Create a Cic term consisting of a type member of a mutual induction - @param uri pair where uri is the uri of a mutual inductive - type and typeno is the type number (0 based) in the mutual induction - @exp_named_subst explicit named substitution - *) -let mkMutInd ~uri:(uri, typeno) ~exp_named_subst = - Cic.MutInd (uri, typeno, exp_named_subst) - -(** EXCEPTIONS *) - - (** - raised when the current goal is not ringable; a goal is ringable when is an - equality on reals (@see r_uri) - *) -exception GoalUnringable - -(** RING's FUNCTIONS LIBRARY *) - - (** - Check whether the ring tactic can be applied on a given term (i.e. that is - an equality on reals) - @param term to be tested - @return true if the term is ringable, false otherwise - *) -let ringable = - let is_equality = function - | Cic.MutInd (uri, 0, []) when (eq uri HelmLibraryObjects.Logic.eq_URI) -> true - | _ -> false - in - let is_real = function - | Cic.Const (uri, _) when (eq uri HelmLibraryObjects.Reals.r_URI) -> true - | _ -> false - in - function - | Cic.Appl (app::set::_::_::[]) when (is_equality app && is_real set) -> - warn (lazy "Goal Ringable!"); - true - | _ -> - warn (lazy "Goal Not Ringable :-(("); - false - - (** - split an equality goal of the form "t1 = t2" in its two subterms t1 and t2 - after checking that the goal is ringable - @param goal the current goal - @return a pair (t1,t2) that are two sides of the equality goal - @raise GoalUnringable if the goal isn't ringable - *) -let split_eq = function - | (Cic.Appl (_::_::t1::t2::[])) as term when ringable term -> - warn (lazy ("" ^ (CicPp.ppterm t1) ^ "")); - warn (lazy ("" ^ (CicPp.ppterm t2) ^ "")); - (t1, t2) - | _ -> raise GoalUnringable - - (** - @param i an integer index representing a 1 based number of node in a binary - search tree counted in a fbs manner (i.e.: 1 is the root, 2 is the left - child of the root (if any), 3 is the right child of the root (if any), 4 is - the left child of the left child of the root (if any), ....) - @param proof the current proof - @return an index representing the same node in a varmap (@see varmap_uri), - the returned index is as defined in index (@see index_uri) - *) -let path_of_int n = - let rec digits_of_int n = - if n=1 then [] else (n mod 2 = 1)::(digits_of_int (n lsr 1)) - in - List.fold_right - (fun digit path -> - Cic.Appl [ - mkCtor (if (digit = true) then right_idx_uri else left_idx_uri) []; - path]) - (List.rev (digits_of_int n)) (* remove leading true (i.e. digit 1) *) - (mkCtor end_idx_uri []) - - (** - Build a variable map (@see varmap_uri) from a variables array. - A variable map is almost a binary tree so this function receiving a var list - like [v;w;x;y;z] will build a varmap of shape: v - / \ - w x - / \ - y z - @param vars variables array - @return a cic term representing the variable map containing vars variables - *) -let btree_of_array ~vars = - let r = HelmLibraryObjects.Reals.r in - let empty_vm_r = mkCtor empty_vm_uri [quote_varmap_A_uri,r] in - let node_vm_r = mkCtor node_vm_uri [quote_varmap_A_uri,r] in - let size = Array.length vars in - let halfsize = size lsr 1 in - let rec aux n = (* build the btree starting from position n *) - (* - n is the position in the vars array _1_based_ in order to access - left and right child using (n*2, n*2+1) trick - *) - if n > size then - empty_vm_r - else if n > halfsize then (* no more children *) - Cic.Appl [node_vm_r; vars.(n-1); empty_vm_r; empty_vm_r] - else (* still children *) - Cic.Appl [node_vm_r; vars.(n-1); aux (n*2); aux (n*2+1)] - in - aux 1 - - (** - abstraction function: - concrete polynoms -----> (abstract polynoms, varmap) - @param terms list of conrete polynoms - @return a pair where aterms is a list of abstract polynoms - and varmap is the variable map needed to interpret them - *) -let abstract_poly ~terms = - let varhash = Hashtbl.create 19 in (* vars hash, to speed up lookup *) - let varlist = ref [] in (* vars list in reverse order *) - let counter = ref 1 in (* index of next new variable *) - let rec aux = function (* TODO not tail recursive *) - (* "bop" -> binary operator | "uop" -> unary operator *) - | Cic.Appl (bop::t1::t2::[]) - when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.rplus_URI) bop) -> (* +. *) - Cic.Appl [mkCtor applus_uri []; aux t1; aux t2] - | Cic.Appl (bop::t1::t2::[]) - when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.rmult_URI) bop) -> (* *. *) - Cic.Appl [mkCtor apmult_uri []; aux t1; aux t2] - | Cic.Appl (uop::t::[]) - when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.ropp_URI) uop) -> (* ~-. *) - Cic.Appl [mkCtor apopp_uri []; aux t] - | t when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.r0_URI) t) -> (* 0. *) - mkCtor ap0_uri [] - | t when (cic_is_const ~uri:(Some HelmLibraryObjects.Reals.r1_URI) t) -> (* 1. *) - mkCtor ap1_uri [] - | t -> (* variable *) - try - Hashtbl.find varhash t (* use an old var *) - with Not_found -> begin (* create a new var *) - let newvar = - Cic.Appl [mkCtor apvar_uri []; path_of_int !counter] - in - incr counter; - varlist := t :: !varlist; - Hashtbl.add varhash t newvar; - newvar - end - in - let aterms = List.map aux terms in (* abstract vars *) - let varmap = (* build varmap *) - btree_of_array ~vars:(Array.of_list (List.rev !varlist)) - in - (aterms, varmap) - - (** - given a list of abstract terms (i.e. apolynomials) build the ring "segments" - that is triples like (t', t'', t''') where - t' = interp_ap(varmap, at) - t'' = interp_sacs(varmap, (apolynomial_normalize at)) - t''' = apolynomial_normalize_ok(varmap, at) - at is the abstract term built from t, t is a single member of aterms - *) -let build_segments ~terms = - let theory_args_subst varmap = - [abstract_rings_A_uri, HelmLibraryObjects.Reals.r ; - abstract_rings_Aplus_uri, HelmLibraryObjects.Reals.rplus ; - abstract_rings_Amult_uri, HelmLibraryObjects.Reals.rmult ; - abstract_rings_Aone_uri, HelmLibraryObjects.Reals.r1 ; - abstract_rings_Azero_uri, HelmLibraryObjects.Reals.r0 ; - abstract_rings_Aopp_uri, HelmLibraryObjects.Reals.ropp ; - abstract_rings_vm_uri, varmap] in - let theory_args_subst' eq varmap t = - [abstract_rings_A_uri, HelmLibraryObjects.Reals.r ; - abstract_rings_Aplus_uri, HelmLibraryObjects.Reals.rplus ; - abstract_rings_Amult_uri, HelmLibraryObjects.Reals.rmult ; - abstract_rings_Aone_uri, HelmLibraryObjects.Reals.r1 ; - abstract_rings_Azero_uri, HelmLibraryObjects.Reals.r0 ; - abstract_rings_Aopp_uri, HelmLibraryObjects.Reals.ropp ; - abstract_rings_Aeq_uri, eq ; - abstract_rings_vm_uri, varmap ; - abstract_rings_T_uri, t] in - let interp_ap varmap = - mkConst interp_ap_uri (theory_args_subst varmap) in - let interp_sacs varmap = - mkConst interp_sacs_uri (theory_args_subst varmap) in - let apolynomial_normalize = mkConst apolynomial_normalize_uri [] in - let apolynomial_normalize_ok eq varmap t = - mkConst apolynomial_normalize_ok_uri (theory_args_subst' eq varmap t) in - let lxy_false = (** Cic funcion "fun (x,y):R -> false" *) - Cic.Lambda (Cic.Anonymous, HelmLibraryObjects.Reals.r, - Cic.Lambda (Cic.Anonymous, HelmLibraryObjects.Reals.r, HelmLibraryObjects.Datatypes.falseb)) - in - let (aterms, varmap) = abstract_poly ~terms in (* abstract polys *) - List.map (* build ring segments *) - (fun t -> - Cic.Appl [interp_ap varmap ; t], - Cic.Appl ( - [interp_sacs varmap ; Cic.Appl [apolynomial_normalize; t]]), - Cic.Appl [apolynomial_normalize_ok lxy_false varmap HelmLibraryObjects.Reals.rtheory ; t] - ) aterms - - -let status_of_single_goal_tactic_result = - function - proof,[goal] -> proof,goal - | _ -> - raise (Fail (lazy "status_of_single_goal_tactic_result: the tactic did not produce exactly a new goal")) - -(* Galla: spostata in variousTactics.ml - (** - auxiliary tactic "elim_type" - @param status current proof engine status - @param term term to cut - *) -let elim_type_tac ~term status = - warn (lazy "in Ring.elim_type_tac"); - Tacticals.thens ~start:(cut_tac ~term) - ~continuations:[elim_simpl_intros_tac ~term:(Cic.Rel 1) ; Tacticals.id_tac] status -*) - - (** - auxiliary tactic, use elim_type and try to close 2nd subgoal using proof - @param status current proof engine status - @param term term to cut - @param proof term used to prove second subgoal generated by elim_type - *) -(* FG: METTERE I NOMI ANCHE QUI? *) -let elim_type2_tac ~term ~proof = - let elim_type2_tac ~term ~proof status = - let module E = EliminationTactics in - warn (lazy "in Ring.elim_type2"); - ProofEngineTypes.apply_tactic - (Tacticals.thens ~start:(E.elim_type_tac term) - ~continuations:[Tacticals.id_tac ; exact_tac ~term:proof]) status - in - ProofEngineTypes.mk_tactic (elim_type2_tac ~term ~proof) - -(* Galla: spostata in variousTactics.ml - (** - Reflexivity tactic, try to solve current goal using "refl_eqT" - Warning: this isn't equale to the coq's Reflexivity because this one tries - only refl_eqT, coq's one also try "refl_equal" - @param status current proof engine status - *) -let reflexivity_tac (proof, goal) = - warn (lazy "in Ring.reflexivity_tac"); - let refl_eqt = mkCtor ~uri:refl_eqt_uri ~exp_named_subst:[] in - try - apply_tac (proof, goal) ~term:refl_eqt - with (Fail _) as e -> - let e_str = Printexc.to_string e in - raise (Fail ("Reflexivity failed with exception: " ^ e_str)) -*) - - (** lift an 8-uple of debrujins indexes of n *) -let lift ~n (a,b,c,d,e,f,g,h) = - match (List.map (CicSubstitution.lift n) [a;b;c;d;e;f;g;h]) with - | [a;b;c;d;e;f;g;h] -> (a,b,c,d,e,f,g,h) - | _ -> assert false - - (** - remove hypothesis from a given status starting from the last one - @param count number of hypotheses to remove - @param status current proof engine status - *) -let purge_hyps_tac ~count = - let purge_hyps_tac ~count status = - let module S = ProofEngineStructuralRules in - let (proof, goal) = status in - let rec aux n context status = - assert(n>=0); - match (n, context) with - | (0, _) -> status - | (n, hd::tl) -> - let name_of_hyp = - match hd with - None - | Some (Cic.Anonymous,_) -> assert false - | Some (Cic.Name name,_) -> name - in - aux (n-1) tl - (status_of_single_goal_tactic_result - (ProofEngineTypes.apply_tactic (S.clear ~hyps:[name_of_hyp]) status)) - | (_, []) -> failwith "Ring.purge_hyps_tac: no hypotheses left" - in - let (_, metasenv, _subst, _, _, _) = 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:[ - EqualityTactics.reflexivity_tac ; - exact_tac ~term:t1'_eq_t1'' ; - exact_tac ~term:t2'_eq_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, t1'' ; - equality_is_a_congruence_y, t1 - ] ; - t1'_eq_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.oblivion_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_tac ~term:t2'_eq_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'' - ]) ; - ProofEngineTypes.mk_tactic (fun status -> - let status' = - let context = context_of_status status in - let b,_ = (* TASSI:FIXME *) - are_convertible context t2'' t2 - CicUniv.oblivion_ugraph - in - if not b then begin - warn (lazy "t2'' and t2 are NOT CONVERTIBLE"); - let newstatus = - ProofEngineTypes.apply_tactic - (elim_type2_tac (* 2nd elim_type use *) - ~proof:t2'_eq_t2'' - ~term:(Cic.Appl [eqt; r; t2''; t2])) - status - in - incr new_hyps; (* elim_type add an hyp *) - match newstatus with - (proof,[goal]) -> proof,goal - | _ -> assert false - end else begin - warn (lazy "t2'' and t2 are CONVERTIBLE"); - status - end - in - try (* try to solve main goal *) - warn (lazy "trying reflexivity ...."); - ProofEngineTypes.apply_tactic - EqualityTactics.reflexivity_tac status' - with (Fail _) -> (* leave conclusion to the user *) - warn (lazy "reflexivity failed, solution's left as an ex :-)"); - ProofEngineTypes.apply_tactic - (purge_hyps_tac ~count:!new_hyps) status')]) - status' - in - status'')]) - status - with (Fail s) -> - raise (Fail (lazy ("Ring failure: " ^ Lazy.force s))) - end - | _ -> (* impossible: we are applying ring exacty to 2 terms *) - assert false - - (* wrap ring_tac catching GoalUnringable and raising Fail *) - -let ring_tac status = - try - ring_tac status - with GoalUnringable -> - raise (Fail (lazy "goal unringable")) - -let ring_tac = ProofEngineTypes.mk_tactic ring_tac - diff --git a/matita/components/tactics/ring.mli b/matita/components/tactics/ring.mli deleted file mode 100644 index b6eb34b69..000000000 --- a/matita/components/tactics/ring.mli +++ /dev/null @@ -1,12 +0,0 @@ - - (* ring tactics *) -val ring_tac: ProofEngineTypes.tactic - -(*Galla: spostata in variuosTactics.ml - (* auxiliary tactics *) -val elim_type_tac: term: Cic.term -> ProofEngineTypes.tactic -*) - -(* spostata in variousTactics.ml -val reflexivity_tac: ProofEngineTypes.tactic -*) diff --git a/matita/components/tactics/setoids.ml b/matita/components/tactics/setoids.ml deleted file mode 100644 index 1ef4e483e..000000000 --- a/matita/components/tactics/setoids.ml +++ /dev/null @@ -1,1916 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* uri - | None -> - raise (ProofEngineTypes.Fail (lazy "You need to register the default equality first. Please use the \"default\" command")) - -let replace = ref (fun _ _ -> assert false) -let register_replace f = replace := f - -let general_rewrite = ref (fun _ _ -> assert false) -let register_general_rewrite f = general_rewrite := f - -let prlist_with_sepi sep elem = - let rec aux n = - function - | [] -> "" - | [h] -> elem n h - | h::t -> - let e = elem n h and r = aux (n+1) t in - e ^ sep ^ r - in - aux 1 - -type relation = - { rel_a: Cic.term ; - rel_aeq: Cic.term; - rel_refl: Cic.term option; - rel_sym: Cic.term option; - rel_trans : Cic.term option; - rel_quantifiers_no: int (* it helps unification *); - rel_X_relation_class: Cic.term; - rel_Xreflexive_relation_class: Cic.term - } - -type 'a relation_class = - Relation of 'a (* the rel_aeq of the relation or the relation *) - | Leibniz of Cic.term option (* the carrier (if eq is partially instantiated)*) - -type 'a morphism = - { args : (bool option * 'a relation_class) list; - output : 'a relation_class; - lem : Cic.term; - morphism_theory : Cic.term - } - -type funct = - { f_args : Cic.term list; - f_output : Cic.term - } - -type morphism_class = - ACMorphism of relation morphism - | ACFunction of funct - -let constr_relation_class_of_relation_relation_class = - function - Relation relation -> Relation relation.rel_aeq - | Leibniz t -> Leibniz t - - -(*COQ -let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c -*) - -(*COQ -let constant dir s = Coqlib.gen_constant "Setoid_replace" ("Setoids"::dir) s -*) let constant dir s = Cic.Implicit None -(*COQ -let gen_constant dir s = Coqlib.gen_constant "Setoid_replace" dir s -*) let gen_constant dir s = Cic.Implicit None -(*COQ -let reference dir s = Coqlib.gen_reference "Setoid_replace" ("Setoids"::dir) s -let eval_reference dir s = EvalConstRef (destConst (constant dir s)) -*) let eval_reference dir s = Cic.Implicit None -(*COQ -let eval_init_reference dir s = EvalConstRef (destConst (gen_constant ("Init"::dir) s)) -*) - -(*COQ -let current_constant id = - try - global_reference id - with Not_found -> - anomaly ("Setoid: cannot find " ^ id) -*) let current_constant id = assert false - -(* From Setoid.v *) - -let coq_reflexive = - (gen_constant ["Relations"; "Relation_Definitions"] "reflexive") -let coq_symmetric = - (gen_constant ["Relations"; "Relation_Definitions"] "symmetric") -let coq_transitive = - (gen_constant ["Relations"; "Relation_Definitions"] "transitive") -let coq_relation = - (gen_constant ["Relations"; "Relation_Definitions"] "relation") - -let coq_Relation_Class = (constant ["Setoid"] "Relation_Class") -let coq_Argument_Class = (constant ["Setoid"] "Argument_Class") -let coq_Setoid_Theory = (constant ["Setoid"] "Setoid_Theory") -let coq_Morphism_Theory = (constant ["Setoid"] "Morphism_Theory") -let coq_Build_Morphism_Theory= (constant ["Setoid"] "Build_Morphism_Theory") -let coq_Compat = (constant ["Setoid"] "Compat") - -let coq_AsymmetricReflexive = (constant ["Setoid"] "AsymmetricReflexive") -let coq_SymmetricReflexive = (constant ["Setoid"] "SymmetricReflexive") -let coq_SymmetricAreflexive = (constant ["Setoid"] "SymmetricAreflexive") -let coq_AsymmetricAreflexive = (constant ["Setoid"] "AsymmetricAreflexive") -let coq_Leibniz = (constant ["Setoid"] "Leibniz") - -let coq_RAsymmetric = (constant ["Setoid"] "RAsymmetric") -let coq_RSymmetric = (constant ["Setoid"] "RSymmetric") -let coq_RLeibniz = (constant ["Setoid"] "RLeibniz") - -let coq_ASymmetric = (constant ["Setoid"] "ASymmetric") -let coq_AAsymmetric = (constant ["Setoid"] "AAsymmetric") - -let coq_seq_refl = (constant ["Setoid"] "Seq_refl") -let coq_seq_sym = (constant ["Setoid"] "Seq_sym") -let coq_seq_trans = (constant ["Setoid"] "Seq_trans") - -let coq_variance = (constant ["Setoid"] "variance") -let coq_Covariant = (constant ["Setoid"] "Covariant") -let coq_Contravariant = (constant ["Setoid"] "Contravariant") -let coq_Left2Right = (constant ["Setoid"] "Left2Right") -let coq_Right2Left = (constant ["Setoid"] "Right2Left") -let coq_MSNone = (constant ["Setoid"] "MSNone") -let coq_MSCovariant = (constant ["Setoid"] "MSCovariant") -let coq_MSContravariant = (constant ["Setoid"] "MSContravariant") - -let coq_singl = (constant ["Setoid"] "singl") -let coq_cons = (constant ["Setoid"] "cons") - -let coq_equality_morphism_of_asymmetric_areflexive_transitive_relation = - (constant ["Setoid"] - "equality_morphism_of_asymmetric_areflexive_transitive_relation") -let coq_equality_morphism_of_symmetric_areflexive_transitive_relation = - (constant ["Setoid"] - "equality_morphism_of_symmetric_areflexive_transitive_relation") -let coq_equality_morphism_of_asymmetric_reflexive_transitive_relation = - (constant ["Setoid"] - "equality_morphism_of_asymmetric_reflexive_transitive_relation") -let coq_equality_morphism_of_symmetric_reflexive_transitive_relation = - (constant ["Setoid"] - "equality_morphism_of_symmetric_reflexive_transitive_relation") -let coq_make_compatibility_goal = - (constant ["Setoid"] "make_compatibility_goal") -let coq_make_compatibility_goal_eval_ref = - (eval_reference ["Setoid"] "make_compatibility_goal") -let coq_make_compatibility_goal_aux_eval_ref = - (eval_reference ["Setoid"] "make_compatibility_goal_aux") - -let coq_App = (constant ["Setoid"] "App") -let coq_ToReplace = (constant ["Setoid"] "ToReplace") -let coq_ToKeep = (constant ["Setoid"] "ToKeep") -let coq_ProperElementToKeep = (constant ["Setoid"] "ProperElementToKeep") -let coq_fcl_singl = (constant ["Setoid"] "fcl_singl") -let coq_fcl_cons = (constant ["Setoid"] "fcl_cons") - -let coq_setoid_rewrite = (constant ["Setoid"] "setoid_rewrite") -let coq_proj1 = (gen_constant ["Init"; "Logic"] "proj1") -let coq_proj2 = (gen_constant ["Init"; "Logic"] "proj2") -let coq_unit = (gen_constant ["Init"; "Datatypes"] "unit") -let coq_tt = (gen_constant ["Init"; "Datatypes"] "tt") -let coq_eq = (gen_constant ["Init"; "Logic"] "eq") - -let coq_morphism_theory_of_function = - (constant ["Setoid"] "morphism_theory_of_function") -let coq_morphism_theory_of_predicate = - (constant ["Setoid"] "morphism_theory_of_predicate") -let coq_relation_of_relation_class = - (eval_reference ["Setoid"] "relation_of_relation_class") -let coq_directed_relation_of_relation_class = - (eval_reference ["Setoid"] "directed_relation_of_relation_class") -let coq_interp = (eval_reference ["Setoid"] "interp") -let coq_Morphism_Context_rect2 = - (eval_reference ["Setoid"] "Morphism_Context_rect2") -let coq_iff = (gen_constant ["Init";"Logic"] "iff") -let coq_impl = (constant ["Setoid"] "impl") - - -(************************* Table of declared relations **********************) - - -(* Relations are stored in a table which is synchronised with the Reset mechanism. *) - -module Gmap = - Map.Make(struct type t = Cic.term let compare = Pervasives.compare end);; - -let relation_table = ref Gmap.empty - -let relation_table_add (s,th) = relation_table := Gmap.add s th !relation_table -let relation_table_find s = Gmap.find s !relation_table -let relation_table_mem s = Gmap.mem s !relation_table - -let prrelation s = - "(" ^ CicPp.ppterm s.rel_a ^ "," ^ CicPp.ppterm s.rel_aeq ^ ")" - -let prrelation_class = - function - Relation eq -> - (try prrelation (relation_table_find eq) - with Not_found -> - "[[ Error: " ^ CicPp.ppterm eq ^ - " is not registered as a relation ]]") - | Leibniz (Some ty) -> CicPp.ppterm ty - | Leibniz None -> "_" - -let prmorphism_argument_gen prrelation (variance,rel) = - prrelation rel ^ - match variance with - None -> " ==> " - | Some true -> " ++> " - | Some false -> " --> " - -let prargument_class = prmorphism_argument_gen prrelation_class - -let pr_morphism_signature (l,c) = - String.concat "" (List.map (prmorphism_argument_gen CicPp.ppterm) l) ^ - CicPp.ppterm c - -let prmorphism k m = - CicPp.ppterm k ^ ": " ^ - String.concat "" (List.map prargument_class m.args) ^ - prrelation_class m.output - -(* A function that gives back the only relation_class on a given carrier *) -(*CSC: this implementation is really inefficient. I should define a new - map to make it efficient. However, is this really worth of? *) -let default_relation_for_carrier ?(filter=fun _ -> true) a = - let rng = Gmap.fold (fun _ y acc -> y::acc) !relation_table [] in - match List.filter (fun ({rel_a=rel_a} as r) -> rel_a = a && filter r) rng with - [] -> Leibniz (Some a) - | relation::tl -> -(*COQ - if tl <> [] then - prerr_endline - ("Warning: There are several relations on the carrier \"" ^ - CicPp.ppterm a ^ "\". The relation " ^ prrelation relation ^ - " is chosen.") ; -*) - Relation relation - -let find_relation_class rel = - try Relation (relation_table_find rel) - with - Not_found -> - let default_eq = default_eq () in - match CicReduction.whd [] rel with - Cic.Appl [Cic.MutInd(uri,0,[]);ty] - when UriManager.eq uri default_eq -> Leibniz (Some ty) - | Cic.MutInd(uri,0,[]) when UriManager.eq uri default_eq -> Leibniz None - | _ -> raise Not_found - -(*COQ -let coq_iff_relation = lazy (find_relation_class (Lazy.force coq_iff)) -let coq_impl_relation = lazy (find_relation_class (Lazy.force coq_impl)) -*) let coq_iff_relation = Obj.magic 0 let coq_impl_relation = Obj.magic 0 - -let relation_morphism_of_constr_morphism = - let relation_relation_class_of_constr_relation_class = - function - Leibniz t -> Leibniz t - | Relation aeq -> - Relation (try relation_table_find aeq with Not_found -> assert false) - in - function mor -> - let args' = - List.map - (fun (variance,rel) -> - variance, relation_relation_class_of_constr_relation_class rel - ) mor.args in - let output' = relation_relation_class_of_constr_relation_class mor.output in - {mor with args=args' ; output=output'} - -let equiv_list () = - Gmap.fold (fun _ y acc -> y.rel_aeq::acc) !relation_table [] - -(* Declare a new type of object in the environment : "relation-theory". *) - -let relation_to_obj (s, th) = - let th' = - if relation_table_mem s then - begin - let old_relation = relation_table_find s in - let th' = - {th with rel_sym = - match th.rel_sym with - None -> old_relation.rel_sym - | Some t -> Some t} - in - prerr_endline - ("Warning: The relation " ^ prrelation th' ^ - " is redeclared. The new declaration" ^ - (match th'.rel_refl with - None -> "" - | Some t -> " (reflevity proved by " ^ CicPp.ppterm t) ^ - (match th'.rel_sym with - None -> "" - | Some t -> - (if th'.rel_refl = None then " (" else " and ") ^ - "symmetry proved by " ^ CicPp.ppterm t) ^ - (if th'.rel_refl <> None && th'.rel_sym <> None then - ")" else "") ^ - " replaces the old declaration" ^ - (match old_relation.rel_refl with - None -> "" - | Some t -> " (reflevity proved by " ^ CicPp.ppterm t) ^ - (match old_relation.rel_sym with - None -> "" - | Some t -> - (if old_relation.rel_refl = None then - " (" else " and ") ^ - "symmetry proved by " ^ CicPp.ppterm t) ^ - (if old_relation.rel_refl <> None && old_relation.rel_sym <> None - then ")" else "") ^ - "."); - th' - end - else - th - in - relation_table_add (s,th') - -(******************************* Table of declared morphisms ********************) - -(* Setoids are stored in a table which is synchronised with the Reset mechanism. *) - -let morphism_table = ref Gmap.empty - -let morphism_table_find m = Gmap.find m !morphism_table -let morphism_table_add (m,c) = - let old = - try - morphism_table_find m - with - Not_found -> [] - in - try -(*COQ - let old_morph = - List.find - (function mor -> mor.args = c.args && mor.output = c.output) old - in - prerr_endline - ("Warning: The morphism " ^ prmorphism m old_morph ^ - " is redeclared. " ^ - "The new declaration whose compatibility is proved by " ^ - CicPp.ppterm c.lem ^ " replaces the old declaration whose" ^ - " compatibility was proved by " ^ - CicPp.ppterm old_morph.lem ^ ".") -*) () - with - Not_found -> morphism_table := Gmap.add m (c::old) !morphism_table - -let default_morphism ?(filter=fun _ -> true) m = - match List.filter filter (morphism_table_find m) with - [] -> raise Not_found - | m1::ml -> -(*COQ - if ml <> [] then - prerr_endline - ("Warning: There are several morphisms associated to \"" ^ - CicPp.ppterm m ^ "\". Morphism " ^ prmorphism m m1 ^ - " is randomly chosen."); -*) - relation_morphism_of_constr_morphism m1 - -(************************** Printing relations and morphisms **********************) - -let print_setoids () = - Gmap.iter - (fun k relation -> - assert (k=relation.rel_aeq) ; - prerr_endline ("Relation " ^ prrelation relation ^ ";" ^ - (match relation.rel_refl with - None -> "" - | Some t -> " reflexivity proved by " ^ CicPp.ppterm t) ^ - (match relation.rel_sym with - None -> "" - | Some t -> " symmetry proved by " ^ CicPp.ppterm t) ^ - (match relation.rel_trans with - None -> "" - | Some t -> " transitivity proved by " ^ CicPp.ppterm t))) - !relation_table ; - Gmap.iter - (fun k l -> - List.iter - (fun ({lem=lem} as mor) -> - prerr_endline ("Morphism " ^ prmorphism k mor ^ - ". Compatibility proved by " ^ - CicPp.ppterm lem ^ ".")) - l) !morphism_table -;; - -(***************** Adding a morphism to the database ****************************) - -(* We maintain a table of the currently edited proofs of morphism lemma - in order to add them in the morphism_table when the user does Save *) - -let edited = ref Gmap.empty - -let new_edited id m = - edited := Gmap.add id m !edited - -let is_edited id = - Gmap.mem id !edited - -let no_more_edited id = - edited := Gmap.remove id !edited - -let what_edited id = - Gmap.find id !edited - -let list_chop n l = - let rec chop_aux acc = function - | (0, l2) -> (List.rev acc, l2) - | (n, (h::t)) -> chop_aux (h::acc) (pred n, t) - | (_, []) -> assert false - in - chop_aux [] (n,l) - -let compose_thing f l b = - let rec aux = - function - (0, env, b) -> b - | (n, ((v,t)::l), b) -> aux (n-1, l, f v t b) - | _ -> assert false - in - aux (List.length l,l,b) - -let compose_prod = compose_thing (fun v t b -> Cic.Prod (v,t,b)) -let compose_lambda = compose_thing (fun v t b -> Cic.Lambda (v,t,b)) - -(* also returns the triple (args_ty_quantifiers_rev,real_args_ty,real_output) - where the args_ty and the output are delifted *) -let check_is_dependent n args_ty output = - let m = List.length args_ty - n in - let args_ty_quantifiers, args_ty = list_chop n args_ty in - let rec aux m t = - match t with - Cic.Prod (n,s,t) when m > 0 -> - let t' = CicSubstitution.subst (Cic.Implicit None) (* dummy *) t in - if t' <> t then - let args,out = aux (m - 1) t' in s::args,out - else - raise (ProofEngineTypes.Fail (lazy - "The morphism is not a quantified non dependent product.")) - | _ -> [],t - in - let ty = compose_prod (List.rev args_ty) output in - let args_ty, output = aux m ty in - List.rev args_ty_quantifiers, args_ty, output - -let cic_relation_class_of_X_relation typ value = - function - {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=None} -> - Cic.Appl [coq_AsymmetricReflexive ; typ ; value ; rel_a ; rel_aeq; refl] - | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=Some sym} -> - Cic.Appl [coq_SymmetricReflexive ; typ ; rel_a ; rel_aeq; sym ; refl] - | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=None} -> - Cic.Appl [coq_AsymmetricAreflexive ; typ ; value ; rel_a ; rel_aeq] - | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=Some sym} -> - Cic.Appl [coq_SymmetricAreflexive ; typ ; rel_a ; rel_aeq; sym] - -let cic_relation_class_of_X_relation_class typ value = - function - Relation {rel_X_relation_class=x_relation_class} -> - Cic.Appl [x_relation_class ; typ ; value] - | Leibniz (Some t) -> - Cic.Appl [coq_Leibniz ; typ ; t] - | Leibniz None -> assert false - - -let cic_precise_relation_class_of_relation = - function - {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=None} -> - Cic.Appl [coq_RAsymmetric ; rel_a ; rel_aeq; refl] - | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=Some refl; rel_sym=Some sym} -> - Cic.Appl [coq_RSymmetric ; rel_a ; rel_aeq; sym ; refl] - | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=None} -> - Cic.Appl [coq_AAsymmetric ; rel_a ; rel_aeq] - | {rel_a=rel_a; rel_aeq=rel_aeq; rel_refl=None; rel_sym=Some sym} -> - Cic.Appl [coq_ASymmetric ; rel_a ; rel_aeq; sym] - -let cic_precise_relation_class_of_relation_class = - function - Relation - {rel_aeq=rel_aeq; rel_Xreflexive_relation_class=lem; rel_refl=rel_refl } - -> - rel_aeq,lem,not(rel_refl=None) - | Leibniz (Some t) -> - Cic.Appl [coq_eq ; t], Cic.Appl [coq_RLeibniz ; t], true - | Leibniz None -> assert false - -let cic_relation_class_of_relation_class rel = - cic_relation_class_of_X_relation_class - coq_unit coq_tt rel - -let cic_argument_class_of_argument_class (variance,arg) = - let coq_variant_value = - match variance with - None -> coq_Covariant (* dummy value, it won't be used *) - | Some true -> coq_Covariant - | Some false -> coq_Contravariant - in - cic_relation_class_of_X_relation_class coq_variance - coq_variant_value arg - -let cic_arguments_of_argument_class_list args = - let rec aux = - function - [] -> assert false - | [last] -> - Cic.Appl [coq_singl ; coq_Argument_Class ; last] - | he::tl -> - Cic.Appl [coq_cons ; coq_Argument_Class ; he ; aux tl] - in - aux (List.map cic_argument_class_of_argument_class args) - -let gen_compat_lemma_statement quantifiers_rev output args m = - let output = cic_relation_class_of_relation_class output in - let args = cic_arguments_of_argument_class_list args in - args, output, - compose_prod quantifiers_rev - (Cic.Appl [coq_make_compatibility_goal ; args ; output ; m]) - -let morphism_theory_id_of_morphism_proof_id id = - id ^ "_morphism_theory" - -let list_map_i f = - let rec map_i_rec i = function - | [] -> [] - | x::l -> let v = f i x in v :: map_i_rec (i+1) l - in - map_i_rec - -(* apply_to_rels c [l1 ; ... ; ln] returns (c Rel1 ... reln) *) -let apply_to_rels c l = - if l = [] then c - else - let len = List.length l in - Cic.Appl (c::(list_map_i (fun i _ -> Cic.Rel (len - i)) 0 l)) - -let apply_to_relation subst rel = - if subst = [] then rel - else - let new_quantifiers_no = rel.rel_quantifiers_no - List.length subst in - assert (new_quantifiers_no >= 0) ; - { rel_a = Cic.Appl (rel.rel_a :: subst) ; - rel_aeq = Cic.Appl (rel.rel_aeq :: subst) ; - rel_refl = HExtlib.map_option (fun c -> Cic.Appl (c::subst)) rel.rel_refl ; - rel_sym = HExtlib.map_option (fun c -> Cic.Appl (c::subst)) rel.rel_sym; - rel_trans = HExtlib.map_option (fun c -> Cic.Appl (c::subst)) rel.rel_trans; - rel_quantifiers_no = new_quantifiers_no; - rel_X_relation_class = Cic.Appl (rel.rel_X_relation_class::subst); - rel_Xreflexive_relation_class = - Cic.Appl (rel.rel_Xreflexive_relation_class::subst) } - -let add_morphism lemma_infos mor_name (m,quantifiers_rev,args,output) = - let lem = - match lemma_infos with - None -> - (* the Morphism_Theory object has already been created *) - let applied_args = - let len = List.length quantifiers_rev in - let subst = - list_map_i (fun i _ -> Cic.Rel (len - i)) 0 quantifiers_rev - in - List.map - (fun (v,rel) -> - match rel with - Leibniz (Some t) -> - assert (subst=[]); - v, Leibniz (Some t) - | Leibniz None -> - (match subst with - [e] -> v, Leibniz (Some e) - | _ -> assert false) - | Relation rel -> v, Relation (apply_to_relation subst rel)) args - in - compose_lambda quantifiers_rev - (Cic.Appl - [coq_Compat ; - cic_arguments_of_argument_class_list applied_args; - cic_relation_class_of_relation_class output; - apply_to_rels (current_constant mor_name) quantifiers_rev]) - | Some (lem_name,argsconstr,outputconstr) -> - (* only the compatibility has been proved; we need to declare the - Morphism_Theory object *) - let mext = current_constant lem_name in -(*COQ - ignore ( - Declare.declare_internal_constant mor_name - (DefinitionEntry - {const_entry_body = - compose_lambda quantifiers_rev - (Cic.Appl - [coq_Build_Morphism_Theory; - argsconstr; outputconstr; apply_to_rels m quantifiers_rev ; - apply_to_rels mext quantifiers_rev]); - const_entry_boxed = Options.boxed_definitions()}, - IsDefinition Definition)) ; -*)ignore (assert false); - mext - in - let mmor = current_constant mor_name in - let args_constr = - List.map - (fun (variance,arg) -> - variance, constr_relation_class_of_relation_relation_class arg) args in - let output_constr = constr_relation_class_of_relation_relation_class output in -(*COQ - Lib.add_anonymous_leaf - (morphism_to_obj (m, - { args = args_constr; - output = output_constr; - lem = lem; - morphism_theory = mmor })); -*)let _ = mmor,args_constr,output_constr,lem in ignore (assert false); - (*COQ Options.if_verbose prerr_endline (CicPp.ppterm m ^ " is registered as a morphism") *) () - -let list_sub _ _ _ = assert false - -(* first order matching with a bit of conversion *) -let unify_relation_carrier_with_type env rel t = - let raise_error quantifiers_no = - raise (ProofEngineTypes.Fail (lazy - ("One morphism argument or its output has type " ^ CicPp.ppterm t ^ - " but the signature requires an argument of type \"" ^ - CicPp.ppterm rel.rel_a ^ " " ^ String.concat " " (List.map (fun _ -> "?") - (Array.to_list (Array.make quantifiers_no 0))) ^ "\""))) in - let args = - match t with - Cic.Appl (he'::args') -> - let argsno = List.length args' - rel.rel_quantifiers_no in - let args1 = list_sub args' 0 argsno in - let args2 = list_sub args' argsno rel.rel_quantifiers_no in - if fst (CicReduction.are_convertible [] rel.rel_a (Cic.Appl (he'::args1)) - CicUniv.oblivion_ugraph) then - args2 - else - raise_error rel.rel_quantifiers_no - | _ -> - if rel.rel_quantifiers_no = 0 && fst (CicReduction.are_convertible [] - rel.rel_a t CicUniv.oblivion_ugraph) then - [] - else - begin -(*COQ - let evars,args,instantiated_rel_a = - let ty = CicTypeChecker.type_of_aux' [] [] rel.rel_a - CicUniv.oblivion_ugraph in - let evd = Evd.create_evar_defs Evd.empty in - let evars,args,concl = - Clenv.clenv_environments_evars env evd - (Some rel.rel_quantifiers_no) ty - in - evars, args, - nf_betaiota - (match args with [] -> rel.rel_a | _ -> applist (rel.rel_a,args)) - in - let evars' = - w_unify true (*??? or false? *) env Reduction.CONV (*??? or cumul? *) - ~mod_delta:true (*??? or true? *) t instantiated_rel_a evars in - let args' = - List.map (Reductionops.nf_evar (Evd.evars_of evars')) args - in - args' -*) assert false - end - in - apply_to_relation args rel - -let unify_relation_class_carrier_with_type env rel t = - match rel with - Leibniz (Some t') -> - if fst (CicReduction.are_convertible [] t t' CicUniv.oblivion_ugraph) then - rel - else - raise (ProofEngineTypes.Fail (lazy - ("One morphism argument or its output has type " ^ CicPp.ppterm t ^ - " but the signature requires an argument of type " ^ - CicPp.ppterm t'))) - | Leibniz None -> Leibniz (Some t) - | Relation rel -> Relation (unify_relation_carrier_with_type env rel t) - -exception Impossible - -(*COQ -(* first order matching with a bit of conversion *) -(* Note: the type checking operations performed by the function could *) -(* be done once and for all abstracting the morphism structure using *) -(* the quantifiers. Would the new structure be more suited than the *) -(* existent one for other tasks to? (e.g. pretty printing would expose *) -(* much more information: is it ok or is it too much information?) *) -let unify_morphism_with_arguments gl (c,al) - {args=args; output=output; lem=lem; morphism_theory=morphism_theory} t -= - let allen = List.length al in - let argsno = List.length args in - if allen < argsno then raise Impossible; (* partial application *) - let quantifiers,al' = Util.list_chop (allen - argsno) al in - let c' = Cic.Appl (c::quantifiers) in - if dependent t c' then raise Impossible; - (* these are pf_type_of we could avoid *) - let al'_type = List.map (Tacmach.pf_type_of gl) al' in - let args' = - List.map2 - (fun (var,rel) ty -> - var,unify_relation_class_carrier_with_type (pf_env gl) rel ty) - args al'_type in - (* this is another pf_type_of we could avoid *) - let ty = Tacmach.pf_type_of gl (Cic.Appl (c::al)) in - let output' = unify_relation_class_carrier_with_type (pf_env gl) output ty in - let lem' = Cic.Appl (lem::quantifiers) in - let morphism_theory' = Cic.Appl (morphism_theory::quantifiers) in - ({args=args'; output=output'; lem=lem'; morphism_theory=morphism_theory'}, - c',al') -*) let unify_morphism_with_arguments _ _ _ _ = assert false - -let new_morphism m signature id hook = -(*COQ - if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then - raise (ProofEngineTypes.Fail (lazy (pr_id id ^ " already exists"))) - else - let env = Global.env() in - let typeofm = Typing.type_of env Evd.empty m in - let typ = clos_norm_flags Closure.betaiotazeta empty_env Evd.empty typeofm in - let argsrev, output = - match signature with - None -> decompose_prod typ - | Some (_,output') -> - (* the carrier of the relation output' can be a Prod ==> - we must uncurry on the fly output. - E.g: A -> B -> C vs A -> (B -> C) - args output args output - *) - let rel = find_relation_class output' in - let rel_a,rel_quantifiers_no = - match rel with - Relation rel -> rel.rel_a, rel.rel_quantifiers_no - | Leibniz (Some t) -> t, 0 - | Leibniz None -> assert false in - let rel_a_n = - clos_norm_flags Closure.betaiotazeta empty_env Evd.empty rel_a in - try - let _,output_rel_a_n = decompose_lam_n rel_quantifiers_no rel_a_n in - let argsrev,_ = decompose_prod output_rel_a_n in - let n = List.length argsrev in - let argsrev',_ = decompose_prod typ in - let m = List.length argsrev' in - decompose_prod_n (m - n) typ - with UserError(_,_) -> - (* decompose_lam_n failed. This may happen when rel_a is an axiom, - a constructor, an inductive type, etc. *) - decompose_prod typ - in - let args_ty = List.rev argsrev in - let args_ty_len = List.length (args_ty) in - let args_ty_quantifiers_rev,args,args_instance,output,output_instance = - match signature with - None -> - if args_ty = [] then - raise (ProofEngineTypes.Fail (lazy - ("The term " ^ CicPp.ppterm m ^ " has type " ^ - CicPp.ppterm typeofm ^ " that is not a product."))) ; - ignore (check_is_dependent 0 args_ty output) ; - let args = - List.map - (fun (_,ty) -> None,default_relation_for_carrier ty) args_ty in - let output = default_relation_for_carrier output in - [],args,args,output,output - | Some (args,output') -> - assert (args <> []); - let number_of_arguments = List.length args in - let number_of_quantifiers = args_ty_len - number_of_arguments in - if number_of_quantifiers < 0 then - raise (ProofEngineTypes.Fail (lazy - ("The morphism " ^ CicPp.ppterm m ^ " has type " ^ - CicPp.ppterm typeofm ^ " that attends at most " ^ int args_ty_len ^ - " arguments. The signature that you specified requires " ^ - int number_of_arguments ^ " arguments."))) - else - begin - (* the real_args_ty returned are already delifted *) - let args_ty_quantifiers_rev, real_args_ty, real_output = - check_is_dependent number_of_quantifiers args_ty output in - let quantifiers_rel_context = - List.map (fun (n,t) -> n,None,t) args_ty_quantifiers_rev in - let env = push_rel_context quantifiers_rel_context env in - let find_relation_class t real_t = - try - let rel = find_relation_class t in - rel, unify_relation_class_carrier_with_type env rel real_t - with Not_found -> - raise (ProofEngineTypes.Fail (lazy - ("Not a valid signature: " ^ CicPp.ppterm t ^ - " is neither a registered relation nor the Leibniz " ^ - " equality."))) - in - let find_relation_class_v (variance,t) real_t = - let relation,relation_instance = find_relation_class t real_t in - match relation, variance with - Leibniz _, None - | Relation {rel_sym = Some _}, None - | Relation {rel_sym = None}, Some _ -> - (variance, relation), (variance, relation_instance) - | Relation {rel_sym = None},None -> - raise (ProofEngineTypes.Fail (lazy - ("You must specify the variance in each argument " ^ - "whose relation is asymmetric."))) - | Leibniz _, Some _ - | Relation {rel_sym = Some _}, Some _ -> - raise (ProofEngineTypes.Fail (lazy - ("You cannot specify the variance of an argument " ^ - "whose relation is symmetric."))) - in - let args, args_instance = - List.split - (List.map2 find_relation_class_v args real_args_ty) in - let output,output_instance= find_relation_class output' real_output in - args_ty_quantifiers_rev, args, args_instance, output, output_instance - end - in - let argsconstr,outputconstr,lem = - gen_compat_lemma_statement args_ty_quantifiers_rev output_instance - args_instance (apply_to_rels m args_ty_quantifiers_rev) in - (* "unfold make_compatibility_goal" *) - let lem = - Reductionops.clos_norm_flags - (Closure.unfold_red (coq_make_compatibility_goal_eval_ref)) - env Evd.empty lem in - (* "unfold make_compatibility_goal_aux" *) - let lem = - Reductionops.clos_norm_flags - (Closure.unfold_red(coq_make_compatibility_goal_aux_eval_ref)) - env Evd.empty lem in - (* "simpl" *) - let lem = Tacred.nf env Evd.empty lem in - if Lib.is_modtype () then - begin - ignore - (Declare.declare_internal_constant id - (ParameterEntry lem, IsAssumption Logical)) ; - let mor_name = morphism_theory_id_of_morphism_proof_id id in - let lemma_infos = Some (id,argsconstr,outputconstr) in - add_morphism lemma_infos mor_name - (m,args_ty_quantifiers_rev,args,output) - end - else - begin - new_edited id - (m,args_ty_quantifiers_rev,args,argsconstr,output,outputconstr); - Pfedit.start_proof id (Global, Proof Lemma) - (Declare.clear_proofs (Global.named_context ())) - lem hook; - Options.if_verbose msg (Printer.pr_open_subgoals ()); - end -*) assert false - -let morphism_hook _ ref = -(*COQ - let pf_id = id_of_global ref in - let mor_id = morphism_theory_id_of_morphism_proof_id pf_id in - let (m,quantifiers_rev,args,argsconstr,output,outputconstr) = - what_edited pf_id in - if (is_edited pf_id) - then - begin - add_morphism (Some (pf_id,argsconstr,outputconstr)) mor_id - (m,quantifiers_rev,args,output) ; - no_more_edited pf_id - end -*) assert false - -type morphism_signature = - (bool option * Cic.term) list * Cic.term - -let new_named_morphism id m sign = - new_morphism m sign id morphism_hook - -(************************** Adding a relation to the database *********************) - -let check_a a = -(*COQ - let typ = Typing.type_of env Evd.empty a in - let a_quantifiers_rev,_ = Reduction.dest_arity env typ in - a_quantifiers_rev -*) assert false - -let check_eq a_quantifiers_rev a aeq = -(*COQ - let typ = - Sign.it_mkProd_or_LetIn - (Cic.Appl [coq_relation ; apply_to_rels a a_quantifiers_rev]) - a_quantifiers_rev in - if - not - (is_conv env Evd.empty (Typing.type_of env Evd.empty aeq) typ) - then - raise (ProofEngineTypes.Fail (lazy - (CicPp.ppterm aeq ^ " should have type (" ^ CicPp.ppterm typ ^ ")"))) -*) (assert false : unit) - -let check_property a_quantifiers_rev a aeq strprop coq_prop t = -(*COQ - if - not - (is_conv env Evd.empty (Typing.type_of env Evd.empty t) - (Sign.it_mkProd_or_LetIn - (Cic.Appl - [coq_prop ; - apply_to_rels a a_quantifiers_rev ; - apply_to_rels aeq a_quantifiers_rev]) a_quantifiers_rev)) - then - raise (ProofEngineTypes.Fail (lazy - ("Not a valid proof of " ^ strprop ^ "."))) -*) assert false - -let check_refl a_quantifiers_rev a aeq refl = - check_property a_quantifiers_rev a aeq "reflexivity" coq_reflexive refl - -let check_sym a_quantifiers_rev a aeq sym = - check_property a_quantifiers_rev a aeq "symmetry" coq_symmetric sym - -let check_trans a_quantifiers_rev a aeq trans = - check_property a_quantifiers_rev a aeq "transitivity" coq_transitive trans -;; - -let int_add_relation id a aeq refl sym trans = -(*COQ - let env = Global.env () in -*) - let a_quantifiers_rev = check_a a in - check_eq a_quantifiers_rev a aeq ; - HExtlib.iter_option (check_refl a_quantifiers_rev a aeq) refl ; - HExtlib.iter_option (check_sym a_quantifiers_rev a aeq) sym ; - HExtlib.iter_option (check_trans a_quantifiers_rev a aeq) trans ; - let quantifiers_no = List.length a_quantifiers_rev in - let aeq_rel = - { rel_a = a; - rel_aeq = aeq; - rel_refl = refl; - rel_sym = sym; - rel_trans = trans; - rel_quantifiers_no = quantifiers_no; - rel_X_relation_class = Cic.Sort Cic.Prop; (* dummy value, overwritten below *) - rel_Xreflexive_relation_class = Cic.Sort Cic.Prop (* dummy value, overwritten below *) - } in - let _x_relation_class = - let subst = - let len = List.length a_quantifiers_rev in - list_map_i (fun i _ -> Cic.Rel (len - i + 2)) 0 a_quantifiers_rev in - cic_relation_class_of_X_relation - (Cic.Rel 2) (Cic.Rel 1) (apply_to_relation subst aeq_rel) in - let _ = -(*COQ - Declare.declare_internal_constant id - (DefinitionEntry - {const_entry_body = - Sign.it_mkLambda_or_LetIn x_relation_class - ([ Name "v",None,Cic.Rel 1; - Name "X",None,Cic.Sort (Cic.Type (CicUniv.fresh ()))] @ - a_quantifiers_rev); - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Options.boxed_definitions()}, - IsDefinition Definition) in -*) () in - let id_precise = id ^ "_precise_relation_class" in - let _xreflexive_relation_class = - let subst = - let len = List.length a_quantifiers_rev in - list_map_i (fun i _ -> Cic.Rel (len - i)) 0 a_quantifiers_rev - in - cic_precise_relation_class_of_relation (apply_to_relation subst aeq_rel) in - let _ = -(*COQ - Declare.declare_internal_constant id_precise - (DefinitionEntry - {const_entry_body = - Sign.it_mkLambda_or_LetIn xreflexive_relation_class a_quantifiers_rev; - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Options.boxed_definitions() }, - IsDefinition Definition) in -*) () in - let aeq_rel = - { aeq_rel with - rel_X_relation_class = current_constant id; - rel_Xreflexive_relation_class = current_constant id_precise } in - relation_to_obj (aeq, aeq_rel) ; - prerr_endline (CicPp.ppterm aeq ^ " is registered as a relation"); - match trans with - None -> () - | Some trans -> - let mor_name = id ^ "_morphism" in - let a_instance = apply_to_rels a a_quantifiers_rev in - let aeq_instance = apply_to_rels aeq a_quantifiers_rev in - let sym_instance = - HExtlib.map_option (fun x -> apply_to_rels x a_quantifiers_rev) sym in - let refl_instance = - HExtlib.map_option (fun x -> apply_to_rels x a_quantifiers_rev) refl in - let trans_instance = apply_to_rels trans a_quantifiers_rev in - let aeq_rel_class_and_var1, aeq_rel_class_and_var2, lemma, output = - match sym_instance, refl_instance with - None, None -> - (Some false, Relation aeq_rel), - (Some true, Relation aeq_rel), - Cic.Appl - [coq_equality_morphism_of_asymmetric_areflexive_transitive_relation; - a_instance ; aeq_instance ; trans_instance], - coq_impl_relation - | None, Some refl_instance -> - (Some false, Relation aeq_rel), - (Some true, Relation aeq_rel), - Cic.Appl - [coq_equality_morphism_of_asymmetric_reflexive_transitive_relation; - a_instance ; aeq_instance ; refl_instance ; trans_instance], - coq_impl_relation - | Some sym_instance, None -> - (None, Relation aeq_rel), - (None, Relation aeq_rel), - Cic.Appl - [coq_equality_morphism_of_symmetric_areflexive_transitive_relation; - a_instance ; aeq_instance ; sym_instance ; trans_instance], - coq_iff_relation - | Some sym_instance, Some refl_instance -> - (None, Relation aeq_rel), - (None, Relation aeq_rel), - Cic.Appl - [coq_equality_morphism_of_symmetric_reflexive_transitive_relation; - a_instance ; aeq_instance ; refl_instance ; sym_instance ; - trans_instance], - coq_iff_relation in - let _ = -(*COQ - Declare.declare_internal_constant mor_name - (DefinitionEntry - {const_entry_body = Sign.it_mkLambda_or_LetIn lemma a_quantifiers_rev; - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Options.boxed_definitions()}, - IsDefinition Definition) -*) () - in - let a_quantifiers_rev = - List.map (fun (n,b,t) -> assert (b = None); n,t) a_quantifiers_rev in - add_morphism None mor_name - (aeq,a_quantifiers_rev,[aeq_rel_class_and_var1; aeq_rel_class_and_var2], - output) - -(* The vernac command "Add Relation ..." *) -let add_relation id a aeq refl sym trans = - int_add_relation id a aeq refl sym trans - -(****************************** The tactic itself *******************************) - -type direction = - Left2Right - | Right2Left - -let prdirection = - function - Left2Right -> "->" - | Right2Left -> "<-" - -type constr_with_marks = - | MApp of Cic.term * morphism_class * constr_with_marks list * direction - | ToReplace - | ToKeep of Cic.term * relation relation_class * direction - -let is_to_replace = function - | ToKeep _ -> false - | ToReplace -> true - | MApp _ -> true - -let get_mark a = - List.fold_left (||) false (List.map is_to_replace a) - -let cic_direction_of_direction = - function - Left2Right -> coq_Left2Right - | Right2Left -> coq_Right2Left - -let opposite_direction = - function - Left2Right -> Right2Left - | Right2Left -> Left2Right - -let direction_of_constr_with_marks hole_direction = - function - MApp (_,_,_,dir) -> cic_direction_of_direction dir - | ToReplace -> hole_direction - | ToKeep (_,_,dir) -> cic_direction_of_direction dir - -type argument = - Toapply of Cic.term (* apply the function to the argument *) - | Toexpand of Cic.name * Cic.term (* beta-expand the function w.r.t. an argument - of this type *) -let beta_expand c args_rev = - let rec to_expand = - function - [] -> [] - | (Toapply _)::tl -> to_expand tl - | (Toexpand (name,s))::tl -> (name,s)::(to_expand tl) in - let rec aux n = - function - [] -> [] - | (Toapply arg)::tl -> arg::(aux n tl) - | (Toexpand _)::tl -> (Cic.Rel n)::(aux (n + 1) tl) - in - compose_lambda (to_expand args_rev) - (Cic.Appl (c :: List.rev (aux 1 args_rev))) - -exception Optimize (* used to fall-back on the tactic for Leibniz equality *) - -let rec list_sep_last = function - | [] -> assert false - | hd::[] -> (hd,[]) - | hd::tl -> let (l,tl) = list_sep_last tl in (l,hd::tl) - -let relation_class_that_matches_a_constr caller_name new_goals hypt = - let heq, hargs = - match hypt with - Cic.Appl (heq::hargs) -> heq,hargs - | _ -> hypt,[] - in - let rec get_all_but_last_two = - function - [] - | [_] -> - raise (ProofEngineTypes.Fail (lazy (CicPp.ppterm hypt ^ - " is not a registered relation."))) - | [_;_] -> [] - | he::tl -> he::(get_all_but_last_two tl) in - let all_aeq_args = get_all_but_last_two hargs in - let rec find_relation l subst = - let aeq = Cic.Appl (heq::l) in - try - let rel = find_relation_class aeq in - match rel,new_goals with - Leibniz _,[] -> - assert (subst = []); - raise Optimize (* let's optimize the proof term size *) - | Leibniz (Some _), _ -> - assert (subst = []); - rel - | Leibniz None, _ -> - (* for well-typedness reasons it should have been catched by the - previous guard in the previous iteration. *) - assert false - | Relation rel,_ -> Relation (apply_to_relation subst rel) - with Not_found -> - if l = [] then - raise (ProofEngineTypes.Fail (lazy - (CicPp.ppterm (Cic.Appl (aeq::all_aeq_args)) ^ - " is not a registered relation."))) - else - let last,others = list_sep_last l in - find_relation others (last::subst) - in - find_relation all_aeq_args [] - -(* rel1 is a subrelation of rel2 whenever - forall x1 x2, rel1 x1 x2 -> rel2 x1 x2 - The Coq part of the tactic, however, needs rel1 == rel2. - Hence the third case commented out. - Note: accepting user-defined subtrelations seems to be the last - useful generalization that does not go against the original spirit of - the tactic. -*) -let subrelation gl rel1 rel2 = - match rel1,rel2 with - Relation {rel_aeq=rel_aeq1}, Relation {rel_aeq=rel_aeq2} -> - (*COQ Tacmach.pf_conv_x gl rel_aeq1 rel_aeq2*) assert false - | Leibniz (Some t1), Leibniz (Some t2) -> - (*COQ Tacmach.pf_conv_x gl t1 t2*) assert false - | Leibniz None, _ - | _, Leibniz None -> assert false -(* This is the commented out case (see comment above) - | Leibniz (Some t1), Relation {rel_a=t2; rel_refl = Some _} -> - Tacmach.pf_conv_x gl t1 t2 -*) - | _,_ -> false - -(* this function returns the list of new goals opened by a constr_with_marks *) -let rec collect_new_goals = - function - MApp (_,_,a,_) -> List.concat (List.map collect_new_goals a) - | ToReplace - | ToKeep (_,Leibniz _,_) - | ToKeep (_,Relation {rel_refl=Some _},_) -> [] - | ToKeep (c,Relation {rel_aeq=aeq; rel_refl=None},_) -> [Cic.Appl[aeq;c;c]] - -(* two marked_constr are equivalent if they produce the same set of new goals *) -let marked_constr_equiv_or_more_complex to_marked_constr gl c1 c2 = - let glc1 = collect_new_goals (to_marked_constr c1) in - let glc2 = collect_new_goals (to_marked_constr c2) in - List.for_all (fun c -> List.exists (fun c' -> (*COQ pf_conv_x gl c c'*) assert false) glc1) glc2 - -let pr_new_goals i c = - let glc = collect_new_goals c in - " " ^ string_of_int i ^ ") side conditions:" ^ - (if glc = [] then " no side conditions" - else - ("\n " ^ - String.concat "\n " - (List.map (fun c -> " ... |- " ^ CicPp.ppterm c) glc))) - -(* given a list of constr_with_marks, it returns the list where - constr_with_marks than open more goals than simpler ones in the list - are got rid of *) -let elim_duplicates gl to_marked_constr = - let rec aux = - function - [] -> [] - | he:: tl -> - if List.exists - (marked_constr_equiv_or_more_complex to_marked_constr gl he) tl - then aux tl - else he::aux tl - in - aux - -let filter_superset_of_new_goals gl new_goals l = - List.filter - (fun (_,_,c) -> - List.for_all - (fun g -> List.exists ((*COQ pf_conv_x gl g*)assert false) (collect_new_goals c)) new_goals) l - -(* given the list of lists [ l1 ; ... ; ln ] it returns the list of lists - [ c1 ; ... ; cn ] that is the cartesian product of the sets l1, ..., ln *) -let cartesian_product gl a = - let rec aux = - function - [] -> assert false - | [he] -> List.map (fun e -> [e]) he - | he::tl -> - let tl' = aux tl in - List.flatten - (List.map (function e -> List.map (function l -> e :: l) tl') he) - in - aux (List.map (elim_duplicates gl (fun x -> x)) a) - -let does_not_occur n t = assert false - -let mark_occur gl ~new_goals t in_c input_relation input_direction = - let rec aux output_relation output_direction in_c = - if t = in_c then - if input_direction = output_direction - && subrelation gl input_relation output_relation then - [ToReplace] - else [] - else - match in_c with - | Cic.Appl (c::al) -> - let mors_and_cs_and_als = - let mors_and_cs_and_als = - let morphism_table_find c = - try morphism_table_find c with Not_found -> [] in - let rec aux acc = - function - [] -> - let c' = Cic.Appl (c::acc) in - let al' = [] in - List.map (fun m -> m,c',al') (morphism_table_find c') - | (he::tl) as l -> - let c' = Cic.Appl (c::acc) in - let acc' = acc @ [he] in - (List.map (fun m -> m,c',l) (morphism_table_find c')) @ - (aux acc' tl) - in - aux [] al in - let mors_and_cs_and_als = - List.map - (function (m,c,al) -> - relation_morphism_of_constr_morphism m, c, al) - mors_and_cs_and_als in - let mors_and_cs_and_als = - List.fold_left - (fun l (m,c,al) -> - try (unify_morphism_with_arguments gl (c,al) m t) :: l - with Impossible -> l - ) [] mors_and_cs_and_als - in - List.filter - (fun (mor,_,_) -> subrelation gl mor.output output_relation) - mors_and_cs_and_als - in - (* First we look for well typed morphisms *) - let res_mors = - List.fold_left - (fun res (mor,c,al) -> - let a = - let arguments = mor.args in - let apply_variance_to_direction default_dir = - function - None -> default_dir - | Some true -> output_direction - | Some false -> opposite_direction output_direction - in - List.map2 - (fun a (variance,relation) -> - (aux relation - (apply_variance_to_direction Left2Right variance) a) @ - (aux relation - (apply_variance_to_direction Right2Left variance) a) - ) al arguments - in - let a' = cartesian_product gl a in - (List.map - (function a -> - if not (get_mark a) then - ToKeep (in_c,output_relation,output_direction) - else - MApp (c,ACMorphism mor,a,output_direction)) a') @ res - ) [] mors_and_cs_and_als in - (* Then we look for well typed functions *) - let res_functions = - (* the tactic works only if the function type is - made of non-dependent products only. However, here we - can cheat a bit by partially istantiating c to match - the requirement when the arguments to be replaced are - bound by non-dependent products only. *) - let typeofc = (*COQ Tacmach.pf_type_of gl c*) assert false in - let typ = (*COQ nf_betaiota typeofc*) let _ = typeofc in assert false in - let rec find_non_dependent_function context c c_args_rev typ - f_args_rev a_rev - = - function - [] -> - if a_rev = [] then - [ToKeep (in_c,output_relation,output_direction)] - else - let a' = - cartesian_product gl (List.rev a_rev) - in - List.fold_left - (fun res a -> - if not (get_mark a) then - (ToKeep (in_c,output_relation,output_direction))::res - else - let err = - match output_relation with - Leibniz (Some typ') when (*COQ pf_conv_x gl typ typ'*) assert false -> - false - | Leibniz None -> assert false - | _ when output_relation = coq_iff_relation - -> false - | _ -> true - in - if err then res - else - let mor = - ACFunction{f_args=List.rev f_args_rev;f_output=typ} in - let func = beta_expand c c_args_rev in - (MApp (func,mor,a,output_direction))::res - ) [] a' - | (he::tl) as a-> - let typnf = (*COQ Reduction.whd_betadeltaiota env typ*) assert false in - match typnf with - Cic.Cast (typ,_) -> - find_non_dependent_function context c c_args_rev typ - f_args_rev a_rev a - | Cic.Prod (name,s,t) -> - let context' = Some (name, Cic.Decl s)::context in - let he = - (aux (Leibniz (Some s)) Left2Right he) @ - (aux (Leibniz (Some s)) Right2Left he) in - if he = [] then [] - else - let he0 = List.hd he in - begin - match does_not_occur 1 t, he0 with - _, ToKeep (arg,_,_) -> - (* invariant: if he0 = ToKeep (t,_,_) then every - element in he is = ToKeep (t,_,_) *) - assert - (List.for_all - (function - ToKeep(arg',_,_) when (*COQpf_conv_x gl arg arg'*) assert false -> - true - | _ -> false) he) ; - (* generic product, to keep *) - find_non_dependent_function - context' c ((Toapply arg)::c_args_rev) - (CicSubstitution.subst arg t) f_args_rev a_rev tl - | true, _ -> - (* non-dependent product, to replace *) - find_non_dependent_function - context' c ((Toexpand (name,s))::c_args_rev) - (CicSubstitution.lift 1 t) (s::f_args_rev) (he::a_rev) tl - | false, _ -> - (* dependent product, to replace *) - (* This limitation is due to the reflexive - implementation and it is hard to lift *) - raise (ProofEngineTypes.Fail (lazy - ("Cannot rewrite in the argument of a " ^ - "dependent product. If you need this " ^ - "feature, please report to the author."))) - end - | _ -> assert false - in - find_non_dependent_function (*COQ (Tacmach.pf_env gl) ci vuole il contesto*)(assert false) c [] typ [] [] - al - in - elim_duplicates gl (fun x -> x) (res_functions @ res_mors) - | Cic.Prod (_, c1, c2) -> - if (*COQ (dependent (Cic.Rel 1) c2)*) assert false - then - raise (ProofEngineTypes.Fail (lazy - ("Cannot rewrite in the type of a variable bound " ^ - "in a dependent product."))) - else - let typeofc1 = (*COQ Tacmach.pf_type_of gl c1*) assert false in - if not (*COQ (Tacmach.pf_conv_x gl typeofc1 (Cic.Sort Cic.Prop))*) (assert false) then - (* to avoid this error we should introduce an impl relation - whose first argument is Type instead of Prop. However, - the type of the new impl would be Type -> Prop -> Prop - that is no longer a Relation_Definitions.relation. Thus - the Coq part of the tactic should be heavily modified. *) - raise (ProofEngineTypes.Fail (lazy - ("Rewriting in a product A -> B is possible only when A " ^ - "is a proposition (i.e. A is of type Prop). The type " ^ - CicPp.ppterm c1 ^ " has type " ^ CicPp.ppterm typeofc1 ^ - " that is not convertible to Prop."))) - else - aux output_relation output_direction - (Cic.Appl [coq_impl; c1 ; CicSubstitution.subst (Cic.Rel 1 (*dummy*)) c2]) - | _ -> - if (*COQ occur_term t in_c*) assert false then - raise (ProofEngineTypes.Fail (lazy - ("Trying to replace " ^ CicPp.ppterm t ^ " in " ^ CicPp.ppterm in_c ^ - " that is not an applicative context."))) - else - [ToKeep (in_c,output_relation,output_direction)] - in - let aux2 output_relation output_direction = - List.map - (fun res -> output_relation,output_direction,res) - (aux output_relation output_direction in_c) in - let res = - (aux2 coq_iff_relation Right2Left) @ - (* This is the case of a proposition of signature A ++> iff or B --> iff *) - (aux2 coq_iff_relation Left2Right) @ - (aux2 coq_impl_relation Right2Left) in - let res = elim_duplicates gl (function (_,_,t) -> t) res in - let res' = filter_superset_of_new_goals gl new_goals res in - match res' with - [] when res = [] -> - raise (ProofEngineTypes.Fail (lazy - ("Either the term " ^ CicPp.ppterm t ^ " that must be " ^ - "rewritten occurs in a covariant position or the goal is not " ^ - "made of morphism applications only. You can replace only " ^ - "occurrences that are in a contravariant position and such that " ^ - "the context obtained by abstracting them is made of morphism " ^ - "applications only."))) - | [] -> - raise (ProofEngineTypes.Fail (lazy - ("No generated set of side conditions is a superset of those " ^ - "requested by the user. The generated sets of side conditions " ^ - "are:\n" ^ - prlist_with_sepi "\n" - (fun i (_,_,mc) -> pr_new_goals i mc) res))) - | [he] -> he - | he::_ -> - prerr_endline - ("Warning: The application of the tactic is subject to one of " ^ - "the \nfollowing set of side conditions that the user needs " ^ - "to prove:\n" ^ - prlist_with_sepi "\n" - (fun i (_,_,mc) -> pr_new_goals i mc) res' ^ - "\nThe first set is randomly chosen. Use the syntax " ^ - "\"setoid_rewrite ... generate side conditions ...\" to choose " ^ - "a different set.") ; - he - -let cic_morphism_context_list_of_list hole_relation hole_direction out_direction -= - let check = - function - (None,dir,dir') -> - Cic.Appl [coq_MSNone ; dir ; dir'] - | (Some true,dir,dir') -> - assert (dir = dir'); - Cic.Appl [coq_MSCovariant ; dir] - | (Some false,dir,dir') -> - assert (dir <> dir'); - Cic.Appl [coq_MSContravariant ; dir] in - let rec aux = - function - [] -> assert false - | [(variance,out),(value,direction)] -> - Cic.Appl [coq_singl ; coq_Argument_Class ; out], - Cic.Appl - [coq_fcl_singl; - hole_relation; hole_direction ; out ; - direction ; out_direction ; - check (variance,direction,out_direction) ; value] - | ((variance,out),(value,direction))::tl -> - let outtl, valuetl = aux tl in - Cic.Appl - [coq_cons; coq_Argument_Class ; out ; outtl], - Cic.Appl - [coq_fcl_cons; - hole_relation ; hole_direction ; out ; outtl ; - direction ; out_direction ; - check (variance,direction,out_direction) ; - value ; valuetl] - in aux - -let rec cic_type_nelist_of_list = - function - [] -> assert false - | [value] -> - Cic.Appl [coq_singl; Cic.Sort (Cic.Type (CicUniv.fresh ())) ; value] - | value::tl -> - Cic.Appl - [coq_cons; Cic.Sort (Cic.Type (CicUniv.fresh ())); value; - cic_type_nelist_of_list tl] - -let syntactic_but_representation_of_marked_but hole_relation hole_direction = - let rec aux out (rel_out,precise_out,is_reflexive) = - function - MApp (f, m, args, direction) -> - let direction = cic_direction_of_direction direction in - let morphism_theory, relations = - match m with - ACMorphism { args = args ; morphism_theory = morphism_theory } -> - morphism_theory,args - | ACFunction { f_args = f_args ; f_output = f_output } -> - let mt = - if (*COQ eq_constr out (cic_relation_class_of_relation_class - coq_iff_relation)*) assert false - then - Cic.Appl - [coq_morphism_theory_of_predicate; - cic_type_nelist_of_list f_args; f] - else - Cic.Appl - [coq_morphism_theory_of_function; - cic_type_nelist_of_list f_args; f_output; f] - in - mt,List.map (fun x -> None,Leibniz (Some x)) f_args in - let cic_relations = - List.map - (fun (variance,r) -> - variance, - r, - cic_relation_class_of_relation_class r, - cic_precise_relation_class_of_relation_class r - ) relations in - let cic_args_relations,argst = - cic_morphism_context_list_of_list hole_relation hole_direction direction - (List.map2 - (fun (variance,trel,t,precise_t) v -> - (variance,cic_argument_class_of_argument_class (variance,trel)), - (aux t precise_t v, - direction_of_constr_with_marks hole_direction v) - ) cic_relations args) - in - Cic.Appl - [coq_App; - hole_relation ; hole_direction ; - cic_args_relations ; out ; direction ; - morphism_theory ; argst] - | ToReplace -> - Cic.Appl [coq_ToReplace ; hole_relation ; hole_direction] - | ToKeep (c,_,direction) -> - let direction = cic_direction_of_direction direction in - if is_reflexive then - Cic.Appl - [coq_ToKeep ; hole_relation ; hole_direction ; precise_out ; - direction ; c] - else - let c_is_proper = - let typ = Cic.Appl [rel_out ; c ; c] in - Cic.Cast ((*COQ Evarutil.mk_new_meta ()*)assert false, typ) - in - Cic.Appl - [coq_ProperElementToKeep ; - hole_relation ; hole_direction; precise_out ; - direction; c ; c_is_proper] - in aux - -let apply_coq_setoid_rewrite hole_relation prop_relation c1 c2 (direction,h) - prop_direction m -= - let hole_relation = cic_relation_class_of_relation_class hole_relation in - let hyp,hole_direction = h,cic_direction_of_direction direction in - let cic_prop_relation = cic_relation_class_of_relation_class prop_relation in - let precise_prop_relation = - cic_precise_relation_class_of_relation_class prop_relation - in - Cic.Appl - [coq_setoid_rewrite; - hole_relation ; hole_direction ; cic_prop_relation ; - prop_direction ; c1 ; c2 ; - syntactic_but_representation_of_marked_but hole_relation hole_direction - cic_prop_relation precise_prop_relation m ; hyp] - -(*COQ -let check_evar_map_of_evars_defs evd = - let metas = Evd.meta_list evd in - let check_freemetas_is_empty rebus = - Evd.Metaset.iter - (fun m -> - if Evd.meta_defined evd m then () else - raise (Logic.RefinerError (Logic.OccurMetaGoal rebus))) - in - List.iter - (fun (_,binding) -> - match binding with - Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) -> - check_freemetas_is_empty rebus freemetas - | Evd.Clval (_,{Evd.rebus=rebus1; Evd.freemetas=freemetas1}, - {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) -> - check_freemetas_is_empty rebus1 freemetas1 ; - check_freemetas_is_empty rebus2 freemetas2 - ) metas -*) - -(* For a correct meta-aware "rewrite in", we split unification - apart from the actual rewriting (Pierre L, 05/04/06) *) - -(* [unification_rewrite] searchs a match for [c1] in [but] and then - returns the modified objects (in particular [c1] and [c2]) *) - -let unification_rewrite c1 c2 cl but gl = -(*COQ - let (env',c1) = - try - (* ~mod_delta:false to allow to mark occurences that must not be - rewritten simply by replacing them with let-defined definitions - in the context *) - w_unify_to_subterm ~mod_delta:false (pf_env gl) (c1,but) cl.env - with - Pretype_errors.PretypeError _ -> - (* ~mod_delta:true to make Ring work (since it really - exploits conversion) *) - w_unify_to_subterm ~mod_delta:true (pf_env gl) (c1,but) cl.env - in - let cl' = {cl with env = env' } in - let c2 = Clenv.clenv_nf_meta cl' c2 in - check_evar_map_of_evars_defs env' ; - env',Clenv.clenv_value cl', c1, c2 -*) assert false - -(* no unification is performed in this function. [sigma] is the - substitution obtained from an earlier unification. *) - -let relation_rewrite_no_unif c1 c2 hyp ~new_goals sigma gl = - let but = (*COQ pf_concl gl*) assert false in - try - let input_relation = - relation_class_that_matches_a_constr "Setoid_rewrite" - new_goals ((*COQTyping.mtype_of (pf_env gl) sigma (snd hyp)*) assert false) in - let output_relation,output_direction,marked_but = - mark_occur gl ~new_goals c1 but input_relation (fst hyp) in - let cic_output_direction = cic_direction_of_direction output_direction in - let if_output_relation_is_iff gl = - let th = - apply_coq_setoid_rewrite input_relation output_relation c1 c2 hyp - cic_output_direction marked_but - in - let new_but = (*COQ Termops.replace_term c1 c2 but*) assert false in - let hyp1,hyp2,proj = - match output_direction with - Right2Left -> new_but, but, coq_proj1 - | Left2Right -> but, new_but, coq_proj2 - in - let impl1 = Cic.Prod (Cic.Anonymous, hyp2, CicSubstitution.lift 1 hyp1) in - let impl2 = Cic.Prod (Cic.Anonymous, hyp1, CicSubstitution.lift 1 hyp2) in - let th' = Cic.Appl [proj; impl2; impl1; th] in - (*COQ Tactics.refine - (Cic.Appl [th'; mkCast (Evarutil.mk_new_meta(), DEFAULTcast, new_but)]) - gl*) let _ = th' in assert false in - let if_output_relation_is_if gl = - let th = - apply_coq_setoid_rewrite input_relation output_relation c1 c2 hyp - cic_output_direction marked_but - in - let new_but = (*COQ Termops.replace_term c1 c2 but*) assert false in - (*COQ Tactics.refine - (Cic.Appl [th ; mkCast (Evarutil.mk_new_meta(), DEFAULTcast, new_but)]) - gl*) let _ = new_but,th in assert false in - if output_relation = coq_iff_relation then - if_output_relation_is_iff gl - else - if_output_relation_is_if gl - with - Optimize -> - (*COQ !general_rewrite (fst hyp = Left2Right) (snd hyp) gl*) assert false - -let relation_rewrite c1 c2 (input_direction,cl) ~new_goals gl = - let (sigma,cl,c1,c2) = unification_rewrite c1 c2 cl ((*COQ pf_concl gl*) assert false) gl in - relation_rewrite_no_unif c1 c2 (input_direction,cl) ~new_goals sigma gl - -let analyse_hypothesis gl c = - let ctype = (*COQ pf_type_of gl c*) assert false in - let eqclause = (*COQ Clenv.make_clenv_binding gl (c,ctype) Rawterm.NoBindings*) let _ = ctype in assert false in - let (equiv, args) = (*COQ decompose_app (Clenv.clenv_type eqclause)*) assert false in - let rec split_last_two = function - | [c1;c2] -> [],(c1, c2) - | x::y::z -> - let l,res = split_last_two (y::z) in x::l, res - | _ -> raise (ProofEngineTypes.Fail (lazy "The term provided is not an equivalence")) in - let others,(c1,c2) = split_last_two args in - eqclause,Cic.Appl (equiv::others),c1,c2 - -let general_s_rewrite lft2rgt c ~new_goals (*COQgl*) = -(*COQ - let eqclause,_,c1,c2 = analyse_hypothesis gl c in - if lft2rgt then - relation_rewrite c1 c2 (Left2Right,eqclause) ~new_goals gl - else - relation_rewrite c2 c1 (Right2Left,eqclause) ~new_goals gl -*) assert false - -let relation_rewrite_in id c1 c2 (direction,eqclause) ~new_goals gl = - let hyp = (*COQ pf_type_of gl (mkVar id)*) assert false in - (* first, we find a match for c1 in the hyp *) - let (sigma,cl,c1,c2) = unification_rewrite c1 c2 eqclause hyp gl in - (* since we will actually rewrite in the opposite direction, we also need - to replace every occurrence of c2 (resp. c1) in hyp with something that - is convertible but not syntactically equal. To this aim we introduce a - let-in and then we will use the intro tactic to get rid of it. - Quite tricky to do properly since c1 can occur in c2 or vice-versa ! *) - let mangled_new_hyp = - let hyp = CicSubstitution.lift 2 hyp in - (* first, we backup every occurences of c1 in newly allocated (Rel 1) *) - let hyp = (*COQ Termops.replace_term (CicSubstitution.lift 2 c1) (Cic.Rel 1) hyp*) let _ = hyp in assert false in - (* then, we factorize every occurences of c2 into (Rel 2) *) - let hyp = (*COQ Termops.replace_term (CicSubstitution.lift 2 c2) (Cic.Rel 2) hyp*) let _ = hyp in assert false in - (* Now we substitute (Rel 1) (i.e. c1) for c2 *) - let hyp = CicSubstitution.subst (CicSubstitution.lift 1 c2) hyp in - (* Since CicSubstitution.subst has killed Rel 1 and decreased the other Rels, - Rel 1 is now coding for c2, we can build the let-in factorizing c2 *) - Cic.LetIn (Cic.Anonymous,c2,assert false,hyp) - in - let new_hyp = (*COQ Termops.replace_term c1 c2 hyp*) assert false in - let oppdir = opposite_direction direction in -(*COQ - cut_replacing id new_hyp - (tclTHENLAST - (tclTHEN (change_in_concl None mangled_new_hyp) - (tclTHEN intro - (relation_rewrite_no_unif c2 c1 (oppdir,cl) ~new_goals sigma)))) - gl -*) let _ = oppdir,new_hyp,mangled_new_hyp in assert false - -let general_s_rewrite_in id lft2rgt c ~new_goals (*COQgl*) = -(*COQ - let eqclause,_,c1,c2 = analyse_hypothesis gl c in - if lft2rgt then - relation_rewrite_in id c1 c2 (Left2Right,eqclause) ~new_goals gl - else - relation_rewrite_in id c2 c1 (Right2Left,eqclause) ~new_goals gl -*) assert false - -let setoid_replace relation c1 c2 ~new_goals (*COQgl*) = - try - let relation = - match relation with - Some rel -> - (try - match find_relation_class rel with - Relation sa -> sa - | Leibniz _ -> raise Optimize - with - Not_found -> - raise (ProofEngineTypes.Fail (lazy - (CicPp.ppterm rel ^ " is not a registered relation.")))) - | None -> - match default_relation_for_carrier ((*COQ pf_type_of gl c1*) assert false) with - Relation sa -> sa - | Leibniz _ -> raise Optimize - in - let eq_left_to_right = Cic.Appl [relation.rel_aeq; c1 ; c2] in - let eq_right_to_left = Cic.Appl [relation.rel_aeq; c2 ; c1] in -(*COQ - let replace dir eq = - tclTHENS (assert_tac false Cic.Anonymous eq) - [onLastHyp (fun id -> - tclTHEN - (general_s_rewrite dir (mkVar id) ~new_goals) - (clear [id])); - Tacticals.tclIDTAC] - in - tclORELSE - (replace true eq_left_to_right) (replace false eq_right_to_left) gl -*) let _ = eq_left_to_right,eq_right_to_left in assert false - with - Optimize -> (*COQ (!replace c1 c2) gl*) assert false - -let setoid_replace_in id relation c1 c2 ~new_goals (*COQgl*) = -(*COQ - let hyp = pf_type_of gl (mkVar id) in - let new_hyp = Termops.replace_term c1 c2 hyp in - cut_replacing id new_hyp - (fun exact -> tclTHENLASTn - (setoid_replace relation c2 c1 ~new_goals) - [| exact; tclIDTAC |]) gl -*) assert false - -(* [setoid_]{reflexivity,symmetry,transitivity} tactics *) - -let setoid_reflexivity_tac = - let tac ((proof,goal) as status) = - let (_,metasenv,_subst,_,_, _) = proof in - let metano,context,ty = CicUtil.lookup_meta goal metasenv in - try - let relation_class = - relation_class_that_matches_a_constr "Setoid_reflexivity" [] ty in - match relation_class with - Leibniz _ -> assert false (* since [] is empty *) - | Relation rel -> - match rel.rel_refl with - None -> - raise (ProofEngineTypes.Fail (lazy - ("The relation " ^ prrelation rel ^ " is not reflexive."))) - | Some refl -> - ProofEngineTypes.apply_tactic (PrimitiveTactics.apply_tac refl) - status - with - Optimize -> - ProofEngineTypes.apply_tactic EqualityTactics.reflexivity_tac status - in - ProofEngineTypes.mk_tactic tac - -let setoid_reflexivity_tac = - let start_tac = RT.whd_tac ~pattern:(PET.conclusion_pattern None) in - let fail_tac = T.then_ ~start:start_tac ~continuation:setoid_reflexivity_tac in - T.if_ ~start:setoid_reflexivity_tac ~continuation:T.id_tac ~fail:fail_tac - -let setoid_symmetry = - let tac status = - try - let relation_class = - relation_class_that_matches_a_constr "Setoid_symmetry" - [] ((*COQ pf_concl gl*) assert false) in - match relation_class with - Leibniz _ -> assert false (* since [] is empty *) - | Relation rel -> - match rel.rel_sym with - None -> - raise (ProofEngineTypes.Fail (lazy - ("The relation " ^ prrelation rel ^ " is not symmetric."))) - | Some sym -> (*COQ apply sym gl*) assert false - with - Optimize -> (*COQ symmetry gl*) assert false - in - ProofEngineTypes.mk_tactic tac - -let setoid_symmetry_in id (*COQgl*) = -(*COQ - let new_hyp = - let _,he,c1,c2 = analyse_hypothesis gl (mkVar id) in - Cic.Appl [he ; c2 ; c1] - in - cut_replacing id new_hyp (tclTHEN setoid_symmetry) gl -*) assert false - -let setoid_transitivity c (*COQgl*) = - try - let relation_class = - relation_class_that_matches_a_constr "Setoid_transitivity" - [] ((*COQ pf_concl gl*) assert false) in - match relation_class with - Leibniz _ -> assert false (* since [] is empty *) - | Relation rel -> -(*COQ - let ctyp = pf_type_of gl c in - let rel' = unify_relation_carrier_with_type (pf_env gl) rel ctyp in - match rel'.rel_trans with - None -> - raise (ProofEngineTypes.Fail (lazy - ("The relation " ^ prrelation rel ^ " is not transitive."))) - | Some trans -> - let transty = nf_betaiota (pf_type_of gl trans) in - let argsrev, _ = - Reductionops.decomp_n_prod (pf_env gl) Evd.empty 2 transty in - let binder = - match List.rev argsrev with - _::(Name n2,None,_)::_ -> Rawterm.NamedHyp n2 - | _ -> assert false - in - apply_with_bindings - (trans, Rawterm.ExplicitBindings [ dummy_loc, binder, c ]) gl -*) assert false - with - Optimize -> (*COQ transitivity c gl*) assert false -;; - -(*COQ -Tactics.register_setoid_reflexivity setoid_reflexivity;; -Tactics.register_setoid_symmetry setoid_symmetry;; -Tactics.register_setoid_symmetry_in setoid_symmetry_in;; -Tactics.register_setoid_transitivity setoid_transitivity;; -*) diff --git a/matita/components/tactics/setoids.mli b/matita/components/tactics/setoids.mli deleted file mode 100644 index abe71f4eb..000000000 --- a/matita/components/tactics/setoids.mli +++ /dev/null @@ -1,70 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Cic.term -> ProofEngineTypes.tactic) -> unit -val register_general_rewrite : (bool -> Cic.term -> ProofEngineTypes.tactic) -> unit - -val print_setoids : unit -> unit - -val equiv_list : unit -> Cic.term list -val default_relation_for_carrier : - ?filter:(relation -> bool) -> Cic.term -> relation relation_class -(* [default_morphism] raises [Not_found] *) -val default_morphism : - ?filter:(Cic.term morphism -> bool) -> Cic.term -> relation morphism - -val setoid_replace : - Cic.term option -> Cic.term -> Cic.term -> new_goals:Cic.term list -> ProofEngineTypes.tactic -val setoid_replace_in : - string -> Cic.term option -> Cic.term -> Cic.term -> new_goals:Cic.term list -> - ProofEngineTypes.tactic - -val general_s_rewrite : bool -> Cic.term -> new_goals:Cic.term list -> ProofEngineTypes.tactic -val general_s_rewrite_in : - string -> bool -> Cic.term -> new_goals:Cic.term list -> ProofEngineTypes.tactic - -val setoid_reflexivity_tac : ProofEngineTypes.tactic -val setoid_symmetry : ProofEngineTypes.tactic -val setoid_symmetry_in : string -> ProofEngineTypes.tactic -val setoid_transitivity : Cic.term -> ProofEngineTypes.tactic - -val add_relation : - string -> Cic.term -> Cic.term -> Cic.term option -> - Cic.term option -> Cic.term option -> unit - -val new_named_morphism : - string -> Cic.term -> morphism_signature option -> unit - -val relation_table_find : Cic.term -> relation -val relation_table_mem : Cic.term -> bool diff --git a/matita/components/tactics/statefulProofEngine.ml b/matita/components/tactics/statefulProofEngine.ml deleted file mode 100644 index 37800187a..000000000 --- a/matita/components/tactics/statefulProofEngine.ml +++ /dev/null @@ -1,216 +0,0 @@ -(* Copyright (C) 2004, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -let default_history_size = 20 - -exception No_goal_left -exception Uri_redefinition -type event = [ `Proof_changed | `Proof_completed ] -let all_events = [ `Proof_changed; `Proof_completed ] -let default_events: event list = [ `Proof_changed ] - -type proof_status = ProofEngineTypes.proof * ProofEngineTypes.goal option - -type 'a observer = (proof_status * 'a) option -> (proof_status * 'a) -> unit -type observer_id = int - -exception Observer_failures of (observer_id * exn) list -exception Tactic_failure of exn -exception Data_failure of exn - -class ['a] status - ?(history_size = default_history_size) - ?uri ~typ ~body ~metasenv ~attrs init_data compute_data () - = - let next_observer_id = - let next_id = ref 0 in - fun () -> - incr next_id; - !next_id - in - let _subst = ([] : Cic.substitution) in - let initial_proof = ((uri: UriManager.uri option), metasenv, _subst, body, typ, attrs) 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 attrs = let (_, _, _, _, _, attrs) = _proof in attrs - - method set_metasenv metasenv = - let (uri, _, _subst,body, typ, attes) = _proof in - _proof <- (uri, metasenv, _subst,body, typ, attrs) - - method set_uri uri = - let (old_uri, metasenv, _subst,body, typ, attrs) = _proof in - if old_uri <> None then - raise Uri_redefinition; - _proof <- (Some uri, metasenv, _subst,body, typ, attrs) - - method conjecture goal = - let (_, metasenv, _subst, _, _, _) = _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 ~attrs () = - new status ?uri ~typ ~body ~metasenv ~attrs (fun _ -> ()) (fun _ _ -> ()) () - diff --git a/matita/components/tactics/statefulProofEngine.mli b/matita/components/tactics/statefulProofEngine.mli deleted file mode 100644 index 06defd79f..000000000 --- a/matita/components/tactics/statefulProofEngine.mli +++ /dev/null @@ -1,123 +0,0 @@ -(* Copyright (C) 2004, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -(** Stateful handling of proof status *) - -exception No_goal_left -exception Uri_redefinition - -type event = [ `Proof_changed | `Proof_completed ] - -val all_events: event list - - (** from our point of view a status is the status of an incomplete proof, thus - * we have an optional goal which is None if the proof is not yet completed - * (i.e. some goal is still open) *) -type proof_status = ProofEngineTypes.proof * ProofEngineTypes.goal option - - (** Proof observer. First callback argument is Some extended_status - * when a 'real 'change of the proof happened and None when Proof_changed event - * was triggered by a time travel by the means of undo/redo actions or by an - * external "#notify" invocation. Embedded status is the status _before_ the - * current change. Second status is the status reached _after_ the current - * change. *) -type 'a observer = (proof_status * 'a) option -> (proof_status * 'a) -> unit - - (** needed to detach previously attached observers *) -type observer_id - - (** tactic application failed. @see apply_tactic *) -exception Tactic_failure of exn - - (** one or more observers failed. @see apply_tactic *) -exception Observer_failures of (observer_id * exn) list - - (** failure while updating internal data (: 'a). @see apply_tactic *) -exception Data_failure of exn - -(** {2 OO interface} *) - -class ['a] status: - ?history_size:int -> (** default 20 *) - ?uri:UriManager.uri -> - typ:Cic.term -> body:Cic.term Lazy.t -> metasenv:Cic.metasenv -> - attrs:Cic.attribute list -> - (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 Lazy.t - method typ: Cic.term - method attrs: Cic.attribute list - - (** 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 Lazy.t -> metasenv:Cic.metasenv -> - attrs:Cic.attribute list -> - unit -> - unit status - diff --git a/matita/components/tactics/tacticChaser.ml b/matita/components/tactics/tacticChaser.ml deleted file mode 100644 index f7ea9d9e3..000000000 --- a/matita/components/tactics/tacticChaser.ml +++ /dev/null @@ -1,259 +0,0 @@ -(* Copyright (C) 2000-2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(*****************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 18/02/2003 *) -(* *) -(* *) -(*****************************************************************************) - -(* $Id$ *) - -module MQI = MQueryInterpreter -module MQIC = MQIConn -module I = MQueryInterpreter -module U = MQGUtil -module G = MQueryGenerator - - (* search arguments on which Apply tactic doesn't fail *) -let matchConclusion mqi_handle ?(output_html = (fun _ -> ())) ~choose_must() status = - let ((_, metasenv, _, _), metano) = status in - let (_, ey ,ty) = CicUtil.lookup_meta metano metasenv in - let list_of_must, only = CGMatchConclusion.get_constraints metasenv ey ty in -match list_of_must with - [] -> [] -|_ -> - let must = choose_must list_of_must only in - let result = - I.execute mqi_handle - (G.query_of_constraints - (Some CGMatchConclusion.universe) - (must,[],[]) (Some only,None,None)) in - let uris = - List.map - (function uri,_ -> - MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' uri - ) result - in - let uris = - (* TODO ristretto per ragioni di efficienza *) - prerr_endline "STO FILTRANDO"; - List.filter (fun uri -> Pcre.pmatch ~pat:"^cic:/Coq/" uri) uris - in - prerr_endline "HO FILTRATO"; - let uris',exc = - let rec filter_out = - function - [] -> [],"" - | uri::tl -> - let tl',exc = filter_out tl in - try - if - let time = Unix.gettimeofday() in - (try - ignore(ProofEngineTypes.apply_tactic - (PrimitiveTactics.apply_tac - ~term:(MQueryMisc.term_of_cic_textual_parser_uri - (MQueryMisc.cic_textual_parser_uri_of_string uri))) - status); - let time1 = Unix.gettimeofday() in - prerr_endline (Printf.sprintf "%1.3f" (time1 -. time) ); - true - with ProofEngineTypes.Fail _ -> - let time1 = Unix.gettimeofday() in - prerr_endline (Printf.sprintf "%1.3f" (time1 -. time)); false) - then - uri::tl',exc - else - tl',exc - with - (ProofEngineTypes.Fail _) as e -> - let exc' = - "

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

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

Objects that can actually be applied:

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

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

" ^ - "

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

" - in - output_html html' ; - uris' -;; - - -(*matchConclusion modificata per evitare una doppia apply*) -let matchConclusion2 mqi_handle ?(output_html = (fun _ -> ())) ~choose_must() status = - let ((_, metasenv, _, _), metano) = status in - let (_, ey ,ty) = CicUtil.lookup_meta metano metasenv in - let conn = - match mqi_handle.MQIConn.pgc with - MQIConn.MySQL_C conn -> conn - | _ -> assert false in - let uris = Match_concl.cmatch conn ty in - (* List.iter - (fun (n,u) -> prerr_endline ((string_of_int n) ^ " " ^u)) uris; *) - (* delete all .var uris *) - let uris = List.filter UriManager.is_var uris in - (* delete all not "cic:/Coq" uris *) - (* - let uris = - (* TODO ristretto per ragioni di efficienza *) - List.filter (fun _,uri -> Pcre.pmatch ~pat:"^cic:/Coq/" uri) uris in - *) - (* concl_cost are the costants in the conclusion of the proof - while hyp_const are the constants in the hypothesis *) - let (main_concl,concl_const) = NewConstraints.mainandcons ty in - prerr_endline ("Ne sono rimasti" ^ string_of_int (List.length uris)); - let hyp t set = - match t with - Some (_,Cic.Decl t) -> (NewConstraints.StringSet.union set (NewConstraints.constants_concl t)) - | Some (_,Cic.Def (t,_)) -> (NewConstraints.StringSet.union set (NewConstraints.constants_concl t)) - | _ -> set in - let hyp_const = - List.fold_right hyp ey NewConstraints.StringSet.empty in - prerr_endline (NewConstraints.pp_StringSet (NewConstraints.StringSet.union hyp_const concl_const)); - (* uris with new constants in the proof are filtered *) - let all_const = NewConstraints.StringSet.union hyp_const concl_const in - let uris = - if (List.length uris < (Filter_auto.power 2 (List.length (NewConstraints.StringSet.elements all_const)))) - then - (prerr_endline("metodo vecchio");List.filter (Filter_auto.filter_new_constants conn all_const) uris) - else Filter_auto.filter_uris conn all_const uris main_concl in -(* - let uris = - (* ristretto all cache *) - prerr_endline "SOLO CACHE"; - List.filter - (fun uri -> CicEnvironment.in_cache (UriManager.uri_of_string uri)) uris - in - prerr_endline "HO FILTRATO2"; -*) - let uris = - List.map - (fun (n,u) -> - (n,MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' u)) - uris in - let uris' = - let rec filter_out = - function - [] -> [] - | (m,uri)::tl -> - let tl' = filter_out tl in - try - prerr_endline ("STO APPLICANDO " ^ uri); - let res = (m, - (ProofEngineTypes.apply_tactic( PrimitiveTactics.apply_tac - ~term:(MQueryMisc.term_of_cic_textual_parser_uri - (MQueryMisc.cic_textual_parser_uri_of_string uri))) - status))::tl' in - prerr_endline ("OK");res - (* with ProofEngineTypes.Fail _ -> tl' *) - (* patch to cover CSC's exportation bug *) - with _ -> prerr_endline ("FAIL");tl' - in - prerr_endline ("Ne sono rimasti 2 " ^ string_of_int (List.length uris)); - filter_out uris - in - prerr_endline ("Ne sono rimasti 3 " ^ string_of_int (List.length uris')); - - uris' -;; - -(*funzione che sceglie il penultimo livello di profondita' dei must*) - -(* -let choose_must list_of_must only= -let n = (List.length list_of_must) - 1 in - List.nth list_of_must n -;;*) - -(* questa prende solo il main *) -let choose_must list_of_must only = - List.nth list_of_must 0 - -(* livello 1 -let choose_must list_of_must only = - try - List.nth list_of_must 1 - with _ -> - List.nth list_of_must 0 *) - -let searchTheorems mqi_handle (proof,goal) = - let subproofs = - matchConclusion2 mqi_handle ~choose_must() (proof, goal) in - let res = - List.sort - (fun (n1,(_,gl1)) (n2,(_,gl2)) -> - let l1 = List.length gl1 in - let l2 = List.length gl2 in - (* if the list of subgoals have the same lenght we use the - prefix tag, where higher tags have precedence *) - if l1 = l2 then n2 - n1 - else l1 - l2) - subproofs - in - (* now we may drop the prefix tag *) - (*let res' = - List.map snd res in*) - let order_goal_list proof goal1 goal2 = - let _,metasenv,_,_ = proof in - let (_, ey1, ty1) = CicUtil.lookup_meta goal1 metasenv in - let (_, ey2, ty2) = CicUtil.lookup_meta goal2 metasenv in -(* - prerr_endline "PRIMA DELLA PRIMA TYPE OF " ; -*) - let ty_sort1,u = (*TASSI: FIXME *) - CicTypeChecker.type_of_aux' metasenv ey1 ty1 CicUniv.oblivion_ugraph in -(* - prerr_endline (Printf.sprintf "PRIMA DELLA SECONDA TYPE OF %s \n### %s @@@%s " (CicMetaSubst.ppmetasenv metasenv []) (CicMetaSubst.ppcontext [] ey2) (CicMetaSubst.ppterm [] ty2)); -*) - let ty_sort2,u1 = CicTypeChecker.type_of_aux' metasenv ey2 ty2 u in -(* - prerr_endline "DOPO LA SECONDA TYPE OF " ; -*) - let b,u2 = - CicReduction.are_convertible ey1 (Cic.Sort Cic.Prop) ty_sort1 u1 in - let prop1 = if b then 0 else 1 in - let b,_ = CicReduction.are_convertible ey2 (Cic.Sort Cic.Prop) ty_sort2 u2 in - let prop2 = if b then 0 else 1 in - prop1 - prop2 in - List.map ( - fun (level,(proof,goallist)) -> - (proof, (List.stable_sort (order_goal_list proof) goallist)) - ) res -;; - diff --git a/matita/components/tactics/tacticals.ml b/matita/components/tactics/tacticals.ml deleted file mode 100644 index 34ecb2d99..000000000 --- a/matita/components/tactics/tacticals.ml +++ /dev/null @@ -1,307 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -(* open CicReduction -open ProofEngineTypes -open UriManager *) - -(** DEBUGGING *) - - (** perform debugging output? *) -let debug = false -let debug_print = fun _ -> () - - (** debugging print *) -let info s = debug_print (lazy ("TACTICALS INFO: " ^ (Lazy.force s))) - -module PET = ProofEngineTypes - -let id_tac = - let id_tac (proof,goal) = - let _, metasenv, _, _, _, _ = proof in - let _, _, _ = CicUtil.lookup_meta goal metasenv in - (proof,[goal]) - in - PET.mk_tactic id_tac - -let fail_tac = - let fail_tac (proof,goal) = - let _, metasenv, _, _ , _, _ = proof in - let _, _, _ = CicUtil.lookup_meta goal metasenv in - raise (PET.Fail (lazy "fail tactical")) - in - PET.mk_tactic fail_tac - -type goal = PET.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 ProofEngineStatus = -struct - module Stack = Continuationals.Stack - - (* The stack is used and saved only at the very end of the eval function; - it is read only at the beginning of the eval; - we need it just to apply several times in a row this machine to an - initial stack, i.e. to chain several applications of the machine together, - i.e. to dump and restore the state of the machine. - The stack is never used by the tactics: each tactic of type - PET.tactic ignore the stack. To make a tactic from the eval function - of a machine we apply the eval on a fresh stack (via the mk_tactic). *) - type input_status = - PET.status (* (proof, goal) *) * Stack.t - - type output_status = - (PET.proof * goal list * goal list) * Stack.t - - type tactic = PET.tactic - - (* f is an eval function of a machine; - the machine is applied to a fresh stack and the final stack is read - back to obtain the result of the tactic *) - let mk_tactic f = - PET.mk_tactic - (fun ((proof, goal) as pstatus) -> - let stack = [ [ 1, Stack.Open goal ], [], [], `NoTag ] in - let istatus = pstatus, stack in - let (proof, _, _), stack = f istatus in - let opened = Continuationals.Stack.open_goals stack in - proof, opened) - - (* it applies a tactic ignoring (and preserving) the stack *) - let apply_tactic tac ((proof, _) as pstatus, stack) = - let proof', opened = PET.apply_tactic tac pstatus in - let before = PET.goals_of_proof proof in - let after = PET.goals_of_proof proof' in - let opened_goals, closed_goals = goals_diff ~before ~after ~opened in - (proof', opened_goals, closed_goals), stack - - let goals ((_, opened, closed), _) = opened, closed - - (* Done only at the beginning of the eval of the machine *) - let get_stack = snd - (* Done only at the end of the eval of the machine *) - let set_stack stack (opstatus, _) = opstatus, stack - - let inject ((proof, _), stack) = ((proof, [], []), stack) - let focus goal ((proof, _, _), stack) = (proof, goal), stack -end - -module S = ProofEngineStatus -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 - -(* Tacticals implemented on top of tynycals *) - -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))) - -(* Tacticals that cannot be implemented on top of tynycals *) - -let const_tac res = PET.mk_tactic (fun _ -> res) - -let if_ ~start ~continuation ~fail = - let if_ status = - let xoutput = - try - let result = PET.apply_tactic start status in - info (lazy ("Tacticals.if_: succedeed!!!")); - Some result - with PET.Fail _ -> None - in - let tactic = match xoutput with - | Some res -> then_ ~start:(const_tac res) ~continuation - | None -> fail - in - PET.apply_tactic tactic status - in - PET.mk_tactic if_ - -let ifs ~start ~continuations ~fail = - let ifs status = - let xoutput = - try - let result = PET.apply_tactic start status in - info (lazy ("Tacticals.ifs: succedeed!!!")); - Some result - with PET.Fail _ -> None - in - let tactic = match xoutput with - | Some res -> thens ~start:(const_tac res) ~continuations - | None -> fail - in - PET.apply_tactic tactic status - in - PET.mk_tactic ifs - -let first ~tactics = - let rec first ~(tactics: tactic list) status = - info (lazy "in Tacticals.first"); - match tactics with - [] -> raise (PET.Fail (lazy "first: no tactics left")) - | tac::tactics -> - try - let res = PET.apply_tactic tac status in - info (lazy ("Tacticals.first: succedeed!!!")); - res - with - PET.Fail _ -> first ~tactics status - in - PET.mk_tactic (first ~tactics) - -let rec do_tactic ~n ~tactic = - PET.mk_tactic - (function status -> - if n = 0 then - PET.apply_tactic id_tac status - else - PET.apply_tactic - (then_ ~start:tactic ~continuation:(do_tactic ~n:(n-1) ~tactic)) - status) - -(* This applies tactic and catches its possible failure *) -let try_tactic ~tactic = - let try_tactic status = - try - PET.apply_tactic tactic status - with (PET.Fail _) as e -> - info (lazy ( - "Tacticals.try_tactic failed with exn: " ^ Printexc.to_string e)); - PET.apply_tactic id_tac status - in - PET.mk_tactic try_tactic - -let rec repeat_tactic ~tactic = - ProofEngineTypes.mk_tactic - (fun status -> - ProofEngineTypes.apply_tactic - (then_ ~start:tactic - ~continuation:(try_tactic (repeat_tactic ~tactic))) status) - -(* This tries tactics until one of them solves the goal *) -let solve_tactics ~tactics = - let rec solve_tactics ~(tactics: tactic list) status = - info (lazy "in Tacticals.solve_tactics"); - match tactics with - | currenttactic::moretactics -> - (try - let (proof, opened) as output_status = - PET.apply_tactic currenttactic status - in - match opened with - | [] -> info (lazy ("Tacticals.solve_tactics: solved the goal!!!")); - output_status - | _ -> info (lazy ("Tacticals.solve_tactics: try the next tactic")); - raise (PET.Fail (lazy "Goal not solved")) - with (PET.Fail _) as e -> - info (lazy ( - "Tacticals.solve_tactics: current tactic failed with exn: " - ^ Printexc.to_string e)); - solve_tactics ~tactics:moretactics status) - | [] -> - raise (PET.Fail - (lazy "solve_tactics cannot solve the goal")) - in - PET.mk_tactic (solve_tactics ~tactics) - -let progress_tactic ~tactic = - let msg = lazy "Failed to progress" in - let progress_tactic (((_,metasenv,_,_,_,_),g) as istatus) = - let ((_,metasenv',_,_,_,_),opened) as ostatus = - PET.apply_tactic tactic istatus - in - match opened with - | [g1] -> - let _,oc,oldty = CicUtil.lookup_meta g metasenv in - let _,nc,newty = CicUtil.lookup_meta g1 metasenv' in - if oldty = newty && oc = nc then - raise (PET.Fail msg) - else - ostatus - | _ -> ostatus - in - PET.mk_tactic progress_tactic diff --git a/matita/components/tactics/tacticals.mli b/matita/components/tactics/tacticals.mli deleted file mode 100644 index 44a6ab4d9..000000000 --- a/matita/components/tactics/tacticals.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type tactic = ProofEngineTypes.tactic - -val id_tac : tactic -val fail_tac: tactic - -val first: tactics: tactic list -> tactic -val thens: start: tactic -> continuations: tactic list -> tactic -val then_: start: tactic -> continuation: tactic -> tactic -val ifs: start: tactic -> continuations: tactic list -> fail: tactic -> tactic -val if_: start: tactic -> continuation: tactic -> fail: 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: tactic list -> tactic -val progress_tactic: tactic: tactic -> tactic - -(* TODO temporary *) -val goals_diff: - before:ProofEngineTypes.goal list -> - after:ProofEngineTypes.goal list -> - opened:ProofEngineTypes.goal list -> - ProofEngineTypes.goal list * ProofEngineTypes.goal list diff --git a/matita/components/tactics/tactics.ml b/matita/components/tactics/tactics.ml deleted file mode 100644 index 1fb1f8de5..000000000 --- a/matita/components/tactics/tactics.ml +++ /dev/null @@ -1,76 +0,0 @@ -(* Copyright (C) 2004, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -let absurd = NegationTactics.absurd_tac -let apply = PrimitiveTactics.apply_tac -let applyP = PrimitiveTactics.applyP_tac -let applyS = Auto.applyS_tac -let assumption = VariousTactics.assumption_tac -let auto = Auto.auto_tac -let cases_intros = PrimitiveTactics.cases_intros_tac -let change = ReductionTactics.change_tac -let clear = ProofEngineStructuralRules.clear -let clearbody = ProofEngineStructuralRules.clearbody -let constructor = IntroductionTactics.constructor_tac -let contradiction = NegationTactics.contradiction_tac -let cut = PrimitiveTactics.cut_tac -let decompose = EliminationTactics.decompose_tac -let demodulate = Auto.demodulate_tac -let destruct = DestructTactic.destruct_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 = PrimitiveTactics.generalize_tac -let id = Tacticals.id_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 reflexivity = Setoids.setoid_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 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 -let compose = Compose.compose_tac - -(* keep linked *) -let _ = CloseCoercionGraph.close_coercion_graph;; diff --git a/matita/components/tactics/tactics.mli b/matita/components/tactics/tactics.mli deleted file mode 100644 index 4d143fd2a..000000000 --- a/matita/components/tactics/tactics.mli +++ /dev/null @@ -1,111 +0,0 @@ -(* GENERATED FILE, DO NOT EDIT. STAMP:Mon May 18 11:04:27 CEST 2009 *) -val absurd : term:Cic.term -> ProofEngineTypes.tactic -val apply : term:Cic.term -> ProofEngineTypes.tactic -val applyP : term:Cic.term -> ProofEngineTypes.tactic -val applyS : - dbd:HSql.dbd -> - term:Cic.term -> - params:Auto.auto_params -> - automation_cache:AutomationCache.cache -> ProofEngineTypes.tactic -val assumption : ProofEngineTypes.tactic -val auto : - dbd:HSql.dbd -> - params:Auto.auto_params -> - automation_cache:AutomationCache.cache -> ProofEngineTypes.tactic -val cases_intros : - ?howmany:int -> - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?pattern:ProofEngineTypes.lazy_pattern -> - Cic.term -> ProofEngineTypes.tactic -val change : - ?with_cast:bool -> - pattern:ProofEngineTypes.lazy_pattern -> - Cic.lazy_term -> ProofEngineTypes.tactic -val clear : hyps:string list -> ProofEngineTypes.tactic -val clearbody : hyp:string -> 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 decompose : - ?sorts:string list -> - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - unit -> ProofEngineTypes.tactic -val demodulate : - dbd:HSql.dbd -> - params:Auto.auto_params -> - automation_cache:AutomationCache.cache -> ProofEngineTypes.tactic -val destruct : Cic.term list option -> ProofEngineTypes.tactic -val elim_intros : - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?depth:int -> - ?using:Cic.term -> - ?pattern:ProofEngineTypes.lazy_pattern -> - Cic.term -> ProofEngineTypes.tactic -val elim_intros_simpl : - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ?depth:int -> - ?using:Cic.term -> - ?pattern:ProofEngineTypes.lazy_pattern -> - 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 : Tacticals.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:HSql.dbd -> string -> ProofEngineTypes.tactic -val generalize : - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic -val id : Tacticals.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 -> - ?linear:bool -> - ?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 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 -> string list -> ProofEngineTypes.tactic -val rewrite_simpl : - direction:[ `LeftToRight | `RightToLeft ] -> - pattern:ProofEngineTypes.lazy_pattern -> - Cic.term -> string list -> ProofEngineTypes.tactic -val right : ProofEngineTypes.tactic -val ring : 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 -val compose : - ?howmany:int -> - ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> - int -> Cic.term -> Cic.term option -> ProofEngineTypes.tactic diff --git a/matita/components/tactics/universe.ml b/matita/components/tactics/universe.ml deleted file mode 100644 index d20dbda35..000000000 --- a/matita/components/tactics/universe.ml +++ /dev/null @@ -1,187 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -module Codomain = struct - type t = Cic.term - let compare = Pervasives.compare -end -module S = Set.Make(Codomain) -module TI = Discrimination_tree.Make(Cic_indexable.CicIndexable)(S) -type universe = TI.t - -let empty = TI.empty ;; - -let iter u f = - TI.iter u - (fun p s -> f p (S.elements s)) -;; - -let get_candidates univ ty = - S.elements (TI.retrieve_unifiables univ ty) -;; - -let in_universe univ ty = - let candidates = get_candidates univ ty in - List.fold_left - (fun res cand -> - match res with - | Some found -> Some found - | None -> - let candty,_ = - CicTypeChecker.type_of_aux' [] [] cand CicUniv.oblivion_ugraph in - let same ,_ = - CicReduction.are_convertible [] candty ty CicUniv.oblivion_ugraph in - if same then Some cand else None - ) None candidates -;; - -let rec unfold context = function - | Cic.Prod(name,s,t) -> - let t' = unfold ((Some (name,Cic.Decl s))::context) t in - Cic.Prod(name,s,t') - | t -> ProofEngineReduction.unfold context t - -let rec collapse_head_metas t = - match t with - | Cic.Appl([]) -> assert false - | Cic.Appl(a::l) -> - let a' = collapse_head_metas a in - (match a' with - | Cic.Meta(n,m) -> Cic.Meta(n,m) - | t -> - let l' = List.map collapse_head_metas l in - Cic.Appl(t::l')) - | Cic.Rel _ - | Cic.Var _ - | Cic.Meta _ - | Cic.Sort _ - | Cic.Implicit _ - | Cic.Const _ - | Cic.MutInd _ - | Cic.MutConstruct _ -> t - | Cic.LetIn _ - | Cic.Lambda _ - | Cic.Prod _ - | Cic.Cast _ - | Cic.MutCase _ - | Cic.Fix _ - | Cic.CoFix _ -> Cic.Meta(-1,[]) -;; - -let rec dummies_of_coercions = - function - | Cic.Appl (c::l) when CoercDb.is_a_coercion c <> None -> - Cic.Meta (-1,[]) - | Cic.Appl l -> - let l' = List.map dummies_of_coercions l in Cic.Appl l' - | Cic.Lambda(n,s,t) -> - let s' = dummies_of_coercions s in - let t' = dummies_of_coercions t in - Cic.Lambda (n,s',t') - | Cic.Prod(n,s,t) -> - let s' = dummies_of_coercions s in - let t' = dummies_of_coercions t in - Cic.Prod (n,s',t') - | Cic.LetIn(n,s,ty,t) -> - let s' = dummies_of_coercions s in - let ty' = dummies_of_coercions ty in - let t' = dummies_of_coercions t in - Cic.LetIn (n,s',ty',t') - | Cic.MutCase _ -> Cic.Meta (-1,[]) - | t -> t -;; - - -let rec head remove_coercions t = - let clean_up t = - if remove_coercions then dummies_of_coercions t - else t in - let rec aux = function - | Cic.Prod(_,_,t) -> - CicSubstitution.subst (Cic.Meta (-1,[])) (aux t) - | t -> t - in collapse_head_metas (clean_up (aux t)) -;; - - -let index univ key term = - (* flexible terms are not indexed *) - if key = Cic.Meta(-1,[]) then univ - else - ((*prerr_endline("ADD: "^CicPp.ppterm key^" |-> "^CicPp.ppterm term);*) - TI.index univ key term) -;; - -let keys context ty = - try - [head true ty; head true (unfold context ty)] - with ProofEngineTypes.Fail _ -> [head true ty] - -let key term = head false term;; - -let index_term_and_unfolded_term univ context t ty = - let key = head true ty in - let univ = index univ key t in - try - let key = head true (unfold context ty) in - index univ key t - with ProofEngineTypes.Fail _ -> univ -;; - -let index_local_term univ context t ty = - let key = head true ty in - let univ = index univ key t in - let key1 = head false ty in - let univ = - if key<>key1 then index univ key1 t else univ in - try - let key = head true (unfold context ty) in - index univ key t - with ProofEngineTypes.Fail _ -> univ -;; - - -let index_list univ context terms_and_types = - List.fold_left - (fun acc (term,ty) -> - index_term_and_unfolded_term acc context term ty) - univ terms_and_types - -;; - -let remove univ context term ty = - let key = head true ty in - let univ = TI.remove_index univ key term in - try - let key = head true (unfold context ty) in - TI.remove_index univ key term - with ProofEngineTypes.Fail _ -> univ - -let remove_uri univ uri = - let term = CicUtil.term_of_uri uri in - let ty,_ = CicTypeChecker.type_of_aux' [] [] term CicUniv.oblivion_ugraph in - remove univ [] term ty - - diff --git a/matita/components/tactics/universe.mli b/matita/components/tactics/universe.mli deleted file mode 100644 index 5f9d612b5..000000000 --- a/matita/components/tactics/universe.mli +++ /dev/null @@ -1,66 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type universe - -val empty : universe - - -val iter : - universe -> - (UriManager.uri Discrimination_tree.path -> Cic.term list -> unit) -> - unit - -(* retrieves the list of term that hopefully unify *) -val get_candidates: universe -> Cic.term -> Cic.term list - -(* index [univ] [key] [term] *) -val index: universe -> Cic.term -> Cic.term -> universe - -(* collapse non-indexable terms, removing coercions an unfolding the head - * constant if any *) -val keys: Cic.context -> Cic.term -> Cic.term list - -(* collapse non-indexable terms, not removing coercions *) -val key: Cic.term -> Cic.term - -val in_universe: universe -> Cic.term -> Cic.term option - -(* indexes the term and its unfolded both without coercions *) -val index_term_and_unfolded_term: - universe -> Cic.context -> Cic.term -> Cic.term -> universe - -(* indexex the term without coercions, with coercions and unfolded without - * coercions *) -val index_local_term: - universe -> Cic.context -> Cic.term -> Cic.term -> universe - -(* pairs are (term,ty) *) -val index_list: - universe -> Cic.context -> (Cic.term*Cic.term) list -> universe -val remove: - universe -> Cic.context -> Cic.term -> Cic.term -> universe -val remove_uri: - universe -> UriManager.uri -> universe diff --git a/matita/components/tactics/variousTactics.ml b/matita/components/tactics/variousTactics.ml deleted file mode 100644 index fd383cf99..000000000 --- a/matita/components/tactics/variousTactics.ml +++ /dev/null @@ -1,58 +0,0 @@ -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - - -(* TODO se ce n'e' piu' di una, prende la prima che trova... sarebbe meglio -chiedere: find dovrebbe restituire una lista di hyp (?) da passare all'utonto con una -funzione di callback che restituisce la (sola) hyp da applicare *) - -let assumption_tac = - let module PET = ProofEngineTypes in - let assumption_tac status = - let (proof, goal) = status in - let module C = Cic in - let module R = CicReduction in - let module S = CicSubstitution in - let module PT = PrimitiveTactics in - let _,metasenv,_,_,_, _ = proof in - let _,context,ty = CicUtil.lookup_meta goal metasenv in - let rec find n = function - hd::tl -> - (match hd with - (Some (_, C.Decl t)) when - fst (R.are_convertible context (S.lift n t) ty - CicUniv.oblivion_ugraph) -> n - | (Some (_, C.Def (_,ty'))) when - fst (R.are_convertible context (S.lift n ty') ty - CicUniv.oblivion_ugraph) -> n - | _ -> 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 -;; diff --git a/matita/components/tactics/variousTactics.mli b/matita/components/tactics/variousTactics.mli deleted file mode 100644 index 3ce6c47e8..000000000 --- a/matita/components/tactics/variousTactics.mli +++ /dev/null @@ -1,27 +0,0 @@ - -(* Copyright (C) 2002, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -val assumption_tac: ProofEngineTypes.tactic diff --git a/matita/configure.ac b/matita/configure.ac index d33d49f42..69eceb4e4 100644 --- a/matita/configure.ac +++ b/matita/configure.ac @@ -78,10 +78,8 @@ helm-grafite_engine \ helm-ng_disambiguation \ helm-ng_cic_content \ helm-grafite_parser \ -helm-acic_procedural \ helm-content_pres \ helm-hgdome \ -helm-tactics \ helm-ng_paramodulation \ helm-ng_tactics \ helm-cic_exportation \ @@ -209,7 +207,6 @@ AC_OUTPUT([ components/extlib/componentsConf.ml matita/matita.conf.xml matita/buildTimeConf.ml - matita/gtkmathview.matita.conf.xml matita/help/C/version.txt Makefile.defs ]) diff --git a/matita/matita/applyTransformation.ml b/matita/matita/applyTransformation.ml index 700c2e1be..584623e6a 100644 --- a/matita/matita/applyTransformation.ml +++ b/matita/matita/applyTransformation.ml @@ -44,9 +44,7 @@ module G = GrafiteAst module GE = GrafiteEngine module LS = LibrarySync module Ds = CicDischarge -module PO = ProceduralOptimizer module N = CicNotationPt -module A2P = Acic2Procedural let mpres_document pres_box = Xml.add_xml_declaration (CicNotationPres.print_box pres_box) @@ -356,11 +354,7 @@ let txt_of_inline_uri ~map_unicode_to_tex params suri = (* Ds.debug := true; *) - let print_exc = function - | ProofEngineHelpers.Bad_pattern s as e -> - Printexc.to_string e ^ " " ^ Lazy.force s - | e -> Printexc.to_string e - in + let print_exc = Printexc.to_string in let dbd = LibraryDb.instance () in let sorted_uris = MetadataDeps.sorted_uris_of_baseuri ~dbd suri in let error uri e = @@ -418,31 +412,6 @@ let txt_of_inline_macro ~map_unicode_to_tex params name = in txt_of_inline_uri ~map_unicode_to_tex params suri -(****************************************************************************) -(* procedural_txt_of_cic_term *) - -let procedural_txt_of_cic_term ~map_unicode_to_tex n params context term = - let term, _info = PO.optimize_term context term in - let annterm, ids_to_inner_sorts, ids_to_inner_types = - try Cic2acic.acic_term_of_cic_term context term - with e -> - let msg = "procedural_txt_of_cic_term: " ^ Printexc.to_string e in - failwith msg - in - let term_pp = term2pres ~map_unicode_to_tex (n - 8) ids_to_inner_sorts in - let lazy_term_pp = term_pp in - let obj_pp = CicNotationPp.pp_obj term_pp in - let aux = GrafiteAstPp.pp_statement - ~map_unicode_to_tex ~term_pp ~lazy_term_pp ~obj_pp in - let script = - A2P.procedural_of_acic_term - ~ids_to_inner_sorts ~ids_to_inner_types params context annterm - in - String.concat "" (List.map aux script) -;; - -(****************************************************************************) - let txt_of_macro ~map_unicode_to_tex metasenv context m = GrafiteAstPp.pp_macro ~term_pp:(txt_of_cic_term ~map_unicode_to_tex 80 metasenv context) diff --git a/matita/matita/applyTransformation.mli b/matita/matita/applyTransformation.mli index 7e1cfb6fb..1b1b749e7 100644 --- a/matita/matita/applyTransformation.mli +++ b/matita/matita/applyTransformation.mli @@ -124,9 +124,3 @@ val txt_of_macro: Cic.metasenv -> Cic.context -> (Cic.term, Cic.lazy_term) GrafiteAst.macro -> string - -(* columns, rendering depth, context, term *) -val procedural_txt_of_cic_term: - map_unicode_to_tex:bool -> int -> GrafiteAst.inline_param list -> - Cic.context -> Cic.term -> - string diff --git a/matita/matita/gtkmathview.matita.conf.xml.in b/matita/matita/gtkmathview.matita.conf.xml.in deleted file mode 100644 index 5935eaafc..000000000 --- a/matita/matita/gtkmathview.matita.conf.xml.in +++ /dev/null @@ -1,31 +0,0 @@ - - -
- @RT_BASE_DIR@/dictionary-matita.xml -
- - - diff --git a/matita/matita/matita.ml b/matita/matita/matita.ml index 1457862e4..e9909890e 100644 --- a/matita/matita/matita.ml +++ b/matita/matita/matita.ml @@ -93,11 +93,12 @@ let _ = 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 grafite_status incomplete_proof; + match grafite_status#ng_mode with + `ProofMode -> + sequents_viewer#nload_sequents grafite_status; (try - script#setGoal (Some (Continuationals.Stack.find_goal stack)); + script#setGoal + (Some (Continuationals.Stack.find_goal grafite_status#stack)); let goal = match script#goal with None -> assert false @@ -105,24 +106,7 @@ let _ = in sequents_viewer#goto_sequent grafite_status goal with Failure _ -> script#setGoal None); - | Proof proof -> sequents_viewer#load_logo_with_qed - | No_proof -> - (match grafite_status#ng_mode with - `ProofMode -> - sequents_viewer#nload_sequents grafite_status; - (try - script#setGoal - (Some (Continuationals.Stack.find_goal grafite_status#stack)); - let goal = - match script#goal with - None -> assert false - | Some n -> n - in - sequents_viewer#goto_sequent grafite_status goal - with Failure _ -> script#setGoal None); - | `CommandMode -> sequents_viewer#load_logo - ) - | Intermediate _ -> assert false (* only the engine may be in this state *) + | `CommandMode -> sequents_viewer#load_logo in script#addObserver sequents_observer; script#addObserver browser_observer @@ -162,42 +146,6 @@ let _ = (fun x l -> (LexiconAstPp.pp_command x)::l) (filter status.LexiconEngine.lexicon_content_rev) []))); *) - 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 "Print current proof term" - (fun _ -> - HLog.debug - (CicPp.ppterm - (match - (MatitaScript.current ())#grafite_status#proof_status - with - | GrafiteTypes.No_proof -> (Cic.Implicit None) - | Incomplete_proof i -> - let _,_,_subst,p,_, _ = i.GrafiteTypes.proof in - Lazy.force p - | Proof p -> let _,_,_subst,p,_, _ = p in Lazy.force p - | Intermediate _ -> assert false))); - addDebugItem "Print current proof (natural language) to stderr" - (fun _ -> - prerr_endline - (ApplyTransformation.txt_of_cic_object 120 [] - ~map_unicode_to_tex:(Helm_registry.get_bool - "matita.paste_unicode_as_tex") - (match - (MatitaScript.current ())#grafite_status#proof_status - with - | GrafiteTypes.No_proof -> assert false - | Incomplete_proof i -> - let _,m,_subst,p,ty, attrs = i.GrafiteTypes.proof in - Cic.CurrentProof ("current (incomplete) proof",m,Lazy.force p,ty,[],attrs) - | Proof (_,m,_subst,p,ty, attrs) -> - Cic.CurrentProof ("current proof",m,Lazy.force p,ty,[],attrs) - | Intermediate _ -> assert false))); addDebugSeparator (); addDebugCheckbox "high level pretty printer" ~init:true (fun mi () -> CicMetaSubst.use_low_level_ppterm_in_context := mi#active); diff --git a/matita/matita/matitaEngine.ml b/matita/matita/matitaEngine.ml index c96132b8a..03eccc104 100644 --- a/matita/matita/matitaEngine.ml +++ b/matita/matita/matitaEngine.ml @@ -32,12 +32,12 @@ let debug_print = if debug then prerr_endline else ignore ;; let disambiguate_command lexicon_status_ref grafite_status cmd = let baseuri = grafite_status#baseuri in - let lexicon_status,metasenv,cmd = + let lexicon_status,cmd = GrafiteDisambiguate.disambiguate_command ~baseuri - !lexicon_status_ref (GrafiteTypes.get_proof_metasenv grafite_status) cmd + !lexicon_status_ref cmd in lexicon_status_ref := lexicon_status; - GrafiteTypes.set_metasenv metasenv grafite_status,cmd + grafite_status,cmd let eval_macro_screenshot (status : GrafiteTypes.status) name = let _,_,metasenv,subst,_ = status#obj in @@ -70,7 +70,6 @@ let eval_ast ?do_heavy_checks status (text,prefix_len,ast) = status, `Old [] | ast -> GrafiteEngine.eval_ast - ~disambiguate_tactic:((* MATITA 1.0*) fun _ -> assert false) ~disambiguate_command:(disambiguate_command lexicon_status_ref) ~disambiguate_macro:((* MATITA 1.0*) fun _ -> assert false) ?do_heavy_checks status (text,prefix_len,ast) diff --git a/matita/matita/matitaExcPp.ml b/matita/matita/matitaExcPp.ml index 04bdd6a38..260ac2f29 100644 --- a/matita/matita/matitaExcPp.ml +++ b/matita/matita/matitaExcPp.ml @@ -133,10 +133,7 @@ let rec to_string = 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 - | ProofEngineHelpers.Bad_pattern msg -> - None, "Bad pattern: " ^ Lazy.force msg | CicRefine.RefineFailure msg | CicRefine.AssertFailure msg -> None, "Refiner error: " ^ Lazy.force msg diff --git a/matita/matita/matitaGui.ml b/matita/matita/matitaGui.ml index 417a758b7..793a914e0 100644 --- a/matita/matita/matitaGui.ml +++ b/matita/matita/matitaGui.ml @@ -72,12 +72,9 @@ let clean_current_baseuri grafite_status = let save_moo grafite_status = let script = MatitaScript.current () in let baseuri = grafite_status#baseuri in - let no_pstatus = - grafite_status#proof_status = GrafiteTypes.No_proof - in - match script#bos, script#eos, no_pstatus with - | true, _, _ -> () - | _, true, true -> + match script#bos, script#eos with + | true, _ -> () + | _, true -> let moo_fname = LibraryMisc.obj_file_of_baseuri ~must_exist:false ~baseuri ~writable:true in diff --git a/matita/matita/matitaGuiTypes.mli b/matita/matita/matitaGuiTypes.mli index ae0bab1c2..f7df481ae 100644 --- a/matita/matita/matitaGuiTypes.mli +++ b/matita/matita/matitaGuiTypes.mli @@ -143,8 +143,6 @@ object method reset: unit method load_logo: unit method load_logo_with_qed: unit - method load_sequents: - #NCicCoercion.status -> GrafiteTypes.incomplete_proof -> unit method nload_sequents: #NTacStatus.tac_status -> unit method goto_sequent: #NCicCoercion.status -> int -> unit (* to be called _after_ load_sequents *) diff --git a/matita/matita/matitaInit.ml b/matita/matita/matitaInit.ml index 70125f54c..43e76cda1 100644 --- a/matita/matita/matitaInit.ml +++ b/matita/matita/matitaInit.ml @@ -294,7 +294,6 @@ let initialize_environment () = let _ = CicFix.init (); - Inversion_principle.init (); CicRecord.init (); CicElim.init () ;; diff --git a/matita/matita/matitaMathView.ml b/matita/matita/matitaMathView.ml index f11354904..e82a01650 100644 --- a/matita/matita/matitaMathView.ml +++ b/matita/matita/matitaMathView.ml @@ -768,86 +768,6 @@ class sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) () = _metasenv <- `Old []; self#script#setGoal None - method load_sequents : 'status. #NCicCoercion.status as 'status -> 'a - = fun status { proof= (_,metasenv,_subst,_,_, _) as proof; stack = stack } - -> - _metasenv <- `Old 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 - ignore(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, 0 -> `Current (render_switch sw) - | 0, _ -> `Shift (pos, `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 status ~page ~goal_switch)) - method nload_sequents : 'status. #NTacStatus.tac_status as 'status -> unit = fun status -> let _,_,metasenv,subst,_ = status#obj in @@ -1010,7 +930,6 @@ let current_proof_uri = BuildTimeConf.current_proof_uri type term_source = [ `Ast of CicNotationPt.term - | `Cic of Cic.term * Cic.metasenv | `NCic of NCic.term * NCic.context * NCic.metasenv * NCic.substitution | `String of string ] @@ -1295,7 +1214,6 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) | `About `TeX -> self#tex () | `About `Grammar -> self#grammar () | `Check term -> self#_loadCheck term - | `Cic (term, metasenv) -> self#_loadTermCic term metasenv | `NCic (term, ctx, metasenv, subst) -> self#_loadTermNCic term metasenv subst ctx | `Dir dir -> self#_loadDir dir @@ -1394,25 +1312,11 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) method private home () = self#_showMath; - match self#script#grafite_status#proof_status with - | Proof (uri, metasenv, _subst, bo, ty, attrs) -> - let name = UriManager.name_of_uri (HExtlib.unopt uri) in - let obj = - Cic.CurrentProof (name, metasenv, Lazy.force bo, ty, [], attrs) - in - self#_loadObj obj - | Incomplete_proof { proof = (uri, metasenv, _subst, bo, ty, attrs) } -> - let name = UriManager.name_of_uri (HExtlib.unopt uri) in - let obj = - Cic.CurrentProof (name, metasenv, Lazy.force bo, ty, [], attrs) - in - self#_loadObj obj - | _ -> - match self#script#grafite_status#ng_mode with - `ProofMode -> - self#_loadNObj self#script#grafite_status - self#script#grafite_status#obj - | _ -> self#blank () + match self#script#grafite_status#ng_mode with + `ProofMode -> + self#_loadNObj self#script#grafite_status + self#script#grafite_status#obj + | _ -> self#blank () (** loads a cic uri from the environment * @param uri UriManager.uri *) @@ -1472,13 +1376,6 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) self#_showMath; mathView#load_nobject status 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 _loadTermNCic term m s c = let d = 0 in let m = (0,([],c,term))::m in diff --git a/matita/matita/matitaScript.ml b/matita/matita/matitaScript.ml index 552d4907a..9fa039b31 100644 --- a/matita/matita/matitaScript.ml +++ b/matita/matita/matitaScript.ml @@ -128,243 +128,6 @@ let pp_eager_statement_ast = GrafiteAstPp.pp_statement ~term_pp:CicNotationPp.pp_term ~lazy_term_pp:(fun _ -> assert false) ~obj_pp:(fun _ -> assert false) -(* naive implementation of procedural proof script generation, - * starting from an applicatiove *auto generated) proof. - * this is out of place, but I like it :-P *) -let cic2grafite context menv t = - (* indents a proof script in a stupid way, better than nothing *) - let stupid_indenter s = - let next s = - let idx_square_o = try String.index s '[' with Not_found -> -1 in - let idx_square_c = try String.index s ']' with Not_found -> -1 in - let idx_pipe = try String.index s '|' with Not_found -> -1 in - let tok = - List.sort (fun (i,_) (j,_) -> compare i j) - [idx_square_o,'[';idx_square_c,']';idx_pipe,'|'] - in - let tok = List.filter (fun (i,_) -> i <> -1) tok in - match tok with - | (i,c)::_ -> Some (i,c) - | _ -> None - in - let break_apply n s = - let tab = String.make (n+1) ' ' in - Pcre.replace ~templ:(".\n" ^ tab ^ "apply") ~pat:"\\.apply" s - in - let rec ind n s = - match next s with - | None -> - s - | Some (position, char) -> - try - let s1, s2 = - String.sub s 0 position, - String.sub s (position+1) (String.length s - (position+1)) - in - match char with - | '[' -> break_apply n s1 ^ "\n" ^ String.make (n+2) ' ' ^ - "[" ^ ind (n+2) s2 - | '|' -> break_apply n s1 ^ "\n" ^ String.make n ' ' ^ - "|" ^ ind n s2 - | ']' -> break_apply n s1 ^ "\n" ^ String.make n ' ' ^ - "]" ^ ind (n-2) s2 - | _ -> assert false - with - Invalid_argument err -> - prerr_endline err; - s - in - ind 0 s - in - let module PT = CicNotationPt in - let module GA = GrafiteAst in - let pp_t context t = - let names = - List.map (function Some (n,_) -> Some n | None -> None) context - in - CicPp.pp t names - in - let sort_of context t = - try - let ty,_ = - CicTypeChecker.type_of_aux' menv context t - CicUniv.oblivion_ugraph - in - let sort,_ = CicTypeChecker.type_of_aux' menv context ty - CicUniv.oblivion_ugraph - in - match sort with - | Cic.Sort Cic.Prop -> true - | _ -> false - with - CicTypeChecker.TypeCheckerFailure _ -> - HLog.error "auto proof to sript transformation error"; false - in - let floc = HExtlib.dummy_floc in - (* minimalisti cic.term -> pt.term *) - let print_term c t = - let rec aux c = function - | Cic.Rel _ - | Cic.MutConstruct _ - | Cic.MutInd _ - | Cic.Const _ as t -> - PT.Ident (pp_t c t, None) - | Cic.Appl l -> PT.Appl (List.map (aux c) l) - | Cic.Implicit _ -> PT.Implicit `JustOne - | Cic.Lambda (Cic.Name n, s, t) -> - PT.Binder (`Lambda, (PT.Ident (n,None), Some (aux c s)), - aux (Some (Cic.Name n, Cic.Decl s)::c) t) - | Cic.Prod (Cic.Name n, s, t) -> - PT.Binder (`Forall, (PT.Ident (n,None), Some (aux c s)), - aux (Some (Cic.Name n, Cic.Decl s)::c) t) - | Cic.LetIn (Cic.Name n, s, ty, t) -> - PT.Binder (`Lambda, (PT.Ident (n,None), Some (aux c s)), - aux (Some (Cic.Name n, Cic.Def (s,ty))::c) t) - | Cic.Meta _ -> PT.Implicit `JustOne - | Cic.Sort (Cic.Type u) -> PT.Sort (`Type u) - | Cic.Sort Cic.Set -> PT.Sort `Set - | Cic.Sort (Cic.CProp u) -> PT.Sort (`CProp u) - | Cic.Sort Cic.Prop -> PT.Sort `Prop - | _ as t -> PT.Ident ("ERROR: "^CicPp.ppterm t, None) - in - aux c t - in - (* prints an applicative proof, that is an auto proof. - * don't use in the general case! *) - let rec print_proof context = function - | Cic.Rel _ - | Cic.Const _ as t -> - [GA.Executable (floc, - GA.Tactic (floc, - Some (GA.Apply (floc, print_term context t)), GA.Dot floc))] - | Cic.Appl (he::tl) -> - let tl = List.map (fun t -> t, sort_of context t) tl in - let subgoals = - HExtlib.filter_map (function (t,true) -> Some t | _ -> None) tl - in - let args = - List.map (function | (t,true) -> Cic.Implicit None | (t,_) -> t) tl - in - if List.length subgoals > 1 then - (* branch *) - [GA.Executable (floc, - GA.Tactic (floc, - Some (GA.Apply (floc, print_term context (Cic.Appl (he::args)))), - GA.Semicolon floc))] @ - [GA.Executable (floc, GA.Tactic (floc, None, GA.Branch floc))] @ - (HExtlib.list_concat - ~sep:[GA.Executable (floc, GA.Tactic (floc, None,GA.Shift floc))] - (List.map (print_proof context) subgoals)) @ - [GA.Executable (floc, GA.Tactic (floc, None,GA.Merge floc))] - else - (* simple apply *) - [GA.Executable (floc, - GA.Tactic (floc, - Some (GA.Apply - (floc, print_term context (Cic.Appl (he::args)) )), GA.Dot floc))] - @ - (match subgoals with - | [] -> [] - | [x] -> print_proof context x - | _ -> assert false) - | Cic.Lambda (Cic.Name n, ty, bo) -> - [GA.Executable (floc, - GA.Tactic (floc, - Some (GA.Cut (floc, Some n, (print_term context ty))), - GA.Branch floc))] @ - (print_proof (Some (Cic.Name n, Cic.Decl ty)::context) bo) @ - [GA.Executable (floc, GA.Tactic (floc, None,GA.Shift floc))] @ - [GA.Executable (floc, GA.Tactic (floc, - Some (GA.Assumption floc),GA.Merge floc))] - | _ -> [] - (* - debug_print (lazy (CicPp.ppterm t)); - assert false - *) - in - (* performs a lambda closure of the proof term abstracting metas. - * this is really an approximation of a closure, local subst of metas - * is not kept into account *) - let close_pt menv context t = - let metas = CicUtil.metas_of_term t in - let metas = - HExtlib.list_uniq ~eq:(fun (i,_) (j,_) -> i = j) - (List.sort (fun (i,_) (j,_) -> compare i j) metas) - in - let mk_rels_and_collapse_metas metas = - let rec aux i map acc acc1 = function - | [] -> acc, acc1, map - | (j,_ as m)::tl -> - let _,_,ty = CicUtil.lookup_meta j menv in - try - let n = List.assoc ty map in - aux i map (Cic.Rel n :: acc) (m::acc1) tl - with Not_found -> - let map = (ty, i)::map in - aux (i+1) map (Cic.Rel i :: acc) (m::acc1) tl - in - aux 1 [] [] [] metas - in - let rels, metas, map = mk_rels_and_collapse_metas metas in - let n_lambdas = List.length map in - let t = - if metas = [] then - t - else - let t = - ProofEngineReduction.replace_lifting - ~what:(List.map (fun (x,_) -> Cic.Meta (x,[])) metas) - ~with_what:rels - ~context:context - ~equality:(fun _ x y -> - match x,y with - | Cic.Meta(i,_), Cic.Meta(j,_) when i=j -> true - | _ -> false) - ~where:(CicSubstitution.lift n_lambdas t) - in - let rec mk_lam = function - | [] -> t - | (ty,n)::tl -> - let name = "fresh_"^ string_of_int n in - Cic.Lambda (Cic.Name name, ty, mk_lam tl) - in - mk_lam - (fst (List.fold_left - (fun (l,liftno) (ty,_) -> - (l @ [CicSubstitution.lift liftno ty,liftno] , liftno+1)) - ([],0) map)) - in - t - in - let ast = print_proof context (close_pt menv context t) in - let pp t = - (* ZACK: setting width to 80 will trigger a bug of BoxPp.render_to_string - * which will show up using the following command line: - * ./tptp2grafite -tptppath ~tassi/TPTP-v3.1.1 GRP170-1 *) - let width = max_int in - let term_pp content_term = - let pres_term = TermContentPres.pp_ast content_term in - let lookup_uri = fun _ -> None in - let markup = CicNotationPres.render ~lookup_uri pres_term in - let s = "(" ^ BoxPp.render_to_string - ~map_unicode_to_tex:(Helm_registry.get_bool - "matita.paste_unicode_as_tex") - List.hd width markup ^ ")" in - Pcre.substitute - ~pat:"\\\\forall [Ha-z][a-z0-9_]*" ~subst:(fun x -> "\n" ^ x) s - in - CicNotationPp.set_pp_term term_pp; - let lazy_term_pp = fun x -> assert false in - let obj_pp = CicNotationPp.pp_obj CicNotationPp.pp_term in - GrafiteAstPp.pp_statement - ~map_unicode_to_tex:(Helm_registry.get_bool - "matita.paste_unicode_as_tex") - ~term_pp ~lazy_term_pp ~obj_pp t - in - let script = String.concat "" (List.map pp ast) in - prerr_endline script; - stupid_indenter script -;; let eval_nmacro include_paths (buffer : GText.buffer) guistuff grafite_status user_goal unparsed_text parsed_text script mac = let parsed_text_length = String.length parsed_text in match mac with @@ -428,7 +191,6 @@ let eval_nmacro include_paths (buffer : GText.buffer) guistuff grafite_status us | TA.NAutoInteractive (_, (Some _,_)) -> assert false let rec eval_macro include_paths (buffer : GText.buffer) guistuff grafite_status user_goal unparsed_text parsed_text script mac = - let module MQ = MetadataQuery in let module CTC = CicTypeChecker in (* no idea why ocaml wants this *) let parsed_text_length = String.length parsed_text in @@ -436,7 +198,7 @@ let rec eval_macro include_paths (buffer : GText.buffer) guistuff grafite_status match mac with (* REAL macro *) | TA.Hint (loc, rewrite) -> (* MATITA 1.0 *) assert false - | TA.Eval (_, kind, term) -> + | TA.Eval (_, kind, term) -> assert false (* MATITA 1.0 let metasenv = GrafiteTypes.get_proof_metasenv grafite_status in let context = match user_goal with @@ -461,88 +223,7 @@ let rec eval_macro include_paths (buffer : GText.buffer) guistuff grafite_status let t_and_ty = Cic.Cast (term,ty) in guistuff.mathviewer#show_entry (`Cic (t_and_ty,metasenv)); [(grafite_status#set_proof_status No_proof), parsed_text ],"", - parsed_text_length - | 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 - | TA.AutoInteractive (_, params) -> - 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 - (try - let _,menv,_,_,_,_ = proof in - let i,cc,ty = CicUtil.lookup_meta user_goal' menv in - let timestamp = Unix.gettimeofday () in - let (_,menv,subst,_,_,_), _ = - ProofEngineTypes.apply_tactic - (Auto.auto_tac ~dbd ~params - ~automation_cache:grafite_status#automation_cache) - proof_status - in - let proof_term = - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable cc - in - CicMetaSubst.apply_subst subst (Cic.Meta (i,irl)) - in - let time = Unix.gettimeofday () -. timestamp in - let size, depth = Auto.size_and_depth cc menv proof_term in - let trailer = - Printf.sprintf - "\n(* end auto(%s) proof: TIME=%4.2f SIZE=%d DEPTH=%d *)" - Auto.revision time size depth - in - let proof_script = - if List.exists (fun (s,_) -> s = "paramodulation") (snd params) then - let proof_term, how_many_lambdas = - Auto.lambda_close ~prefix_name:"orrible_hack_" - proof_term menv cc - in - let ty,_ = - CicTypeChecker.type_of_aux' - [] [] proof_term CicUniv.empty_ugraph - in - prerr_endline (CicPp.ppterm proof_term ^ " n lambda= " ^ string_of_int how_many_lambdas); - (* use declarative output *) - let obj = - (* il proof_term vive in cc, devo metterci i lambda no? *) - (Cic.CurrentProof ("xxx",[],proof_term,ty,[],[])) - in - ApplyTransformation.txt_of_cic_object - ~map_unicode_to_tex:(Helm_registry.get_bool - "matita.paste_unicode_as_tex") - ~skip_thm_and_qed:true - ~skip_initial_lambdas:how_many_lambdas - 80 [] obj - else - if true then - (* use cic2grafite *) - cic2grafite cc menv proof_term - else - (* alternative using FG stuff *) - let map_unicode_to_tex = - Helm_registry.get_bool "matita.paste_unicode_as_tex" - in - ApplyTransformation.procedural_txt_of_cic_term - ~map_unicode_to_tex 78 [] cc proof_term - in - let text = comment parsed_text ^ "\n" ^ proof_script ^ trailer in - [],text,parsed_text_length - with - ProofEngineTypes.Fail _ as exn -> - raise exn - (* [], comment parsed_text ^ "\nfail.\n", parsed_text_length *)) + parsed_text_length *) | TA.Inline (_, suri, params) -> let str = "\n\n" ^ ApplyTransformation.txt_of_inline_macro @@ -566,10 +247,7 @@ script ex loc 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 context = [] in let grafite_status,macro = lazy_macro context in eval_macro include_paths buffer guistuff grafite_status user_goal unparsed_text (skipped_txt ^ nonskipped_txt) script macro @@ -737,7 +415,7 @@ object (self) * 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 + val mutable userGoal = (None : int option) (** text mark and tag representing locked part of a script *) val locked_mark = @@ -791,12 +469,7 @@ object (self) buffer#insert ~iter:(buffer#get_iter_at_mark (`MARK locked_mark)) newtext; (* 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 + userGoal <- None method private _retract offset grafite_status new_statements new_history @@ -1063,27 +736,8 @@ object (self) with Invalid_argument "Array.make" -> HLog.error "The script is too big!\n" - 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 stack = (assert false : Continuationals.Stack.t) (* MATITA 1.0 GrafiteTypes.get_stack + self#grafite_status *) method setGoal n = userGoal <- n method goal = userGoal diff --git a/matita/matita/matitaScript.mli b/matita/matita/matitaScript.mli index e1369617d..85c4e767a 100644 --- a/matita/matita/matitaScript.mli +++ b/matita/matita/matitaScript.mli @@ -63,12 +63,6 @@ object (** {2 Current proof} (if any) *) - (** @return true if there is an ongoing proof, false otherise *) - method onGoingProof: unit -> bool - - 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 diff --git a/matita/matita/matitaTypes.ml b/matita/matita/matitaTypes.ml index e295b9c0f..854bbca16 100644 --- a/matita/matita/matitaTypes.ml +++ b/matita/matita/matitaTypes.ml @@ -45,7 +45,6 @@ type abouts = type mathViewer_entry = [ `About of abouts (* current proof *) | `Check of string (* term *) - | `Cic of Cic.term * Cic.metasenv | `NCic of NCic.term * NCic.context * NCic.metasenv * NCic.substitution | `Dir of string (* "directory" in cic uris namespace *) | `Uri of UriManager.uri (* cic object uri *) @@ -63,7 +62,6 @@ let string_of_entry = function | `About `Grammar -> "about:grammar" | `About `Hints -> "about:hints" | `Check _ -> "check:" - | `Cic (_, _) -> "term:" | `NCic (_, _, _, _) -> "nterm:" | `Dir uri -> uri | `Uri uri -> UriManager.string_of_uri uri diff --git a/matita/matita/matitaTypes.mli b/matita/matita/matitaTypes.mli index ec3048f67..9cb7ac984 100644 --- a/matita/matita/matitaTypes.mli +++ b/matita/matita/matitaTypes.mli @@ -31,7 +31,6 @@ type abouts = [ `Blank | `Current_proof | `Us | `Coercions type mathViewer_entry = [ `About of abouts | `Check of string - | `Cic of Cic.term * Cic.metasenv | `NCic of NCic.term * NCic.context * NCic.metasenv * NCic.substitution | `Dir of string | `Uri of UriManager.uri diff --git a/matita/matita/matitacLib.ml b/matita/matita/matitacLib.ml index 0b8b58c0d..7869482ba 100644 --- a/matita/matita/matitacLib.ml +++ b/matita/matita/matitacLib.ml @@ -98,13 +98,7 @@ let dump f = end ;; -let get_macro_context = function - | Some status when status#proof_status = GrafiteTypes.No_proof -> [] - | Some status -> - let stack = GrafiteTypes.get_stack status in - let goal = Continuationals.Stack.find_goal stack in - GrafiteTypes.get_proof_context status goal - | None -> assert false +let get_macro_context = function _ -> [] ;; let pp_times fname rc big_bang big_bang_u big_bang_s = @@ -256,20 +250,10 @@ let compile atstart options fname = aux_for_dump print_cb grafite_status in let elapsed = Unix.time () -. time in - let proof_status,moo_content_rev,lexicon_content_rev = - grafite_status#proof_status, grafite_status#moo_content_rev, + let moo_content_rev,lexicon_content_rev = + grafite_status#moo_content_rev, grafite_status#lstatus.LexiconEngine.lexicon_content_rev in - if proof_status <> GrafiteTypes.No_proof then - (HLog.error - "there are still incomplete proofs at the end of the script"; - pp_times fname false big_bang big_bang_u big_bang_s; -(* - LexiconSync.time_travel - ~present:lexicon_status ~past:initial_lexicon_status; -*) - clean_exit baseuri false) - else (if Helm_registry.get_bool "matita.moo" then begin (* FG: we do not generate .moo when dumping .mma files *) GrafiteMarshal.save_moo moo_fname moo_content_rev; -- 2.39.2