From 5b7eafd0f00a16d78f99a27f5c7d5a0de77dc7e6 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Wed, 21 Jul 2010 09:46:51 +0200 Subject: Imported Upstream snapshot 8.3~beta0+13298 --- plugins/cc/README | 20 + plugins/cc/cc_plugin.mllib | 5 + plugins/cc/ccalgo.ml | 884 +++++++ plugins/cc/ccalgo.mli | 222 ++ plugins/cc/ccproof.ml | 153 ++ plugins/cc/ccproof.mli | 31 + plugins/cc/cctac.ml | 465 ++++ plugins/cc/cctac.mli | 22 + plugins/cc/g_congruence.ml4 | 29 + plugins/dp/Dp.v | 120 + plugins/dp/TODO | 24 + plugins/dp/dp.ml | 1134 ++++++++ plugins/dp/dp.mli | 20 + plugins/dp/dp_plugin.mllib | 5 + plugins/dp/dp_why.ml | 186 ++ plugins/dp/dp_why.mli | 17 + plugins/dp/dp_zenon.mli | 7 + plugins/dp/dp_zenon.mll | 189 ++ plugins/dp/fol.mli | 58 + plugins/dp/g_dp.ml4 | 79 + plugins/dp/test2.v | 80 + plugins/dp/tests.v | 300 +++ plugins/dp/vo.itarget | 1 + plugins/dp/zenon.v | 94 + plugins/extraction/CHANGES | 414 +++ plugins/extraction/ExtrOcamlBasic.v | 33 + plugins/extraction/ExtrOcamlBigIntConv.v | 108 + plugins/extraction/ExtrOcamlIntConv.v | 97 + plugins/extraction/ExtrOcamlNatBigInt.v | 69 + plugins/extraction/ExtrOcamlNatInt.v | 75 + plugins/extraction/ExtrOcamlString.v | 38 + plugins/extraction/ExtrOcamlZBigInt.v | 85 + plugins/extraction/ExtrOcamlZInt.v | 78 + plugins/extraction/README | 147 ++ plugins/extraction/big.ml | 154 ++ plugins/extraction/common.ml | 535 ++++ plugins/extraction/common.mli | 59 + plugins/extraction/extract_env.ml | 540 ++++ plugins/extraction/extract_env.mli | 23 + plugins/extraction/extraction.ml | 982 +++++++ plugins/extraction/extraction.mli | 34 + plugins/extraction/extraction_plugin.mllib | 11 + plugins/extraction/g_extraction.ml4 | 142 + plugins/extraction/haskell.ml | 357 +++ plugins/extraction/haskell.mli | 12 + plugins/extraction/miniml.mli | 201 ++ plugins/extraction/mlutil.ml | 1293 +++++++++ plugins/extraction/mlutil.mli | 131 + plugins/extraction/modutil.ml | 375 +++ plugins/extraction/modutil.mli | 41 + plugins/extraction/ocaml.ml | 759 ++++++ plugins/extraction/ocaml.mli | 12 + plugins/extraction/scheme.ml | 215 ++ plugins/extraction/scheme.mli | 11 + plugins/extraction/table.ml | 767 ++++++ plugins/extraction/table.mli | 167 ++ plugins/extraction/vo.itarget | 8 + plugins/field/LegacyField.v | 16 + plugins/field/LegacyField_Compl.v | 38 + plugins/field/LegacyField_Tactic.v | 433 +++ plugins/field/LegacyField_Theory.v | 650 +++++ plugins/field/field.ml4 | 191 ++ plugins/field/field_plugin.mllib | 2 + plugins/field/vo.itarget | 4 + plugins/firstorder/formula.ml | 270 ++ plugins/firstorder/formula.mli | 77 + plugins/firstorder/g_ground.ml4 | 148 ++ plugins/firstorder/ground.ml | 152 ++ plugins/firstorder/ground.mli | 13 + plugins/firstorder/ground_plugin.mllib | 8 + plugins/firstorder/instances.ml | 206 ++ plugins/firstorder/instances.mli | 26 + plugins/firstorder/rules.ml | 215 ++ plugins/firstorder/rules.mli | 54 + plugins/firstorder/sequent.ml | 312 +++ plugins/firstorder/sequent.mli | 66 + plugins/firstorder/unify.ml | 143 + plugins/firstorder/unify.mli | 23 + plugins/fourier/Fourier.v | 21 + plugins/fourier/Fourier_util.v | 222 ++ plugins/fourier/fourier.ml | 205 ++ plugins/fourier/fourierR.ml | 629 +++++ plugins/fourier/fourier_plugin.mllib | 4 + plugins/fourier/g_fourier.ml4 | 17 + plugins/fourier/vo.itarget | 2 + plugins/funind/Recdef.v | 48 + plugins/funind/functional_principles_proofs.ml | 1710 ++++++++++++ plugins/funind/functional_principles_proofs.mli | 19 + plugins/funind/functional_principles_types.ml | 737 ++++++ plugins/funind/functional_principles_types.mli | 34 + plugins/funind/g_indfun.ml4 | 524 ++++ plugins/funind/indfun.ml | 776 ++++++ plugins/funind/indfun_common.ml | 558 ++++ plugins/funind/indfun_common.mli | 121 + plugins/funind/invfun.ml | 1020 +++++++ plugins/funind/merge.ml | 1032 ++++++++ plugins/funind/rawterm_to_relation.ml | 1419 ++++++++++ plugins/funind/rawterm_to_relation.mli | 16 + plugins/funind/rawtermops.ml | 718 +++++ plugins/funind/rawtermops.mli | 126 + plugins/funind/recdef.ml | 1473 +++++++++++ plugins/funind/recdef_plugin.mllib | 11 + plugins/funind/vo.itarget | 1 + plugins/micromega/CheckerMaker.v | 129 + plugins/micromega/Env.v | 182 ++ plugins/micromega/EnvRing.v | 1403 ++++++++++ plugins/micromega/LICENSE.sos | 29 + plugins/micromega/MExtraction.v | 48 + plugins/micromega/OrderedRing.v | 458 ++++ plugins/micromega/Psatz.v | 86 + plugins/micromega/QMicromega.v | 197 ++ plugins/micromega/RMicromega.v | 182 ++ plugins/micromega/Refl.v | 130 + plugins/micromega/RingMicromega.v | 884 +++++++ plugins/micromega/Tauto.v | 327 +++ plugins/micromega/VarMap.v | 259 ++ plugins/micromega/ZCoeff.v | 173 ++ plugins/micromega/ZMicromega.v | 1023 +++++++ plugins/micromega/certificate.ml | 813 ++++++ plugins/micromega/coq_micromega.ml | 1710 ++++++++++++ plugins/micromega/csdpcert.ml | 214 ++ plugins/micromega/g_micromega.ml4 | 76 + plugins/micromega/mfourier.ml | 1012 +++++++ plugins/micromega/micromega.ml | 1703 ++++++++++++ plugins/micromega/micromega.mli | 442 ++++ plugins/micromega/micromega_plugin.mllib | 9 + plugins/micromega/mutils.ml | 402 +++ plugins/micromega/persistent_cache.ml | 180 ++ plugins/micromega/sos.ml | 1859 +++++++++++++ plugins/micromega/sos.mli | 36 + plugins/micromega/sos_lib.ml | 621 +++++ plugins/micromega/sos_types.ml | 68 + plugins/micromega/vo.itarget | 13 + plugins/nsatz/NsatzR.v | 407 +++ plugins/nsatz/NsatzZ.v | 73 + plugins/nsatz/Nsatz_domain.v | 558 ++++ plugins/nsatz/ideal.ml | 1057 ++++++++ plugins/nsatz/nsatz.ml4 | 608 +++++ plugins/nsatz/nsatz_plugin.mllib | 5 + plugins/nsatz/polynom.ml | 679 +++++ plugins/nsatz/polynom.mli | 97 + plugins/nsatz/utile.ml | 130 + plugins/nsatz/utile.mli | 22 + plugins/nsatz/vo.itarget | 3 + plugins/omega/Omega.v | 59 + plugins/omega/OmegaLemmas.v | 302 +++ plugins/omega/OmegaPlugin.v | 11 + plugins/omega/PreOmega.v | 445 ++++ plugins/omega/coq_omega.ml | 1823 +++++++++++++ plugins/omega/g_omega.ml4 | 47 + plugins/omega/omega.ml | 716 +++++ plugins/omega/omega_plugin.mllib | 4 + plugins/omega/vo.itarget | 4 + plugins/plugins.itarget | 3 + plugins/pluginsbyte.itarget | 23 + plugins/pluginsdyn.itarget | 23 + plugins/pluginsopt.itarget | 23 + plugins/pluginsvo.itarget | 13 + plugins/quote/Quote.v | 87 + plugins/quote/g_quote.ml4 | 31 + plugins/quote/quote.ml | 504 ++++ plugins/quote/quote_plugin.mllib | 3 + plugins/quote/vo.itarget | 1 + plugins/ring/LegacyArithRing.v | 90 + plugins/ring/LegacyNArithRing.v | 46 + plugins/ring/LegacyRing.v | 37 + plugins/ring/LegacyRing_theory.v | 376 +++ plugins/ring/LegacyZArithRing.v | 37 + plugins/ring/Ring_abstract.v | 706 +++++ plugins/ring/Ring_normalize.v | 902 +++++++ plugins/ring/Setoid_ring.v | 14 + plugins/ring/Setoid_ring_normalize.v | 1165 ++++++++ plugins/ring/Setoid_ring_theory.v | 427 +++ plugins/ring/g_ring.ml4 | 136 + plugins/ring/ring.ml | 924 +++++++ plugins/ring/ring_plugin.mllib | 3 + plugins/ring/vo.itarget | 10 + plugins/romega/README | 6 + plugins/romega/ROmega.v | 14 + plugins/romega/ReflOmegaCore.v | 3216 +++++++++++++++++++++++ plugins/romega/const_omega.ml | 352 +++ plugins/romega/const_omega.mli | 176 ++ plugins/romega/g_romega.ml4 | 42 + plugins/romega/refl_omega.ml | 1299 +++++++++ plugins/romega/romega_plugin.mllib | 4 + plugins/romega/vo.itarget | 2 + plugins/rtauto/Bintree.v | 489 ++++ plugins/rtauto/Rtauto.v | 400 +++ plugins/rtauto/g_rtauto.ml4 | 16 + plugins/rtauto/proof_search.ml | 546 ++++ plugins/rtauto/proof_search.mli | 49 + plugins/rtauto/refl_tauto.ml | 337 +++ plugins/rtauto/refl_tauto.mli | 26 + plugins/rtauto/rtauto_plugin.mllib | 4 + plugins/rtauto/vo.itarget | 2 + plugins/setoid_ring/ArithRing.v | 60 + plugins/setoid_ring/BinList.v | 93 + plugins/setoid_ring/Field.v | 10 + plugins/setoid_ring/Field_tac.v | 571 ++++ plugins/setoid_ring/Field_theory.v | 1946 ++++++++++++++ plugins/setoid_ring/InitialRing.v | 908 +++++++ plugins/setoid_ring/NArithRing.v | 21 + plugins/setoid_ring/RealField.v | 134 + plugins/setoid_ring/Ring.v | 44 + plugins/setoid_ring/Ring_base.v | 17 + plugins/setoid_ring/Ring_equiv.v | 74 + plugins/setoid_ring/Ring_polynom.v | 1781 +++++++++++++ plugins/setoid_ring/Ring_tac.v | 434 +++ plugins/setoid_ring/Ring_theory.v | 608 +++++ plugins/setoid_ring/ZArithRing.v | 60 + plugins/setoid_ring/newring.ml4 | 1164 ++++++++ plugins/setoid_ring/newring_plugin.mllib | 2 + plugins/setoid_ring/vo.itarget | 15 + plugins/subtac/eterm.ml | 233 ++ plugins/subtac/eterm.mli | 34 + plugins/subtac/g_subtac.ml4 | 177 ++ plugins/subtac/subtac.ml | 250 ++ plugins/subtac/subtac.mli | 2 + plugins/subtac/subtac_cases.ml | 2027 ++++++++++++++ plugins/subtac/subtac_cases.mli | 23 + plugins/subtac/subtac_classes.ml | 182 ++ plugins/subtac/subtac_classes.mli | 41 + plugins/subtac/subtac_coercion.ml | 503 ++++ plugins/subtac/subtac_coercion.mli | 4 + plugins/subtac/subtac_command.ml | 534 ++++ plugins/subtac/subtac_command.mli | 60 + plugins/subtac/subtac_errors.ml | 24 + plugins/subtac/subtac_errors.mli | 15 + plugins/subtac/subtac_obligations.ml | 652 +++++ plugins/subtac/subtac_obligations.mli | 69 + plugins/subtac/subtac_plugin.mllib | 13 + plugins/subtac/subtac_pretyping.ml | 137 + plugins/subtac/subtac_pretyping.mli | 23 + plugins/subtac/subtac_pretyping_F.ml | 645 +++++ plugins/subtac/subtac_utils.ml | 484 ++++ plugins/subtac/subtac_utils.mli | 136 + plugins/subtac/test/ListDep.v | 49 + plugins/subtac/test/ListsTest.v | 99 + plugins/subtac/test/Mutind.v | 20 + plugins/subtac/test/Test1.v | 16 + plugins/subtac/test/euclid.v | 24 + plugins/subtac/test/id.v | 46 + plugins/subtac/test/measure.v | 20 + plugins/subtac/test/rec.v | 65 + plugins/subtac/test/take.v | 34 + plugins/subtac/test/wf.v | 48 + plugins/syntax/ascii_syntax.ml | 83 + plugins/syntax/ascii_syntax_plugin.mllib | 2 + plugins/syntax/nat_syntax.ml | 78 + plugins/syntax/nat_syntax_plugin.mllib | 2 + plugins/syntax/numbers_syntax.ml | 330 +++ plugins/syntax/numbers_syntax_plugin.mllib | 2 + plugins/syntax/r_syntax.ml | 125 + plugins/syntax/r_syntax_plugin.mllib | 2 + plugins/syntax/string_syntax.ml | 69 + plugins/syntax/string_syntax_plugin.mllib | 2 + plugins/syntax/z_syntax.ml | 194 ++ plugins/syntax/z_syntax_plugin.mllib | 2 + plugins/xml/COPYRIGHT | 25 + plugins/xml/README | 254 ++ plugins/xml/acic.ml | 108 + plugins/xml/acic2Xml.ml4 | 363 +++ plugins/xml/cic.dtd | 259 ++ plugins/xml/cic2Xml.ml | 17 + plugins/xml/cic2acic.ml | 942 +++++++ plugins/xml/doubleTypeInference.ml | 272 ++ plugins/xml/doubleTypeInference.mli | 24 + plugins/xml/dumptree.ml4 | 152 ++ plugins/xml/proof2aproof.ml | 176 ++ plugins/xml/proofTree2Xml.ml4 | 210 ++ plugins/xml/theoryobject.dtd | 62 + plugins/xml/unshare.ml | 52 + plugins/xml/unshare.mli | 21 + plugins/xml/xml.ml4 | 78 + plugins/xml/xml.mli | 40 + plugins/xml/xml_plugin.mllib | 13 + plugins/xml/xmlcommand.ml | 719 +++++ plugins/xml/xmlcommand.mli | 41 + plugins/xml/xmlentries.ml4 | 40 + 279 files changed, 80280 insertions(+) create mode 100644 plugins/cc/README create mode 100644 plugins/cc/cc_plugin.mllib create mode 100644 plugins/cc/ccalgo.ml create mode 100644 plugins/cc/ccalgo.mli create mode 100644 plugins/cc/ccproof.ml create mode 100644 plugins/cc/ccproof.mli create mode 100644 plugins/cc/cctac.ml create mode 100644 plugins/cc/cctac.mli create mode 100644 plugins/cc/g_congruence.ml4 create mode 100644 plugins/dp/Dp.v create mode 100644 plugins/dp/TODO create mode 100644 plugins/dp/dp.ml create mode 100644 plugins/dp/dp.mli create mode 100644 plugins/dp/dp_plugin.mllib create mode 100644 plugins/dp/dp_why.ml create mode 100644 plugins/dp/dp_why.mli create mode 100644 plugins/dp/dp_zenon.mli create mode 100644 plugins/dp/dp_zenon.mll create mode 100644 plugins/dp/fol.mli create mode 100644 plugins/dp/g_dp.ml4 create mode 100644 plugins/dp/test2.v create mode 100644 plugins/dp/tests.v create mode 100644 plugins/dp/vo.itarget create mode 100644 plugins/dp/zenon.v create mode 100644 plugins/extraction/CHANGES create mode 100644 plugins/extraction/ExtrOcamlBasic.v create mode 100644 plugins/extraction/ExtrOcamlBigIntConv.v create mode 100644 plugins/extraction/ExtrOcamlIntConv.v create mode 100644 plugins/extraction/ExtrOcamlNatBigInt.v create mode 100644 plugins/extraction/ExtrOcamlNatInt.v create mode 100644 plugins/extraction/ExtrOcamlString.v create mode 100644 plugins/extraction/ExtrOcamlZBigInt.v create mode 100644 plugins/extraction/ExtrOcamlZInt.v create mode 100644 plugins/extraction/README create mode 100644 plugins/extraction/big.ml create mode 100644 plugins/extraction/common.ml create mode 100644 plugins/extraction/common.mli create mode 100644 plugins/extraction/extract_env.ml create mode 100644 plugins/extraction/extract_env.mli create mode 100644 plugins/extraction/extraction.ml create mode 100644 plugins/extraction/extraction.mli create mode 100644 plugins/extraction/extraction_plugin.mllib create mode 100644 plugins/extraction/g_extraction.ml4 create mode 100644 plugins/extraction/haskell.ml create mode 100644 plugins/extraction/haskell.mli create mode 100644 plugins/extraction/miniml.mli create mode 100644 plugins/extraction/mlutil.ml create mode 100644 plugins/extraction/mlutil.mli create mode 100644 plugins/extraction/modutil.ml create mode 100644 plugins/extraction/modutil.mli create mode 100644 plugins/extraction/ocaml.ml create mode 100644 plugins/extraction/ocaml.mli create mode 100644 plugins/extraction/scheme.ml create mode 100644 plugins/extraction/scheme.mli create mode 100644 plugins/extraction/table.ml create mode 100644 plugins/extraction/table.mli create mode 100644 plugins/extraction/vo.itarget create mode 100644 plugins/field/LegacyField.v create mode 100644 plugins/field/LegacyField_Compl.v create mode 100644 plugins/field/LegacyField_Tactic.v create mode 100644 plugins/field/LegacyField_Theory.v create mode 100644 plugins/field/field.ml4 create mode 100644 plugins/field/field_plugin.mllib create mode 100644 plugins/field/vo.itarget create mode 100644 plugins/firstorder/formula.ml create mode 100644 plugins/firstorder/formula.mli create mode 100644 plugins/firstorder/g_ground.ml4 create mode 100644 plugins/firstorder/ground.ml create mode 100644 plugins/firstorder/ground.mli create mode 100644 plugins/firstorder/ground_plugin.mllib create mode 100644 plugins/firstorder/instances.ml create mode 100644 plugins/firstorder/instances.mli create mode 100644 plugins/firstorder/rules.ml create mode 100644 plugins/firstorder/rules.mli create mode 100644 plugins/firstorder/sequent.ml create mode 100644 plugins/firstorder/sequent.mli create mode 100644 plugins/firstorder/unify.ml create mode 100644 plugins/firstorder/unify.mli create mode 100644 plugins/fourier/Fourier.v create mode 100644 plugins/fourier/Fourier_util.v create mode 100644 plugins/fourier/fourier.ml create mode 100644 plugins/fourier/fourierR.ml create mode 100644 plugins/fourier/fourier_plugin.mllib create mode 100644 plugins/fourier/g_fourier.ml4 create mode 100644 plugins/fourier/vo.itarget create mode 100644 plugins/funind/Recdef.v create mode 100644 plugins/funind/functional_principles_proofs.ml create mode 100644 plugins/funind/functional_principles_proofs.mli create mode 100644 plugins/funind/functional_principles_types.ml create mode 100644 plugins/funind/functional_principles_types.mli create mode 100644 plugins/funind/g_indfun.ml4 create mode 100644 plugins/funind/indfun.ml create mode 100644 plugins/funind/indfun_common.ml create mode 100644 plugins/funind/indfun_common.mli create mode 100644 plugins/funind/invfun.ml create mode 100644 plugins/funind/merge.ml create mode 100644 plugins/funind/rawterm_to_relation.ml create mode 100644 plugins/funind/rawterm_to_relation.mli create mode 100644 plugins/funind/rawtermops.ml create mode 100644 plugins/funind/rawtermops.mli create mode 100644 plugins/funind/recdef.ml create mode 100644 plugins/funind/recdef_plugin.mllib create mode 100644 plugins/funind/vo.itarget create mode 100644 plugins/micromega/CheckerMaker.v create mode 100644 plugins/micromega/Env.v create mode 100644 plugins/micromega/EnvRing.v create mode 100644 plugins/micromega/LICENSE.sos create mode 100644 plugins/micromega/MExtraction.v create mode 100644 plugins/micromega/OrderedRing.v create mode 100644 plugins/micromega/Psatz.v create mode 100644 plugins/micromega/QMicromega.v create mode 100644 plugins/micromega/RMicromega.v create mode 100644 plugins/micromega/Refl.v create mode 100644 plugins/micromega/RingMicromega.v create mode 100644 plugins/micromega/Tauto.v create mode 100644 plugins/micromega/VarMap.v create mode 100644 plugins/micromega/ZCoeff.v create mode 100644 plugins/micromega/ZMicromega.v create mode 100644 plugins/micromega/certificate.ml create mode 100644 plugins/micromega/coq_micromega.ml create mode 100644 plugins/micromega/csdpcert.ml create mode 100644 plugins/micromega/g_micromega.ml4 create mode 100644 plugins/micromega/mfourier.ml create mode 100644 plugins/micromega/micromega.ml create mode 100644 plugins/micromega/micromega.mli create mode 100644 plugins/micromega/micromega_plugin.mllib create mode 100644 plugins/micromega/mutils.ml create mode 100644 plugins/micromega/persistent_cache.ml create mode 100644 plugins/micromega/sos.ml create mode 100644 plugins/micromega/sos.mli create mode 100644 plugins/micromega/sos_lib.ml create mode 100644 plugins/micromega/sos_types.ml create mode 100644 plugins/micromega/vo.itarget create mode 100644 plugins/nsatz/NsatzR.v create mode 100644 plugins/nsatz/NsatzZ.v create mode 100644 plugins/nsatz/Nsatz_domain.v create mode 100644 plugins/nsatz/ideal.ml create mode 100644 plugins/nsatz/nsatz.ml4 create mode 100644 plugins/nsatz/nsatz_plugin.mllib create mode 100644 plugins/nsatz/polynom.ml create mode 100644 plugins/nsatz/polynom.mli create mode 100644 plugins/nsatz/utile.ml create mode 100644 plugins/nsatz/utile.mli create mode 100644 plugins/nsatz/vo.itarget create mode 100644 plugins/omega/Omega.v create mode 100644 plugins/omega/OmegaLemmas.v create mode 100644 plugins/omega/OmegaPlugin.v create mode 100644 plugins/omega/PreOmega.v create mode 100644 plugins/omega/coq_omega.ml create mode 100644 plugins/omega/g_omega.ml4 create mode 100644 plugins/omega/omega.ml create mode 100644 plugins/omega/omega_plugin.mllib create mode 100644 plugins/omega/vo.itarget create mode 100644 plugins/plugins.itarget create mode 100644 plugins/pluginsbyte.itarget create mode 100644 plugins/pluginsdyn.itarget create mode 100644 plugins/pluginsopt.itarget create mode 100644 plugins/pluginsvo.itarget create mode 100644 plugins/quote/Quote.v create mode 100644 plugins/quote/g_quote.ml4 create mode 100644 plugins/quote/quote.ml create mode 100644 plugins/quote/quote_plugin.mllib create mode 100644 plugins/quote/vo.itarget create mode 100644 plugins/ring/LegacyArithRing.v create mode 100644 plugins/ring/LegacyNArithRing.v create mode 100644 plugins/ring/LegacyRing.v create mode 100644 plugins/ring/LegacyRing_theory.v create mode 100644 plugins/ring/LegacyZArithRing.v create mode 100644 plugins/ring/Ring_abstract.v create mode 100644 plugins/ring/Ring_normalize.v create mode 100644 plugins/ring/Setoid_ring.v create mode 100644 plugins/ring/Setoid_ring_normalize.v create mode 100644 plugins/ring/Setoid_ring_theory.v create mode 100644 plugins/ring/g_ring.ml4 create mode 100644 plugins/ring/ring.ml create mode 100644 plugins/ring/ring_plugin.mllib create mode 100644 plugins/ring/vo.itarget create mode 100644 plugins/romega/README create mode 100644 plugins/romega/ROmega.v create mode 100644 plugins/romega/ReflOmegaCore.v create mode 100644 plugins/romega/const_omega.ml create mode 100644 plugins/romega/const_omega.mli create mode 100644 plugins/romega/g_romega.ml4 create mode 100644 plugins/romega/refl_omega.ml create mode 100644 plugins/romega/romega_plugin.mllib create mode 100644 plugins/romega/vo.itarget create mode 100644 plugins/rtauto/Bintree.v create mode 100644 plugins/rtauto/Rtauto.v create mode 100644 plugins/rtauto/g_rtauto.ml4 create mode 100644 plugins/rtauto/proof_search.ml create mode 100644 plugins/rtauto/proof_search.mli create mode 100644 plugins/rtauto/refl_tauto.ml create mode 100644 plugins/rtauto/refl_tauto.mli create mode 100644 plugins/rtauto/rtauto_plugin.mllib create mode 100644 plugins/rtauto/vo.itarget create mode 100644 plugins/setoid_ring/ArithRing.v create mode 100644 plugins/setoid_ring/BinList.v create mode 100644 plugins/setoid_ring/Field.v create mode 100644 plugins/setoid_ring/Field_tac.v create mode 100644 plugins/setoid_ring/Field_theory.v create mode 100644 plugins/setoid_ring/InitialRing.v create mode 100644 plugins/setoid_ring/NArithRing.v create mode 100644 plugins/setoid_ring/RealField.v create mode 100644 plugins/setoid_ring/Ring.v create mode 100644 plugins/setoid_ring/Ring_base.v create mode 100644 plugins/setoid_ring/Ring_equiv.v create mode 100644 plugins/setoid_ring/Ring_polynom.v create mode 100644 plugins/setoid_ring/Ring_tac.v create mode 100644 plugins/setoid_ring/Ring_theory.v create mode 100644 plugins/setoid_ring/ZArithRing.v create mode 100644 plugins/setoid_ring/newring.ml4 create mode 100644 plugins/setoid_ring/newring_plugin.mllib create mode 100644 plugins/setoid_ring/vo.itarget create mode 100644 plugins/subtac/eterm.ml create mode 100644 plugins/subtac/eterm.mli create mode 100644 plugins/subtac/g_subtac.ml4 create mode 100644 plugins/subtac/subtac.ml create mode 100644 plugins/subtac/subtac.mli create mode 100644 plugins/subtac/subtac_cases.ml create mode 100644 plugins/subtac/subtac_cases.mli create mode 100644 plugins/subtac/subtac_classes.ml create mode 100644 plugins/subtac/subtac_classes.mli create mode 100644 plugins/subtac/subtac_coercion.ml create mode 100644 plugins/subtac/subtac_coercion.mli create mode 100644 plugins/subtac/subtac_command.ml create mode 100644 plugins/subtac/subtac_command.mli create mode 100644 plugins/subtac/subtac_errors.ml create mode 100644 plugins/subtac/subtac_errors.mli create mode 100644 plugins/subtac/subtac_obligations.ml create mode 100644 plugins/subtac/subtac_obligations.mli create mode 100644 plugins/subtac/subtac_plugin.mllib create mode 100644 plugins/subtac/subtac_pretyping.ml create mode 100644 plugins/subtac/subtac_pretyping.mli create mode 100644 plugins/subtac/subtac_pretyping_F.ml create mode 100644 plugins/subtac/subtac_utils.ml create mode 100644 plugins/subtac/subtac_utils.mli create mode 100644 plugins/subtac/test/ListDep.v create mode 100644 plugins/subtac/test/ListsTest.v create mode 100644 plugins/subtac/test/Mutind.v create mode 100644 plugins/subtac/test/Test1.v create mode 100644 plugins/subtac/test/euclid.v create mode 100644 plugins/subtac/test/id.v create mode 100644 plugins/subtac/test/measure.v create mode 100644 plugins/subtac/test/rec.v create mode 100644 plugins/subtac/test/take.v create mode 100644 plugins/subtac/test/wf.v create mode 100644 plugins/syntax/ascii_syntax.ml create mode 100644 plugins/syntax/ascii_syntax_plugin.mllib create mode 100644 plugins/syntax/nat_syntax.ml create mode 100644 plugins/syntax/nat_syntax_plugin.mllib create mode 100644 plugins/syntax/numbers_syntax.ml create mode 100644 plugins/syntax/numbers_syntax_plugin.mllib create mode 100644 plugins/syntax/r_syntax.ml create mode 100644 plugins/syntax/r_syntax_plugin.mllib create mode 100644 plugins/syntax/string_syntax.ml create mode 100644 plugins/syntax/string_syntax_plugin.mllib create mode 100644 plugins/syntax/z_syntax.ml create mode 100644 plugins/syntax/z_syntax_plugin.mllib create mode 100644 plugins/xml/COPYRIGHT create mode 100644 plugins/xml/README create mode 100644 plugins/xml/acic.ml create mode 100644 plugins/xml/acic2Xml.ml4 create mode 100644 plugins/xml/cic.dtd create mode 100644 plugins/xml/cic2Xml.ml create mode 100644 plugins/xml/cic2acic.ml create mode 100644 plugins/xml/doubleTypeInference.ml create mode 100644 plugins/xml/doubleTypeInference.mli create mode 100644 plugins/xml/dumptree.ml4 create mode 100644 plugins/xml/proof2aproof.ml create mode 100644 plugins/xml/proofTree2Xml.ml4 create mode 100644 plugins/xml/theoryobject.dtd create mode 100644 plugins/xml/unshare.ml create mode 100644 plugins/xml/unshare.mli create mode 100644 plugins/xml/xml.ml4 create mode 100644 plugins/xml/xml.mli create mode 100644 plugins/xml/xml_plugin.mllib create mode 100644 plugins/xml/xmlcommand.ml create mode 100644 plugins/xml/xmlcommand.mli create mode 100644 plugins/xml/xmlentries.ml4 (limited to 'plugins') diff --git a/plugins/cc/README b/plugins/cc/README new file mode 100644 index 00000000..073b140e --- /dev/null +++ b/plugins/cc/README @@ -0,0 +1,20 @@ + +cctac: congruence-closure for coq + +author: Pierre Corbineau, + Stage de DEA au LSV, ENS Cachan + Thèse au LRI, Université Paris Sud XI + +Files : + +- ccalgo.ml : congruence closure algorithm +- ccproof.ml : proof generation code +- cctac.ml4 : the tactic itself +- CCSolve.v : a small Ltac tactic based on congruence + +Known Bugs : the congruence tactic can fail due to type dependencies. + +Related documents: + Peter J. Downey, Ravi Sethi, and Robert E. Tarjan. + Variations on the common subexpression problem. + JACM, 27(4):758-771, October 1980. diff --git a/plugins/cc/cc_plugin.mllib b/plugins/cc/cc_plugin.mllib new file mode 100644 index 00000000..1bcfc537 --- /dev/null +++ b/plugins/cc/cc_plugin.mllib @@ -0,0 +1,5 @@ +Ccalgo +Ccproof +Cctac +G_congruence +Cc_plugin_mod diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml new file mode 100644 index 00000000..9cc6f9de --- /dev/null +++ b/plugins/cc/ccalgo.ml @@ -0,0 +1,884 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* !cc_verbose); + optwrite=(fun b -> cc_verbose := b)} + in + declare_bool_option gdopt + +(* Signature table *) + +module ST=struct + + (* l: sign -> term r: term -> sign *) + + type t = {toterm:(int*int,int) Hashtbl.t; + tosign:(int,int*int) Hashtbl.t} + + let empty ()= + {toterm=Hashtbl.create init_size; + tosign=Hashtbl.create init_size} + + let enter t sign st= + if Hashtbl.mem st.toterm sign then + anomaly "enter: signature already entered" + else + Hashtbl.replace st.toterm sign t; + Hashtbl.replace st.tosign t sign + + let query sign st=Hashtbl.find st.toterm sign + + let rev_query term st=Hashtbl.find st.tosign term + + let delete st t= + try let sign=Hashtbl.find st.tosign t in + Hashtbl.remove st.toterm sign; + Hashtbl.remove st.tosign t + with + Not_found -> () + + let rec delete_set st s = Intset.iter (delete st) s + +end + +type pa_constructor= + { cnode : int; + arity : int; + args : int list} + +type pa_fun= + {fsym:int; + fnargs:int} + +type pa_mark= + Fmark of pa_fun + | Cmark of pa_constructor + +module PacMap=Map.Make(struct + type t=pa_constructor + let compare=Pervasives.compare end) + +module PafMap=Map.Make(struct + type t=pa_fun + let compare=Pervasives.compare end) + +type cinfo= + {ci_constr: constructor; (* inductive type *) + ci_arity: int; (* # args *) + ci_nhyps: int} (* # projectable args *) + +type term= + Symb of constr + | Product of sorts_family * sorts_family + | Eps of identifier + | Appli of term*term + | Constructor of cinfo (* constructor arity + nhyps *) + +type ccpattern = + PApp of term * ccpattern list (* arguments are reversed *) + | PVar of int + +type rule= + Congruence + | Axiom of constr * bool + | Injection of int * pa_constructor * int * pa_constructor * int + +type from= + Goal + | Hyp of constr + | HeqG of constr + | HeqnH of constr * constr + +type 'a eq = {lhs:int;rhs:int;rule:'a} + +type equality = rule eq + +type disequality = from eq + +type patt_kind = + Normal + | Trivial of types + | Creates_variables + +type quant_eq = + {qe_hyp_id: identifier; + qe_pol: bool; + qe_nvars:int; + qe_lhs: ccpattern; + qe_lhs_valid:patt_kind; + qe_rhs: ccpattern; + qe_rhs_valid:patt_kind} + +let swap eq : equality = + let swap_rule=match eq.rule with + Congruence -> Congruence + | Injection (i,pi,j,pj,k) -> Injection (j,pj,i,pi,k) + | Axiom (id,reversed) -> Axiom (id,not reversed) + in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule} + +type inductive_status = + Unknown + | Partial of pa_constructor + | Partial_applied + | Total of (int * pa_constructor) + +type representative= + {mutable weight:int; + mutable lfathers:Intset.t; + mutable fathers:Intset.t; + mutable inductive_status: inductive_status; + class_type : Term.types; + mutable functions: Intset.t PafMap.t; + mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *) + +type cl = Rep of representative| Eqto of int*equality + +type vertex = Leaf| Node of (int*int) + +type node = + {mutable clas:cl; + mutable cpath: int; + vertex:vertex; + term:term} + +type forest= + {mutable max_size:int; + mutable size:int; + mutable map: node array; + axioms: (constr,term*term) Hashtbl.t; + mutable epsilons: pa_constructor list; + syms:(term,int) Hashtbl.t} + +type state = + {uf: forest; + sigtable:ST.t; + mutable terms: Intset.t; + combine: equality Queue.t; + marks: (int * pa_mark) Queue.t; + mutable diseq: disequality list; + mutable quant: quant_eq list; + mutable pa_classes: Intset.t; + q_history: (identifier,int array) Hashtbl.t; + mutable rew_depth:int; + mutable changed:bool; + by_type: (types,Intset.t) Hashtbl.t; + mutable gls:Proof_type.goal Tacmach.sigma} + +let dummy_node = + {clas=Eqto(min_int,{lhs=min_int;rhs=min_int;rule=Congruence}); + cpath=min_int; + vertex=Leaf; + term=Symb (mkRel min_int)} + +let empty depth gls:state = + {uf= + {max_size=init_size; + size=0; + map=Array.create init_size dummy_node; + epsilons=[]; + axioms=Hashtbl.create init_size; + syms=Hashtbl.create init_size}; + terms=Intset.empty; + combine=Queue.create (); + marks=Queue.create (); + sigtable=ST.empty (); + diseq=[]; + quant=[]; + pa_classes=Intset.empty; + q_history=Hashtbl.create init_size; + rew_depth=depth; + by_type=Hashtbl.create init_size; + changed=false; + gls=gls} + +let forest state = state.uf + +let compress_path uf i j = uf.map.(j).cpath<-i + +let rec find_aux uf visited i= + let j = uf.map.(i).cpath in + if j<0 then let _ = List.iter (compress_path uf i) visited in i else + find_aux uf (i::visited) j + +let find uf i= find_aux uf [] i + +let get_representative uf i= + match uf.map.(i).clas with + Rep r -> r + | _ -> anomaly "get_representative: not a representative" + +let find_pac uf i pac = + PacMap.find pac (get_representative uf i).constructors + +let get_constructor_info uf i= + match uf.map.(i).term with + Constructor cinfo->cinfo + | _ -> anomaly "get_constructor: not a constructor" + +let size uf i= + (get_representative uf i).weight + +let axioms uf = uf.axioms + +let epsilons uf = uf.epsilons + +let add_lfather uf i t= + let r=get_representative uf i in + r.weight<-r.weight+1; + r.lfathers<-Intset.add t r.lfathers; + r.fathers <-Intset.add t r.fathers + +let add_rfather uf i t= + let r=get_representative uf i in + r.weight<-r.weight+1; + r.fathers <-Intset.add t r.fathers + +exception Discriminable of int * pa_constructor * int * pa_constructor + +let append_pac t p = + {p with arity=pred p.arity;args=t::p.args} + +let tail_pac p= + {p with arity=succ p.arity;args=List.tl p.args} + +let fsucc paf = + {paf with fnargs=succ paf.fnargs} + +let add_pac rep pac t = + if not (PacMap.mem pac rep.constructors) then + rep.constructors<-PacMap.add pac t rep.constructors + +let add_paf rep paf t = + let already = + try PafMap.find paf rep.functions with Not_found -> Intset.empty in + rep.functions<- PafMap.add paf (Intset.add t already) rep.functions + +let term uf i=uf.map.(i).term + +let subterms uf i= + match uf.map.(i).vertex with + Node(j,k) -> (j,k) + | _ -> anomaly "subterms: not a node" + +let signature uf i= + let j,k=subterms uf i in (find uf j,find uf k) + +let next uf= + let size=uf.size in + let nsize= succ size in + if nsize=uf.max_size then + let newmax=uf.max_size * 3 / 2 + 1 in + let newmap=Array.create newmax dummy_node in + begin + uf.max_size<-newmax; + Array.blit uf.map 0 newmap 0 size; + uf.map<-newmap + end + else (); + uf.size<-nsize; + size + +let new_representative typ = + {weight=0; + lfathers=Intset.empty; + fathers=Intset.empty; + inductive_status=Unknown; + class_type=typ; + functions=PafMap.empty; + constructors=PacMap.empty} + +(* rebuild a constr from an applicative term *) + +let _A_ = Name (id_of_string "A") +let _B_ = Name (id_of_string "A") +let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) + +let cc_product s1 s2 = + mkLambda(_A_,mkSort(Termops.new_sort_in_family s1), + mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_)) + +let rec constr_of_term = function + Symb s->s + | Product(s1,s2) -> cc_product s1 s2 + | Eps id -> mkVar id + | Constructor cinfo -> mkConstruct cinfo.ci_constr + | Appli (s1,s2)-> + make_app [(constr_of_term s2)] s1 +and make_app l=function + Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 + | other -> applistc (constr_of_term other) l + +(* rebuild a term from a pattern and a substitution *) + +let build_subst uf subst = + Array.map (fun i -> + try term uf i + with _ -> anomaly "incomplete matching") subst + +let rec inst_pattern subst = function + PVar i -> + subst.(pred i) + | PApp (t, args) -> + List.fold_right + (fun spat f -> Appli (f,inst_pattern subst spat)) + args t + +let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++ + Termops.print_constr (constr_of_term (term state.uf i)) ++ str "]" + +let pr_term t = str "[" ++ + Termops.print_constr (constr_of_term t) ++ str "]" + +let rec add_term state t= + let uf=state.uf in + try Hashtbl.find uf.syms t with + Not_found -> + let b=next uf in + let typ = pf_type_of state.gls (constr_of_term t) in + let new_node= + match t with + Symb _ | Product (_,_) -> + let paf = + {fsym=b; + fnargs=0} in + Queue.add (b,Fmark paf) state.marks; + {clas= Rep (new_representative typ); + cpath= -1; + vertex= Leaf; + term= t} + | Eps id -> + {clas= Rep (new_representative typ); + cpath= -1; + vertex= Leaf; + term= t} + | Appli (t1,t2) -> + let i1=add_term state t1 and i2=add_term state t2 in + add_lfather uf (find uf i1) b; + add_rfather uf (find uf i2) b; + state.terms<-Intset.add b state.terms; + {clas= Rep (new_representative typ); + cpath= -1; + vertex= Node(i1,i2); + term= t} + | Constructor cinfo -> + let paf = + {fsym=b; + fnargs=0} in + Queue.add (b,Fmark paf) state.marks; + let pac = + {cnode= b; + arity= cinfo.ci_arity; + args=[]} in + Queue.add (b,Cmark pac) state.marks; + {clas=Rep (new_representative typ); + cpath= -1; + vertex=Leaf; + term=t} + in + uf.map.(b)<-new_node; + Hashtbl.add uf.syms t b; + Hashtbl.replace state.by_type typ + (Intset.add b + (try Hashtbl.find state.by_type typ with + Not_found -> Intset.empty)); + b + +let add_equality state c s t= + let i = add_term state s in + let j = add_term state t in + Queue.add {lhs=i;rhs=j;rule=Axiom(c,false)} state.combine; + Hashtbl.add state.uf.axioms c (s,t) + +let add_disequality state from s t = + let i = add_term state s in + let j = add_term state t in + state.diseq<-{lhs=i;rhs=j;rule=from}::state.diseq + +let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) = + state.quant<- + {qe_hyp_id= id; + qe_pol= pol; + qe_nvars=nvars; + qe_lhs= patt1; + qe_lhs_valid=valid1; + qe_rhs= patt2; + qe_rhs_valid=valid2}::state.quant + +let is_redundant state id args = + try + let norm_args = Array.map (find state.uf) args in + let prev_args = Hashtbl.find_all state.q_history id in + List.exists + (fun old_args -> + Util.array_for_all2 (fun i j -> i = find state.uf j) + norm_args old_args) + prev_args + with Not_found -> false + +let add_inst state (inst,int_subst) = + check_for_interrupt (); + if state.rew_depth > 0 then + if is_redundant state inst.qe_hyp_id int_subst then + debug msgnl (str "discarding redundant (dis)equality") + else + begin + Hashtbl.add state.q_history inst.qe_hyp_id int_subst; + let subst = build_subst (forest state) int_subst in + let prfhead= mkVar inst.qe_hyp_id in + let args = Array.map constr_of_term subst in + let _ = array_rev args in (* highest deBruijn index first *) + let prf= mkApp(prfhead,args) in + let s = inst_pattern subst inst.qe_lhs + and t = inst_pattern subst inst.qe_rhs in + state.changed<-true; + state.rew_depth<-pred state.rew_depth; + if inst.qe_pol then + begin + debug (fun () -> + msgnl + (str "Adding new equality, depth="++ int state.rew_depth); + msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ + pr_term s ++ str " == " ++ pr_term t ++ str "]")) (); + add_equality state prf s t + end + else + begin + debug (fun () -> + msgnl + (str "Adding new disequality, depth="++ int state.rew_depth); + msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ + pr_term s ++ str " <> " ++ pr_term t ++ str "]")) (); + add_disequality state (Hyp prf) s t + end + end + +let link uf i j eq = (* links i -> j *) + let node=uf.map.(i) in + node.clas<-Eqto (j,eq); + node.cpath<-j + +let rec down_path uf i l= + match uf.map.(i).clas with + Eqto(j,t)->down_path uf j (((i,j),t)::l) + | Rep _ ->l + +let rec min_path=function + ([],l2)->([],l2) + | (l1,[])->(l1,[]) + | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) + | cpl -> cpl + +let join_path uf i j= + assert (find uf i=find uf j); + min_path (down_path uf i [],down_path uf j []) + +let union state i1 i2 eq= + debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++ + str " and " ++ pr_idx_term state i2 ++ str ".")) (); + let r1= get_representative state.uf i1 + and r2= get_representative state.uf i2 in + link state.uf i1 i2 eq; + Hashtbl.replace state.by_type r1.class_type + (Intset.remove i1 + (try Hashtbl.find state.by_type r1.class_type with + Not_found -> Intset.empty)); + let f= Intset.union r1.fathers r2.fathers in + r2.weight<-Intset.cardinal f; + r2.fathers<-f; + r2.lfathers<-Intset.union r1.lfathers r2.lfathers; + ST.delete_set state.sigtable r1.fathers; + state.terms<-Intset.union state.terms r1.fathers; + PacMap.iter + (fun pac b -> Queue.add (b,Cmark pac) state.marks) + r1.constructors; + PafMap.iter + (fun paf -> Intset.iter + (fun b -> Queue.add (b,Fmark paf) state.marks)) + r1.functions; + match r1.inductive_status,r2.inductive_status with + Unknown,_ -> () + | Partial pac,Unknown -> + r2.inductive_status<-Partial pac; + state.pa_classes<-Intset.remove i1 state.pa_classes; + state.pa_classes<-Intset.add i2 state.pa_classes + | Partial _ ,(Partial _ |Partial_applied) -> + state.pa_classes<-Intset.remove i1 state.pa_classes + | Partial_applied,Unknown -> + r2.inductive_status<-Partial_applied + | Partial_applied,Partial _ -> + state.pa_classes<-Intset.remove i2 state.pa_classes; + r2.inductive_status<-Partial_applied + | Total cpl,Unknown -> r2.inductive_status<-Total cpl; + | Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks + | _,_ -> () + +let merge eq state = (* merge and no-merge *) + debug (fun () -> msgnl + (str "Merging " ++ pr_idx_term state eq.lhs ++ + str " and " ++ pr_idx_term state eq.rhs ++ str ".")) (); + let uf=state.uf in + let i=find uf eq.lhs + and j=find uf eq.rhs in + if i<>j then + if (size uf i)<(size uf j) then + union state i j eq + else + union state j i (swap eq) + +let update t state = (* update 1 and 2 *) + debug (fun () -> msgnl + (str "Updating term " ++ pr_idx_term state t ++ str ".")) (); + let (i,j) as sign = signature state.uf t in + let (u,v) = subterms state.uf t in + let rep = get_representative state.uf i in + begin + match rep.inductive_status with + Partial _ -> + rep.inductive_status <- Partial_applied; + state.pa_classes <- Intset.remove i state.pa_classes + | _ -> () + end; + PacMap.iter + (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) + rep.constructors; + PafMap.iter + (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) + rep.functions; + try + let s = ST.query sign state.sigtable in + Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine + with + Not_found -> ST.enter t sign state.sigtable + +let process_function_mark t rep paf state = + add_paf rep paf t; + state.terms<-Intset.union rep.lfathers state.terms + +let process_constructor_mark t i rep pac state = + match rep.inductive_status with + Total (s,opac) -> + if pac.cnode <> opac.cnode then (* Conflict *) + raise (Discriminable (s,opac,t,pac)) + else (* Match *) + let cinfo = get_constructor_info state.uf pac.cnode in + let rec f n oargs args= + if n > 0 then + match (oargs,args) with + s1::q1,s2::q2-> + Queue.add + {lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)} + state.combine; + f (n-1) q1 q2 + | _-> anomaly + "add_pacs : weird error in injection subterms merge" + in f cinfo.ci_nhyps opac.args pac.args + | Partial_applied | Partial _ -> + add_pac rep pac t; + state.terms<-Intset.union rep.lfathers state.terms + | Unknown -> + if pac.arity = 0 then + rep.inductive_status <- Total (t,pac) + else + begin + add_pac rep pac t; + state.terms<-Intset.union rep.lfathers state.terms; + rep.inductive_status <- Partial pac; + state.pa_classes<- Intset.add i state.pa_classes + end + +let process_mark t m state = + debug (fun () -> msgnl + (str "Processing mark for term " ++ pr_idx_term state t ++ str ".")) (); + let i=find state.uf t in + let rep=get_representative state.uf i in + match m with + Fmark paf -> process_function_mark t rep paf state + | Cmark pac -> process_constructor_mark t i rep pac state + +type explanation = + Discrimination of (int*pa_constructor*int*pa_constructor) + | Contradiction of disequality + | Incomplete + +let check_disequalities state = + let uf=state.uf in + let rec check_aux = function + dis::q -> + debug (fun () -> msg + (str "Checking if " ++ pr_idx_term state dis.lhs ++ str " = " ++ + pr_idx_term state dis.rhs ++ str " ... ")) (); + if find uf dis.lhs=find uf dis.rhs then + begin debug msgnl (str "Yes");Some dis end + else + begin debug msgnl (str "No");check_aux q end + | [] -> None + in + check_aux state.diseq + +let one_step state = + try + let eq = Queue.take state.combine in + merge eq state; + true + with Queue.Empty -> + try + let (t,m) = Queue.take state.marks in + process_mark t m state; + true + with Queue.Empty -> + try + let t = Intset.choose state.terms in + state.terms<-Intset.remove t state.terms; + update t state; + true + with Not_found -> false + +let __eps__ = id_of_string "_eps_" + +let new_state_var typ state = + let id = pf_get_new_id __eps__ state.gls in + state.gls<- + {state.gls with it = + {state.gls.it with evar_hyps = + Environ.push_named_context_val (id,None,typ) + state.gls.it.evar_hyps}}; + id + +let complete_one_class state i= + match (get_representative state.uf i).inductive_status with + Partial pac -> + let rec app t typ n = + if n<=0 then t else + let _,etyp,rest= destProd typ in + let id = new_state_var etyp state in + app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in + let _c = pf_type_of state.gls + (constr_of_term (term state.uf pac.cnode)) in + let _args = + List.map (fun i -> constr_of_term (term state.uf i)) + pac.args in + let typ = prod_applist _c (List.rev _args) in + let ct = app (term state.uf i) typ pac.arity in + state.uf.epsilons <- pac :: state.uf.epsilons; + ignore (add_term state ct) + | _ -> anomaly "wrong incomplete class" + +let complete state = + Intset.iter (complete_one_class state) state.pa_classes + +type matching_problem = +{mp_subst : int array; + mp_inst : quant_eq; + mp_stack : (ccpattern*int) list } + +let make_fun_table state = + let uf= state.uf in + let funtab=ref PafMap.empty in + Array.iteri + (fun i inode -> if i < uf.size then + match inode.clas with + Rep rep -> + PafMap.iter + (fun paf _ -> + let elem = + try PafMap.find paf !funtab + with Not_found -> Intset.empty in + funtab:= PafMap.add paf (Intset.add i elem) !funtab) + rep.functions + | _ -> ()) state.uf.map; + !funtab + + +let rec do_match state res pb_stack = + let mp=Stack.pop pb_stack in + match mp.mp_stack with + [] -> + res:= (mp.mp_inst,mp.mp_subst) :: !res + | (patt,cl)::remains -> + let uf=state.uf in + match patt with + PVar i -> + if mp.mp_subst.(pred i)<0 then + begin + mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *) + Stack.push {mp with mp_stack=remains} pb_stack + end + else + if mp.mp_subst.(pred i) = cl then + Stack.push {mp with mp_stack=remains} pb_stack + else (* mismatch for non-linear variable in pattern *) () + | PApp (f,[]) -> + begin + try let j=Hashtbl.find uf.syms f in + if find uf j =cl then + Stack.push {mp with mp_stack=remains} pb_stack + with Not_found -> () + end + | PApp(f, ((last_arg::rem_args) as args)) -> + try + let j=Hashtbl.find uf.syms f in + let paf={fsym=j;fnargs=List.length args} in + let rep=get_representative uf cl in + let good_terms = PafMap.find paf rep.functions in + let aux i = + let (s,t) = signature state.uf i in + Stack.push + {mp with + mp_subst=Array.copy mp.mp_subst; + mp_stack= + (PApp(f,rem_args),s) :: + (last_arg,t) :: remains} pb_stack in + Intset.iter aux good_terms + with Not_found -> () + +let paf_of_patt syms = function + PVar _ -> invalid_arg "paf_of_patt: pattern is trivial" + | PApp (f,args) -> + {fsym=Hashtbl.find syms f; + fnargs=List.length args} + +let init_pb_stack state = + let syms= state.uf.syms in + let pb_stack = Stack.create () in + let funtab = make_fun_table state in + let aux inst = + begin + let good_classes = + match inst.qe_lhs_valid with + Creates_variables -> Intset.empty + | Normal -> + begin + try + let paf= paf_of_patt syms inst.qe_lhs in + PafMap.find paf funtab + with Not_found -> Intset.empty + end + | Trivial typ -> + begin + try + Hashtbl.find state.by_type typ + with Not_found -> Intset.empty + end in + Intset.iter (fun i -> + Stack.push + {mp_subst = Array.make inst.qe_nvars (-1); + mp_inst=inst; + mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes + end; + begin + let good_classes = + match inst.qe_rhs_valid with + Creates_variables -> Intset.empty + | Normal -> + begin + try + let paf= paf_of_patt syms inst.qe_rhs in + PafMap.find paf funtab + with Not_found -> Intset.empty + end + | Trivial typ -> + begin + try + Hashtbl.find state.by_type typ + with Not_found -> Intset.empty + end in + Intset.iter (fun i -> + Stack.push + {mp_subst = Array.make inst.qe_nvars (-1); + mp_inst=inst; + mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes + end in + List.iter aux state.quant; + pb_stack + +let find_instances state = + let pb_stack= init_pb_stack state in + let res =ref [] in + let _ = + debug msgnl (str "Running E-matching algorithm ... "); + try + while true do + check_for_interrupt (); + do_match state res pb_stack + done; + anomaly "get out of here !" + with Stack.Empty -> () in + !res + +let rec execute first_run state = + debug msgnl (str "Executing ... "); + try + while + check_for_interrupt (); + one_step state do () + done; + match check_disequalities state with + None -> + if not(Intset.is_empty state.pa_classes) then + begin + debug msgnl (str "First run was incomplete, completing ... "); + complete state; + execute false state + end + else + if state.rew_depth>0 then + let l=find_instances state in + List.iter (add_inst state) l; + if state.changed then + begin + state.changed <- false; + execute true state + end + else + begin + debug msgnl (str "Out of instances ... "); + None + end + else + begin + debug msgnl (str "Out of depth ... "); + None + end + | Some dis -> Some + begin + if first_run then Contradiction dis + else Incomplete + end + with Discriminable(s,spac,t,tpac) -> Some + begin + if first_run then Discrimination (s,spac,t,tpac) + else Incomplete + end + + diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli new file mode 100644 index 00000000..5f56c7e6 --- /dev/null +++ b/plugins/cc/ccalgo.mli @@ -0,0 +1,222 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr + +val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit + +val forest : state -> forest + +val axioms : forest -> (constr, term * term) Hashtbl.t + +val epsilons : forest -> pa_constructor list + +val empty : int -> Proof_type.goal Tacmach.sigma -> state + +val add_term : state -> term -> int + +val add_equality : state -> constr -> term -> term -> unit + +val add_disequality : state -> from -> term -> term -> unit + +val add_quant : state -> identifier -> bool -> + int * patt_kind * ccpattern * patt_kind * ccpattern -> unit + +val tail_pac : pa_constructor -> pa_constructor + +val find : forest -> int -> int + +val find_pac : forest -> int -> pa_constructor -> int + +val term : forest -> int -> term + +val get_constructor_info : forest -> int -> cinfo + +val subterms : forest -> int -> int * int + +val join_path : forest -> int -> int -> + ((int * int) * equality) list * ((int * int) * equality) list + +type quant_eq= + {qe_hyp_id: identifier; + qe_pol: bool; + qe_nvars:int; + qe_lhs: ccpattern; + qe_lhs_valid:patt_kind; + qe_rhs: ccpattern; + qe_rhs_valid:patt_kind} + + +type pa_fun= + {fsym:int; + fnargs:int} + +type matching_problem + +module PafMap: Map.S with type key = pa_fun + +val make_fun_table : state -> Intset.t PafMap.t + +val do_match : state -> + (quant_eq * int array) list ref -> matching_problem Stack.t -> unit + +val init_pb_stack : state -> matching_problem Stack.t + +val paf_of_patt : (term, int) Hashtbl.t -> ccpattern -> pa_fun + +val find_instances : state -> (quant_eq * int array) list + +val execute : bool -> state -> explanation option + + + + + + + + + + + + + +(*type pa_constructor + + +module PacMap:Map.S with type key=pa_constructor + +type term = + Symb of Term.constr + | Eps + | Appli of term * term + | Constructor of Names.constructor*int*int + +type rule = + Congruence + | Axiom of Names.identifier + | Injection of int*int*int*int + +type equality = + {lhs : int; + rhs : int; + rule : rule} + +module ST : +sig + type t + val empty : unit -> t + val enter : int -> int * int -> t -> unit + val query : int * int -> t -> int + val delete : int -> t -> unit + val delete_list : int list -> t -> unit +end + +module UF : +sig + type t + exception Discriminable of int * int * int * int * t + val empty : unit -> t + val find : t -> int -> int + val size : t -> int -> int + val get_constructor : t -> int -> Names.constructor + val pac_arity : t -> int -> int * int -> int + val mem_node_pac : t -> int -> int * int -> int + val add_pacs : t -> int -> pa_constructor PacMap.t -> + int list * equality list + val term : t -> int -> term + val subterms : t -> int -> int * int + val add : t -> term -> int + val union : t -> int -> int -> equality -> int list * equality list + val join_path : t -> int -> int -> + ((int*int)*equality) list* + ((int*int)*equality) list +end + + +val combine_rec : UF.t -> int list -> equality list +val process_rec : UF.t -> equality list -> int list + +val cc : UF.t -> unit + +val make_uf : + (Names.identifier * (term * term)) list -> UF.t + +val add_one_diseq : UF.t -> (term * term) -> int * int + +val add_disaxioms : + UF.t -> (Names.identifier * (term * term)) list -> + (Names.identifier * (int * int)) list + +val check_equal : UF.t -> int * int -> bool + +val find_contradiction : UF.t -> + (Names.identifier * (int * int)) list -> + (Names.identifier * (int * int)) +*) + + diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml new file mode 100644 index 00000000..2a019ebf --- /dev/null +++ b/plugins/cc/ccproof.ml @@ -0,0 +1,153 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* prefl (Appli (t1,t2)) + | _, _ -> + {p_lhs=Appli (p1.p_lhs,p2.p_lhs); + p_rhs=Appli (p1.p_rhs,p2.p_rhs); + p_rule=Congr (p1,p2)} + +let rec ptrans p1 p3= + match p1.p_rule,p3.p_rule with + Refl _, _ ->p3 + | _, Refl _ ->p1 + | Trans(p1,p2), _ ->ptrans p1 (ptrans p2 p3) + | Congr(p1,p2), Congr(p3,p4) ->pcongr (ptrans p1 p3) (ptrans p2 p4) + | Congr(p1,p2), Trans({p_rule=Congr(p3,p4)},p5) -> + ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5 + | _, _ -> + if p1.p_rhs = p3.p_lhs then + {p_lhs=p1.p_lhs; + p_rhs=p3.p_rhs; + p_rule=Trans (p1,p3)} + else anomaly "invalid cc transitivity" + +let rec psym p = + match p.p_rule with + Refl _ -> p + | SymAx s -> + {p_lhs=p.p_rhs; + p_rhs=p.p_lhs; + p_rule=Ax s} + | Ax s-> + {p_lhs=p.p_rhs; + p_rhs=p.p_lhs; + p_rule=SymAx s} + | Inject (p0,c,n,a)-> + {p_lhs=p.p_rhs; + p_rhs=p.p_lhs; + p_rule=Inject (psym p0,c,n,a)} + | Trans (p1,p2)-> ptrans (psym p2) (psym p1) + | Congr (p1,p2)-> pcongr (psym p1) (psym p2) + +let pax axioms s = + let l,r = Hashtbl.find axioms s in + {p_lhs=l; + p_rhs=r; + p_rule=Ax s} + +let psymax axioms s = + let l,r = Hashtbl.find axioms s in + {p_lhs=r; + p_rhs=l; + p_rule=SymAx s} + +let rec nth_arg t n= + match t with + Appli (t1,t2)-> + if n>0 then + nth_arg t1 (n-1) + else t2 + | _ -> anomaly "nth_arg: not enough args" + +let pinject p c n a = + {p_lhs=nth_arg p.p_lhs (n-a); + p_rhs=nth_arg p.p_rhs (n-a); + p_rule=Inject(p,c,n,a)} + +let build_proof uf= + + let axioms = axioms uf in + + let rec equal_proof i j= + if i=j then prefl (term uf i) else + let (li,lj)=join_path uf i j in + ptrans (path_proof i li) (psym (path_proof j lj)) + + and edge_proof ((i,j),eq)= + let pi=equal_proof i eq.lhs in + let pj=psym (equal_proof j eq.rhs) in + let pij= + match eq.rule with + Axiom (s,reversed)-> + if reversed then psymax axioms s + else pax axioms s + | Congruence ->congr_proof eq.lhs eq.rhs + | Injection (ti,ipac,tj,jpac,k) -> + let p=ind_proof ti ipac tj jpac in + let cinfo= get_constructor_info uf ipac.cnode in + pinject p cinfo.ci_constr cinfo.ci_nhyps k + in ptrans (ptrans pi pij) pj + + and constr_proof i t ipac= + if ipac.args=[] then + equal_proof i t + else + let npac=tail_pac ipac in + let (j,arg)=subterms uf t in + let targ=term uf arg in + let rj=find uf j in + let u=find_pac uf rj npac in + let p=constr_proof j u npac in + ptrans (equal_proof i t) (pcongr p (prefl targ)) + + and path_proof i=function + [] -> prefl (term uf i) + | x::q->ptrans (path_proof (snd (fst x)) q) (edge_proof x) + + and congr_proof i j= + let (i1,i2) = subterms uf i + and (j1,j2) = subterms uf j in + pcongr (equal_proof i1 j1) (equal_proof i2 j2) + + and ind_proof i ipac j jpac= + let p=equal_proof i j + and p1=constr_proof i i ipac + and p2=constr_proof j j jpac in + ptrans (psym p1) (ptrans p p2) + in + function + `Prove (i,j) -> equal_proof i j + | `Discr (i,ci,j,cj)-> ind_proof i ci j cj + + + diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli new file mode 100644 index 00000000..2a0ca688 --- /dev/null +++ b/plugins/cc/ccproof.mli @@ -0,0 +1,31 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + [ `Discr of int * pa_constructor * int * pa_constructor + | `Prove of int * int ] -> proof + + + diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml new file mode 100644 index 00000000..4e6ea802 --- /dev/null +++ b/plugins/cc/cctac.ml @@ -0,0 +1,465 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Closure.whd_val infos (Closure.inject t)) + +let whd_delta env= + let infos=Closure.create_clos_infos Closure.betadeltaiota env in + (fun t -> Closure.whd_val infos (Closure.inject t)) + +(* decompose member of equality in an applicative format *) + +let sf_of env sigma c = family_of_sort (sort_of env sigma c) + +let rec decompose_term env sigma t= + match kind_of_term (whd env t) with + App (f,args)-> + let tf=decompose_term env sigma f in + let targs=Array.map (decompose_term env sigma) args in + Array.fold_left (fun s t->Appli (s,t)) tf targs + | Prod (_,a,_b) when not (dependent (mkRel 1) _b) -> + let b = pop _b in + let sort_b = sf_of env sigma b in + let sort_a = sf_of env sigma a in + Appli(Appli(Product (sort_a,sort_b) , + decompose_term env sigma a), + decompose_term env sigma b) + | Construct c-> + let (oib,_)=Global.lookup_inductive (fst c) in + let nargs=mis_constructor_nargs_env env c in + Constructor {ci_constr=c; + ci_arity=nargs; + ci_nhyps=nargs-oib.mind_nparams} + | _ ->if closed0 t then (Symb t) else raise Not_found + +(* decompose equality in members and type *) + +let atom_of_constr env sigma term = + let wh = (whd_delta env term) in + let kot = kind_of_term wh in + match kot with + App (f,args)-> + if eq_constr f (Lazy.force _eq) && (Array.length args)=3 + then `Eq (args.(0), + decompose_term env sigma args.(1), + decompose_term env sigma args.(2)) + else `Other (decompose_term env sigma term) + | _ -> `Other (decompose_term env sigma term) + +let rec pattern_of_constr env sigma c = + match kind_of_term (whd env c) with + App (f,args)-> + let pf = decompose_term env sigma f in + let pargs,lrels = List.split + (array_map_to_list (pattern_of_constr env sigma) args) in + PApp (pf,List.rev pargs), + List.fold_left Intset.union Intset.empty lrels + | Prod (_,a,_b) when not (dependent (mkRel 1) _b) -> + let b =pop _b in + let pa,sa = pattern_of_constr env sigma a in + let pb,sb = pattern_of_constr env sigma (pop b) in + let sort_b = sf_of env sigma b in + let sort_a = sf_of env sigma a in + PApp(Product (sort_a,sort_b), + [pa;pb]),(Intset.union sa sb) + | Rel i -> PVar i,Intset.singleton i + | _ -> + let pf = decompose_term env sigma c in + PApp (pf,[]),Intset.empty + +let non_trivial = function + PVar _ -> false + | _ -> true + +let patterns_of_constr env sigma nrels term= + let f,args= + try destApp (whd_delta env term) with _ -> raise Not_found in + if eq_constr f (Lazy.force _eq) && (Array.length args)=3 + then + let patt1,rels1 = pattern_of_constr env sigma args.(1) + and patt2,rels2 = pattern_of_constr env sigma args.(2) in + let valid1 = + if Intset.cardinal rels1 <> nrels then Creates_variables + else if non_trivial patt1 then Normal + else Trivial args.(0) + and valid2 = + if Intset.cardinal rels2 <> nrels then Creates_variables + else if non_trivial patt2 then Normal + else Trivial args.(0) in + if valid1 <> Creates_variables + || valid2 <> Creates_variables then + nrels,valid1,patt1,valid2,patt2 + else raise Not_found + else raise Not_found + +let rec quantified_atom_of_constr env sigma nrels term = + match kind_of_term (whd_delta env term) with + Prod (_,atom,ff) -> + if eq_constr ff (Lazy.force _False) then + let patts=patterns_of_constr env sigma nrels atom in + `Nrule patts + else + quantified_atom_of_constr env sigma (succ nrels) ff + | _ -> + let patts=patterns_of_constr env sigma nrels term in + `Rule patts + +let litteral_of_constr env sigma term= + match kind_of_term (whd_delta env term) with + | Prod (_,atom,ff) -> + if eq_constr ff (Lazy.force _False) then + match (atom_of_constr env sigma atom) with + `Eq(t,a,b) -> `Neq(t,a,b) + | `Other(p) -> `Nother(p) + else + begin + try + quantified_atom_of_constr env sigma 1 ff + with Not_found -> + `Other (decompose_term env sigma term) + end + | _ -> + atom_of_constr env sigma term + + +(* store all equalities from the context *) + +let rec make_prb gls depth additionnal_terms = + let env=pf_env gls in + let sigma=sig_sig gls in + let state = empty depth gls in + let pos_hyps = ref [] in + let neg_hyps =ref [] in + List.iter + (fun c -> + let t = decompose_term env sigma c in + ignore (add_term state t)) additionnal_terms; + List.iter + (fun (id,_,e) -> + begin + let cid=mkVar id in + match litteral_of_constr env sigma e with + `Eq (t,a,b) -> add_equality state cid a b + | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b + | `Other ph -> + List.iter + (fun (cidn,nh) -> + add_disequality state (HeqnH (cid,cidn)) ph nh) + !neg_hyps; + pos_hyps:=(cid,ph):: !pos_hyps + | `Nother nh -> + List.iter + (fun (cidp,ph) -> + add_disequality state (HeqnH (cidp,cid)) ph nh) + !pos_hyps; + neg_hyps:=(cid,nh):: !neg_hyps + | `Rule patts -> add_quant state id true patts + | `Nrule patts -> add_quant state id false patts + end) (Environ.named_context_of_val gls.it.evar_hyps); + begin + match atom_of_constr env sigma gls.it.evar_concl with + `Eq (t,a,b) -> add_disequality state Goal a b + | `Other g -> + List.iter + (fun (idp,ph) -> + add_disequality state (HeqG idp) ph g) !pos_hyps + end; + state + +(* indhyps builds the array of arrays of constructor hyps for (ind largs) *) + +let build_projection intype outtype (cstr:constructor) special default gls= + let env=pf_env gls in + let (h,argv) = + try destApp intype with + Invalid_argument _ -> (intype,[||]) in + let ind=destInd h in + let types=Inductiveops.arities_of_constructors env ind in + let lp=Array.length types in + let ci=pred (snd cstr) in + let branch i= + let ti=Term.prod_appvect types.(i) argv in + let rc=fst (decompose_prod_assum ti) in + let head= + if i=ci then special else default in + it_mkLambda_or_LetIn head rc in + let branches=Array.init lp branch in + let casee=mkRel 1 in + let pred=mkLambda(Anonymous,intype,outtype) in + let case_info=make_case_info (pf_env gls) ind RegularStyle in + let body= mkCase(case_info, pred, casee, branches) in + let id=pf_get_new_id (id_of_string "t") gls in + mkLambda(Name id,intype,body) + +(* generate an adhoc tactic following the proof tree *) + +let _M =mkMeta + +let rec proof_tac p gls = + match p.p_rule with + Ax c -> exact_check c gls + | SymAx c -> + let l=constr_of_term p.p_lhs and + r=constr_of_term p.p_rhs in + let typ = refresh_universes (pf_type_of gls l) in + exact_check + (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls + | Refl t -> + let lr = constr_of_term t in + let typ = refresh_universes (pf_type_of gls lr) in + exact_check + (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls + | Trans (p1,p2)-> + let t1 = constr_of_term p1.p_lhs and + t2 = constr_of_term p1.p_rhs and + t3 = constr_of_term p2.p_rhs in + let typ = refresh_universes (pf_type_of gls t2) in + let prf = + mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in + tclTHENS (refine prf) [(proof_tac p1);(proof_tac p2)] gls + | Congr (p1,p2)-> + let tf1=constr_of_term p1.p_lhs + and tx1=constr_of_term p2.p_lhs + and tf2=constr_of_term p1.p_rhs + and tx2=constr_of_term p2.p_rhs in + let typf = refresh_universes (pf_type_of gls tf1) in + let typx = refresh_universes (pf_type_of gls tx1) in + let typfx = refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in + let id = pf_get_new_id (id_of_string "f") gls in + let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in + let lemma1 = + mkApp(Lazy.force _f_equal, + [|typf;typfx;appx1;tf1;tf2;_M 1|]) in + let lemma2= + mkApp(Lazy.force _f_equal, + [|typx;typfx;tf2;tx1;tx2;_M 1|]) in + let prf = + mkApp(Lazy.force _trans_eq, + [|typfx; + mkApp(tf1,[|tx1|]); + mkApp(tf2,[|tx1|]); + mkApp(tf2,[|tx2|]);_M 2;_M 3|]) in + tclTHENS (refine prf) + [tclTHEN (refine lemma1) (proof_tac p1); + tclFIRST + [tclTHEN (refine lemma2) (proof_tac p2); + reflexivity; + fun gls -> + errorlabstrm "Congruence" + (Pp.str + "I don't know how to handle dependent equality")]] gls + | Inject (prf,cstr,nargs,argind) -> + let ti=constr_of_term prf.p_lhs in + let tj=constr_of_term prf.p_rhs in + let default=constr_of_term p.p_lhs in + let intype=refresh_universes (pf_type_of gls ti) in + let outtype=refresh_universes (pf_type_of gls default) in + let special=mkRel (1+nargs-argind) in + let proj=build_projection intype outtype cstr special default gls in + let injt= + mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in + tclTHEN (refine injt) (proof_tac prf) gls + +let refute_tac c t1 t2 p gls = + let tt1=constr_of_term t1 and tt2=constr_of_term t2 in + let intype=refresh_universes (pf_type_of gls tt1) in + let neweq= + mkApp(Lazy.force _eq, + [|intype;tt1;tt2|]) in + let hid=pf_get_new_id (id_of_string "Heq") gls in + let false_t=mkApp (c,[|mkVar hid|]) in + tclTHENS (assert_tac (Name hid) neweq) + [proof_tac p; simplest_elim false_t] gls + +let convert_to_goal_tac c t1 t2 p gls = + let tt1=constr_of_term t1 and tt2=constr_of_term t2 in + let sort=refresh_universes (pf_type_of gls tt2) in + let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in + let e=pf_get_new_id (id_of_string "e") gls in + let x=pf_get_new_id (id_of_string "X") gls in + let identity=mkLambda (Name x,sort,mkRel 1) in + let endt=mkApp (Lazy.force _eq_rect, + [|sort;tt1;identity;c;tt2;mkVar e|]) in + tclTHENS (assert_tac (Name e) neweq) + [proof_tac p;exact_check endt] gls + +let convert_to_hyp_tac c1 t1 c2 t2 p gls = + let tt2=constr_of_term t2 in + let h=pf_get_new_id (id_of_string "H") gls in + let false_t=mkApp (c2,[|mkVar h|]) in + tclTHENS (assert_tac (Name h) tt2) + [convert_to_goal_tac c1 t1 t2 p; + simplest_elim false_t] gls + +let discriminate_tac cstr p gls = + let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in + let intype=refresh_universes (pf_type_of gls t1) in + let concl=pf_concl gls in + let outsort=mkType (new_univ ()) in + let xid=pf_get_new_id (id_of_string "X") gls in + let tid=pf_get_new_id (id_of_string "t") gls in + let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in + let trivial=pf_type_of gls identity in + let outtype=mkType (new_univ ()) in + let pred=mkLambda(Name xid,outtype,mkRel 1) in + let hid=pf_get_new_id (id_of_string "Heq") gls in + let proj=build_projection intype outtype cstr trivial concl gls in + let injt=mkApp (Lazy.force _f_equal, + [|intype;outtype;proj;t1;t2;mkVar hid|]) in + let endt=mkApp (Lazy.force _eq_rect, + [|outtype;trivial;pred;identity;concl;injt|]) in + let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in + tclTHENS (assert_tac (Name hid) neweq) + [proof_tac p;exact_check endt] gls + +(* wrap everything *) + +let build_term_to_complete uf meta pac = + let cinfo = get_constructor_info uf pac.cnode in + let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in + let dummy_args = List.rev (list_tabulate meta pac.arity) in + let all_args = List.rev_append real_args dummy_args in + applistc (mkConstruct cinfo.ci_constr) all_args + +let cc_tactic depth additionnal_terms gls= + Coqlib.check_required_library ["Coq";"Init";"Logic"]; + let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in + let state = make_prb gls depth additionnal_terms in + let _ = debug Pp.msgnl (Pp.str "Problem built, solving ...") in + let sol = execute true state in + let _ = debug Pp.msgnl (Pp.str "Computation completed.") in + let uf=forest state in + match sol with + None -> tclFAIL 0 (str "congruence failed") gls + | Some reason -> + debug Pp.msgnl (Pp.str "Goal solved, generating proof ..."); + match reason with + Discrimination (i,ipac,j,jpac) -> + let p=build_proof uf (`Discr (i,ipac,j,jpac)) in + let cstr=(get_constructor_info uf ipac.cnode).ci_constr in + discriminate_tac cstr p gls + | Incomplete -> + let metacnt = ref 0 in + let newmeta _ = incr metacnt; _M !metacnt in + let terms_to_complete = + List.map + (build_term_to_complete uf newmeta) + (epsilons uf) in + Pp.msgnl + (Pp.str "Goal is solvable by congruence but \ + some arguments are missing."); + Pp.msgnl + (Pp.str " Try " ++ + hov 8 + begin + str "\"congruence with (" ++ + prlist_with_sep + (fun () -> str ")" ++ pr_spc () ++ str "(") + (print_constr_env (pf_env gls)) + terms_to_complete ++ + str ")\"," + end); + Pp.msgnl + (Pp.str " replacing metavariables by arbitrary terms."); + tclFAIL 0 (str "Incomplete") gls + | Contradiction dis -> + let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in + let ta=term uf dis.lhs and tb=term uf dis.rhs in + match dis.rule with + Goal -> proof_tac p gls + | Hyp id -> refute_tac id ta tb p gls + | HeqG id -> + convert_to_goal_tac id ta tb p gls + | HeqnH (ida,idb) -> + convert_to_hyp_tac ida ta idb tb p gls + + +let cc_fail gls = + errorlabstrm "Congruence" (Pp.str "congruence failed.") + +let congruence_tac depth l = + tclORELSE + (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) + cc_fail + +(* Beware: reflexivity = constructor 1 = apply refl_equal + might be slow now, let's rather do something equivalent + to a "simple apply refl_equal" *) + +let simple_reflexivity () = apply (Lazy.force _refl_equal) + +(* The [f_equal] tactic. + + It mimics the use of lemmas [f_equal], [f_equal2], etc. + This isn't particularly related with congruence, apart from + the fact that congruence is called internally. +*) + +let f_equal gl = + let cut_eq c1 c2 = + let ty = refresh_universes (pf_type_of gl c1) in + tclTHENTRY + (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) + (simple_reflexivity ()) + in + try match kind_of_term (pf_concl gl) with + | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) -> + begin match kind_of_term t, kind_of_term t' with + | App (f,v), App (f',v') when Array.length v = Array.length v' -> + let rec cuts i = + if i < 0 then tclTRY (congruence_tac 1000 []) + else tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1)) + in cuts (Array.length v - 1) gl + | _ -> tclIDTAC gl + end + | _ -> tclIDTAC gl + with Type_errors.TypeError _ -> tclIDTAC gl diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli new file mode 100644 index 00000000..7ed077bd --- /dev/null +++ b/plugins/cc/cctac.mli @@ -0,0 +1,22 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Proof_type.tactic + +val cc_tactic : int -> constr list -> tactic + +val cc_fail : tactic + +val congruence_tac : int -> constr list -> tactic + +val f_equal : tactic diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 new file mode 100644 index 00000000..d9db927a --- /dev/null +++ b/plugins/cc/g_congruence.ml4 @@ -0,0 +1,29 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ congruence_tac 1000 [] ] + |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] + |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ] + |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> + [ congruence_tac n l ] +END + +TACTIC EXTEND f_equal + [ "f_equal" ] -> [ f_equal ] +END diff --git a/plugins/dp/Dp.v b/plugins/dp/Dp.v new file mode 100644 index 00000000..bc7d73f6 --- /dev/null +++ b/plugins/dp/Dp.v @@ -0,0 +1,120 @@ +(* Calls to external decision procedures *) + +Require Export ZArith. +Require Export Classical. + +(* Zenon *) + +(* Copyright 2004 INRIA *) +(* $Id$ *) + +Lemma zenon_nottrue : + (~True -> False). +Proof. tauto. Qed. + +Lemma zenon_noteq : forall (T : Type) (t : T), + ((t <> t) -> False). +Proof. tauto. Qed. + +Lemma zenon_and : forall P Q : Prop, + (P -> Q -> False) -> (P /\ Q -> False). +Proof. tauto. Qed. + +Lemma zenon_or : forall P Q : Prop, + (P -> False) -> (Q -> False) -> (P \/ Q -> False). +Proof. tauto. Qed. + +Lemma zenon_imply : forall P Q : Prop, + (~P -> False) -> (Q -> False) -> ((P -> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_equiv : forall P Q : Prop, + (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notand : forall P Q : Prop, + (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notor : forall P Q : Prop, + (~P -> ~Q -> False) -> (~(P \/ Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notimply : forall P Q : Prop, + (P -> ~Q -> False) -> (~(P -> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notequiv : forall P Q : Prop, + (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_ex : forall (T : Type) (P : T -> Prop), + (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False). +Proof. firstorder. Qed. + +Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T), + ((P t) -> False) -> ((forall x : T, (P x)) -> False). +Proof. firstorder. Qed. + +Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T), + (~(P t) -> False) -> (~(exists x : T, (P x)) -> False). +Proof. firstorder. Qed. + +Lemma zenon_notall : forall (T : Type) (P : T -> Prop), + (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False). +Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed. + +Lemma zenon_equal_base : forall (T : Type) (f : T), f = f. +Proof. auto. Qed. + +Lemma zenon_equal_step : + forall (S T : Type) (fa fb : S -> T) (a b : S), + (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)). +Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed. + +Lemma zenon_pnotp : forall P Q : Prop, + (P = Q) -> (P -> ~Q -> False). +Proof. intros P Q Ha. rewrite Ha. auto. Qed. + +Lemma zenon_notequal : forall (T : Type) (a b : T), + (a = b) -> (a <> b -> False). +Proof. auto. Qed. + +Ltac zenon_intro id := + intro id || let nid := fresh in (intro nid; clear nid) +. + +Definition zenon_and_s := fun P Q a b => zenon_and P Q b a. +Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a. +Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a. +Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a. +Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a. +Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a. +Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a. +Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a. +Definition zenon_ex_s := fun T P a b => zenon_ex T P b a. +Definition zenon_notall_s := fun T P a b => zenon_notall T P b a. + +Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b. +Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x. + +(* Ergo *) + +Set Implicit Arguments. +Section congr. + Variable t:Type. +Lemma ergo_eq_concat_1 : + forall (P:t -> Prop) (x y:t), + P x -> x = y -> P y. +Proof. + intros; subst; auto. +Qed. + +Lemma ergo_eq_concat_2 : + forall (P:t -> t -> Prop) (x1 x2 y1 y2:t), + P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2. +Proof. + intros; subst; auto. +Qed. + +End congr. diff --git a/plugins/dp/TODO b/plugins/dp/TODO new file mode 100644 index 00000000..44349e21 --- /dev/null +++ b/plugins/dp/TODO @@ -0,0 +1,24 @@ + +TODO +---- + +- axiomes pour les prédicats récursifs comme + + Fixpoint even (n:nat) : Prop := + match n with + O => True + | S O => False + | S (S p) => even p + end. + + ou encore In sur les listes du module Coq List. + +- discriminate + +- inversion (Set et Prop) + + +BUGS +---- + + diff --git a/plugins/dp/dp.ml b/plugins/dp/dp.ml new file mode 100644 index 00000000..34b32c0a --- /dev/null +++ b/plugins/dp/dp.ml @@ -0,0 +1,1134 @@ +(* Authors: Nicolas Ayache and Jean-Christophe Filliâtre *) +(* Tactics to call decision procedures *) + +(* Works in two steps: + + - first the Coq context and the current goal are translated in + Polymorphic First-Order Logic (see fol.mli in this directory) + + - then the resulting query is passed to the Why tool that translates + it to the syntax of the selected prover (Simplify, CVC Lite, haRVey, + Zenon) +*) + +open Util +open Pp +open Libobject +open Summary +open Term +open Tacmach +open Tactics +open Tacticals +open Fol +open Names +open Nameops +open Namegen +open Termops +open Coqlib +open Hipattern +open Libnames +open Declarations +open Dp_why + +let debug = ref false +let set_debug b = debug := b +let trace = ref false +let set_trace b = trace := b +let timeout = ref 10 +let set_timeout n = timeout := n + +let (dp_timeout_obj,_) = + declare_object + {(default_object "Dp_timeout") with + cache_function = (fun (_,x) -> set_timeout x); + load_function = (fun _ (_,x) -> set_timeout x)} + +let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x) + +let (dp_debug_obj,_) = + declare_object + {(default_object "Dp_debug") with + cache_function = (fun (_,x) -> set_debug x); + load_function = (fun _ (_,x) -> set_debug x)} + +let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x) + +let (dp_trace_obj,_) = + declare_object + {(default_object "Dp_trace") with + cache_function = (fun (_,x) -> set_trace x); + load_function = (fun _ (_,x) -> set_trace x)} + +let dp_trace x = Lib.add_anonymous_leaf (dp_trace_obj x) + +let logic_dir = ["Coq";"Logic";"Decidable"] +let coq_modules = + init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules + @ [["Coq"; "ZArith"; "BinInt"]; + ["Coq"; "Reals"; "Rdefinitions"]; + ["Coq"; "Reals"; "Raxioms";]; + ["Coq"; "Reals"; "Rbasic_fun";]; + ["Coq"; "Reals"; "R_sqrt";]; + ["Coq"; "Reals"; "Rfunctions";]] + @ [["Coq"; "omega"; "OmegaLemmas"]] + +let constant = gen_constant_in_modules "dp" coq_modules + +(* integers constants and operations *) +let coq_Z = lazy (constant "Z") +let coq_Zplus = lazy (constant "Zplus") +let coq_Zmult = lazy (constant "Zmult") +let coq_Zopp = lazy (constant "Zopp") +let coq_Zminus = lazy (constant "Zminus") +let coq_Zdiv = lazy (constant "Zdiv") +let coq_Zs = lazy (constant "Zs") +let coq_Zgt = lazy (constant "Zgt") +let coq_Zle = lazy (constant "Zle") +let coq_Zge = lazy (constant "Zge") +let coq_Zlt = lazy (constant "Zlt") +let coq_Z0 = lazy (constant "Z0") +let coq_Zpos = lazy (constant "Zpos") +let coq_Zneg = lazy (constant "Zneg") +let coq_xH = lazy (constant "xH") +let coq_xI = lazy (constant "xI") +let coq_xO = lazy (constant "xO") +let coq_iff = lazy (constant "iff") + +(* real constants and operations *) +let coq_R = lazy (constant "R") +let coq_R0 = lazy (constant "R0") +let coq_R1 = lazy (constant "R1") +let coq_Rgt = lazy (constant "Rgt") +let coq_Rle = lazy (constant "Rle") +let coq_Rge = lazy (constant "Rge") +let coq_Rlt = lazy (constant "Rlt") +let coq_Rplus = lazy (constant "Rplus") +let coq_Rmult = lazy (constant "Rmult") +let coq_Ropp = lazy (constant "Ropp") +let coq_Rminus = lazy (constant "Rminus") +let coq_Rdiv = lazy (constant "Rdiv") +let coq_powerRZ = lazy (constant "powerRZ") + +(* not Prop typed expressions *) +exception NotProp + +(* not first-order expressions *) +exception NotFO + +(* Renaming of Coq globals *) + +let global_names = Hashtbl.create 97 +let used_names = Hashtbl.create 97 + +let rename_global r = + try + Hashtbl.find global_names r + with Not_found -> + let rec loop id = + if Hashtbl.mem used_names id then + loop (lift_subscript id) + else begin + Hashtbl.add used_names id (); + let s = string_of_id id in + Hashtbl.add global_names r s; + s + end + in + loop (Nametab.basename_of_global r) + +let foralls = + List.fold_right + (fun (x,t) p -> Forall (x, t, p)) + +let fresh_var = function + | Anonymous -> rename_global (VarRef (id_of_string "x")) + | Name x -> rename_global (VarRef x) + +(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of + env names, and returns the new variables together with the new + environment *) +let coq_rename_vars env vars = + let avoid = ref (ids_of_named_context (Environ.named_context env)) in + List.fold_right + (fun (na,t) (newvars, newenv) -> + let id = next_name_away na !avoid in + avoid := id :: !avoid; + id :: newvars, Environ.push_named (id, None, t) newenv) + vars ([],env) + +(* extract the prenex type quantifications i.e. + type_quantifiers env (A1:Set)...(Ak:Set)t = A1...An, (env+Ai), t *) +let decomp_type_quantifiers env t = + let rec loop vars t = match kind_of_term t with + | Prod (n, a, t) when is_Set a || is_Type a -> + loop ((n,a) :: vars) t + | _ -> + let vars, env = coq_rename_vars env vars in + let t = substl (List.map mkVar vars) t in + List.rev vars, env, t + in + loop [] t + +(* same thing with lambda binders (for axiomatize body) *) +let decomp_type_lambdas env t = + let rec loop vars t = match kind_of_term t with + | Lambda (n, a, t) when is_Set a || is_Type a -> + loop ((n,a) :: vars) t + | _ -> + let vars, env = coq_rename_vars env vars in + let t = substl (List.map mkVar vars) t in + List.rev vars, env, t + in + loop [] t + +let decompose_arrows = + let rec arrows_rec l c = match kind_of_term c with + | Prod (_,t,c) when not (dependent (mkRel 1) c) -> arrows_rec (t :: l) c + | Cast (c,_,_) -> arrows_rec l c + | _ -> List.rev l, c + in + arrows_rec [] + +let rec eta_expanse t vars env i = + assert (i >= 0); + if i = 0 then + t, vars, env + else + match kind_of_term (Typing.type_of env Evd.empty t) with + | Prod (n, a, b) when not (dependent (mkRel 1) b) -> + let avoid = ids_of_named_context (Environ.named_context env) in + let id = next_name_away n avoid in + let env' = Environ.push_named (id, None, a) env in + let t' = mkApp (t, [| mkVar id |]) in + eta_expanse t' (id :: vars) env' (pred i) + | _ -> + assert false + +let rec skip_k_args k cl = match k, cl with + | 0, _ -> cl + | _, _ :: cl -> skip_k_args (k-1) cl + | _, [] -> raise NotFO + +(* Coq global references *) + +type global = Gnot_fo | Gfo of Fol.decl + +let globals = ref Refmap.empty +let globals_stack = ref [] + +(* synchronization *) +let () = + Summary.declare_summary "Dp globals" + { Summary.freeze_function = (fun () -> !globals, !globals_stack); + Summary.unfreeze_function = + (fun (g,s) -> globals := g; globals_stack := s); + Summary.init_function = (fun () -> ()) } + +let add_global r d = globals := Refmap.add r d !globals +let mem_global r = Refmap.mem r !globals +let lookup_global r = match Refmap.find r !globals with + | Gnot_fo -> raise NotFO + | Gfo d -> d + +let locals = Hashtbl.create 97 + +let lookup_local r = match Hashtbl.find locals r with + | Gnot_fo -> raise NotFO + | Gfo d -> d + +let iter_all_constructors i f = + let _, oib = Global.lookup_inductive i in + Array.iteri + (fun j tj -> f j (mkConstruct (i, j+1))) + oib.mind_nf_lc + + +(* injection c [t1,...,tn] adds the injection axiom + forall x1:t1,...,xn:tn,y1:t1,...,yn:tn. + c(x1,...,xn)=c(y1,...,yn) -> x1=y1 /\ ... /\ xn=yn *) + +let injection c l = + let i = ref 0 in + let var s = incr i; id_of_string (s ^ string_of_int !i) in + let xl = List.map (fun t -> rename_global (VarRef (var "x")), t) l in + i := 0; + let yl = List.map (fun t -> rename_global (VarRef (var "y")), t) l in + let f = + List.fold_right2 + (fun (x,_) (y,_) p -> And (Fatom (Eq (App (x,[]),App (y,[]))), p)) + xl yl True + in + let vars = List.map (fun (x,_) -> App(x,[])) in + let f = Imp (Fatom (Eq (App (c, vars xl), App (c, vars yl))), f) in + let foralls = List.fold_right (fun (x,t) p -> Forall (x, t, p)) in + let f = foralls xl (foralls yl f) in + let ax = Axiom ("injection_" ^ c, f) in + globals_stack := ax :: !globals_stack + +(* rec_names_for c [|n1;...;nk|] builds the list of constant names for + identifiers n1...nk with the same path as c, if they exist; otherwise + raises Not_found *) +let rec_names_for c = + let mp,dp,_ = Names.repr_con c in + array_map_to_list + (function + | Name id -> + let c' = Names.make_con mp dp (label_of_id id) in + ignore (Global.lookup_constant c'); + msgnl (Printer.pr_constr (mkConst c')); + c' + | Anonymous -> + raise Not_found) + +(* abstraction tables *) + +let term_abstractions = Hashtbl.create 97 + +let new_abstraction = + let r = ref 0 in fun () -> incr r; "abstraction_" ^ string_of_int !r + +(* Arithmetic constants *) + +exception NotArithConstant + +(* translates a closed Coq term p:positive into a FOL term of type int *) + +let big_two = Big_int.succ_big_int Big_int.unit_big_int + +let rec tr_positive p = match kind_of_term p with + | Term.Construct _ when p = Lazy.force coq_xH -> + Big_int.unit_big_int + | Term.App (f, [|a|]) when f = Lazy.force coq_xI -> +(* + Plus (Mult (Cst 2, tr_positive a), Cst 1) +*) + Big_int.succ_big_int (Big_int.mult_big_int big_two (tr_positive a)) + | Term.App (f, [|a|]) when f = Lazy.force coq_xO -> +(* + Mult (Cst 2, tr_positive a) +*) + Big_int.mult_big_int big_two (tr_positive a) + | Term.Cast (p, _, _) -> + tr_positive p + | _ -> + raise NotArithConstant + +(* translates a closed Coq term t:Z or R into a FOL term of type int or real *) +let rec tr_arith_constant t = match kind_of_term t with + | Term.Construct _ when t = Lazy.force coq_Z0 -> + Cst Big_int.zero_big_int + | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> + Cst (tr_positive a) + | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> + Cst (Big_int.minus_big_int (tr_positive a)) + | Term.Const _ when t = Lazy.force coq_R0 -> + RCst Big_int.zero_big_int + | Term.Const _ when t = Lazy.force coq_R1 -> + RCst Big_int.unit_big_int + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus -> + let ta = tr_arith_constant a in + let tb = tr_arith_constant b in + begin match ta,tb with + | RCst na, RCst nb -> RCst (Big_int.add_big_int na nb) + | _ -> raise NotArithConstant + end + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult -> + let ta = tr_arith_constant a in + let tb = tr_arith_constant b in + begin match ta,tb with + | RCst na, RCst nb -> RCst (Big_int.mult_big_int na nb) + | _ -> raise NotArithConstant + end + | Term.App (f, [|a;b|]) when f = Lazy.force coq_powerRZ -> + tr_powerRZ a b + | Term.Cast (t, _, _) -> + tr_arith_constant t + | _ -> + raise NotArithConstant + +(* translates a constant of the form (powerRZ 2 int_constant) *) +and tr_powerRZ a b = + (* checking first that a is (R1 + R1) *) + match kind_of_term a with + | Term.App (f, [|c;d|]) when f = Lazy.force coq_Rplus -> + begin + match kind_of_term c,kind_of_term d with + | Term.Const _, Term.Const _ + when c = Lazy.force coq_R1 && d = Lazy.force coq_R1 -> + begin + match tr_arith_constant b with + | Cst n -> Power2 n + | _ -> raise NotArithConstant + end + | _ -> raise NotArithConstant + end + | _ -> raise NotArithConstant + + +(* translate a Coq term t:Set into a FOL type expression; + tv = list of type variables *) +and tr_type tv env t = + let t = Reductionops.nf_betadeltaiota env Evd.empty t in + if t = Lazy.force coq_Z then + Tid ("int", []) + else if t = Lazy.force coq_R then + Tid ("real", []) + else match kind_of_term t with + | Var x when List.mem x tv -> + Tvar (string_of_id x) + | _ -> + let f, cl = decompose_app t in + begin try + let r = global_of_constr f in + match tr_global env r with + | DeclType (id, k) -> + assert (k = List.length cl); (* since t:Set *) + Tid (id, List.map (tr_type tv env) cl) + | _ -> + raise NotFO + with + | Not_found -> + raise NotFO + | NotFO -> + (* we need to abstract some part of (f cl) *) + (*TODO*) + raise NotFO + end + +and make_term_abstraction tv env c = + let ty = Typing.type_of env Evd.empty c in + let id = new_abstraction () in + match tr_decl env id ty with + | DeclFun (id,_,_,_) as _d -> + raise NotFO + (* [CM 07/09/2009] deactivated because it generates + unbound identifiers 'abstraction_' + begin try + Hashtbl.find term_abstractions c + with Not_found -> + Hashtbl.add term_abstractions c id; + globals_stack := d :: !globals_stack; + id + end + *) + | _ -> + raise NotFO + +(* translate a Coq declaration id:ty in a FOL declaration, that is either + - a type declaration : DeclType (id, n) where n:int is the type arity + - a function declaration : DeclFun (id, tl, t) ; that includes constants + - a predicate declaration : DeclPred (id, tl) + - an axiom : Axiom (id, p) + *) +and tr_decl env id ty = + let tv, env, t = decomp_type_quantifiers env ty in + if is_Set t || is_Type t then + DeclType (id, List.length tv) + else if is_Prop t then + DeclPred (id, List.length tv, []) + else + let s = Typing.type_of env Evd.empty t in + if is_Prop s then + Axiom (id, tr_formula tv [] env t) + else + let l, t = decompose_arrows t in + let l = List.map (tr_type tv env) l in + if is_Prop t then + DeclPred(id, List.length tv, l) + else + let s = Typing.type_of env Evd.empty t in + if is_Set s || is_Type s then + DeclFun (id, List.length tv, l, tr_type tv env t) + else + raise NotFO + +(* tr_global(r) = tr_decl(id(r),typeof(r)) + a cache mechanism *) +and tr_global env r = match r with + | VarRef id -> + lookup_local id + | r -> + try + lookup_global r + with Not_found -> + try + let ty = Global.type_of_global r in + let id = rename_global r in + let d = tr_decl env id ty in + (* r can be already declared if it is a constructor *) + if not (mem_global r) then begin + add_global r (Gfo d); + globals_stack := d :: !globals_stack + end; + begin try axiomatize_body env r id d with NotFO -> () end; + d + with NotFO -> + add_global r Gnot_fo; + raise NotFO + +and axiomatize_body env r id d = match r with + | VarRef _ -> + assert false + | ConstRef c -> + begin match (Global.lookup_constant c).const_body with + | Some b -> + let b = force b in + let axioms = + (match d with + | DeclPred (id, _, []) -> + let tv, env, b = decomp_type_lambdas env b in + let value = tr_formula tv [] env b in + [id, Iff (Fatom (Pred (id, [])), value)] + | DeclFun (id, _, [], _) -> + let tv, env, b = decomp_type_lambdas env b in + let value = tr_term tv [] env b in + [id, Fatom (Eq (Fol.App (id, []), value))] + | DeclFun (id, _, l, _) | DeclPred (id, _, l) -> + (*Format.eprintf "axiomatize_body %S@." id;*) + let b = match kind_of_term b with + (* a single recursive function *) + | Fix (_, (_,_,[|b|])) -> + subst1 (mkConst c) b + (* mutually recursive functions *) + | Fix ((_,i), (names,_,bodies)) -> + (* we only deal with named functions *) + begin try + let l = rec_names_for c names in + substl (List.rev_map mkConst l) bodies.(i) + with Not_found -> + b + end + | _ -> + b + in + let tv, env, b = decomp_type_lambdas env b in + let vars, t = decompose_lam b in + let n = List.length l in + let k = List.length vars in + assert (k <= n); + let vars, env = coq_rename_vars env vars in + let t = substl (List.map mkVar vars) t in + let t, vars, env = eta_expanse t vars env (n-k) in + let vars = List.rev vars in + let bv = vars in + let vars = List.map (fun x -> string_of_id x) vars in + let fol_var x = Fol.App (x, []) in + let fol_vars = List.map fol_var vars in + let vars = List.combine vars l in + begin match d with + | DeclFun (_, _, _, ty) -> + begin match kind_of_term t with + | Case (ci, _, e, br) -> + equations_for_case env id vars tv bv ci e br + | _ -> + let t = tr_term tv bv env t in + let ax = + add_proof (Fun_def (id, vars, ty, t)) + in + let p = Fatom (Eq (App (id, fol_vars), t)) in + [ax, foralls vars p] + end + | DeclPred _ -> + let value = tr_formula tv bv env t in + let p = Iff (Fatom (Pred (id, fol_vars)), value) in + [id, foralls vars p] + | _ -> + assert false + end + | DeclType _ -> + raise NotFO + | Axiom _ -> assert false) + in + let axioms = List.map (fun (id,ax) -> Axiom (id, ax)) axioms in + globals_stack := axioms @ !globals_stack + | None -> + () (* Coq axiom *) + end + | IndRef i -> + iter_all_constructors i + (fun _ c -> + let rc = global_of_constr c in + try + begin match tr_global env rc with + | DeclFun (_, _, [], _) -> () + | DeclFun (idc, _, al, _) -> injection idc al + | _ -> () + end + with NotFO -> + ()) + | _ -> () + +and equations_for_case env id vars tv bv ci e br = match kind_of_term e with + | Var x when List.exists (fun (y, _) -> string_of_id x = y) vars -> + let eqs = ref [] in + iter_all_constructors ci.ci_ind + (fun j cj -> + try + let cjr = global_of_constr cj in + begin match tr_global env cjr with + | DeclFun (idc, _, l, _) -> + let b = br.(j) in + let rec_vars, b = decompose_lam b in + let rec_vars, env = coq_rename_vars env rec_vars in + let coq_rec_vars = List.map mkVar rec_vars in + let b = substl coq_rec_vars b in + let rec_vars = List.rev rec_vars in + let coq_rec_term = applist (cj, List.rev coq_rec_vars) in + let b = replace_vars [x, coq_rec_term] b in + let bv = bv @ rec_vars in + let rec_vars = List.map string_of_id rec_vars in + let fol_var x = Fol.App (x, []) in + let fol_rec_vars = List.map fol_var rec_vars in + let fol_rec_term = App (idc, fol_rec_vars) in + let rec_vars = List.combine rec_vars l in + let fol_vars = List.map fst vars in + let fol_vars = List.map fol_var fol_vars in + let fol_vars = List.map (fun y -> match y with + | App (id, _) -> + if id = string_of_id x + then fol_rec_term + else y + | _ -> y) + fol_vars in + let vars = vars @ rec_vars in + let rec remove l e = match l with + | [] -> [] + | (y, t)::l' -> if y = string_of_id e then l' + else (y, t)::(remove l' e) in + let vars = remove vars x in + let p = + Fatom (Eq (App (id, fol_vars), + tr_term tv bv env b)) + in + eqs := (id ^ "_" ^ idc, foralls vars p) :: !eqs + | _ -> + assert false end + with NotFO -> + ()); + !eqs + | _ -> + raise NotFO + +(* assumption: t:T:Set *) +and tr_term tv bv env t = + try + tr_arith_constant t + with NotArithConstant -> + match kind_of_term t with + (* binary operations on integers *) + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus -> + Plus (tr_term tv bv env a, tr_term tv bv env b) + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus -> + Moins (tr_term tv bv env a, tr_term tv bv env b) + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult -> + Mult (tr_term tv bv env a, tr_term tv bv env b) + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv -> + Div (tr_term tv bv env a, tr_term tv bv env b) + | Term.App (f, [|a|]) when f = Lazy.force coq_Zopp -> + Opp (tr_term tv bv env a) + (* binary operations on reals *) + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus -> + Plus (tr_term tv bv env a, tr_term tv bv env b) + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rminus -> + Moins (tr_term tv bv env a, tr_term tv bv env b) + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult -> + Mult (tr_term tv bv env a, tr_term tv bv env b) + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rdiv -> + Div (tr_term tv bv env a, tr_term tv bv env b) + | Term.Var id when List.mem id bv -> + App (string_of_id id, []) + | _ -> + let f, cl = decompose_app t in + begin try + let r = global_of_constr f in + match tr_global env r with + | DeclFun (s, k, _, _) -> + let cl = skip_k_args k cl in + Fol.App (s, List.map (tr_term tv bv env) cl) + | _ -> + raise NotFO + with + | Not_found -> + raise NotFO + | NotFO -> (* we need to abstract some part of (f cl) *) + let rec abstract app = function + | [] -> + Fol.App (make_term_abstraction tv env app, []) + | x :: l as args -> + begin try + let s = make_term_abstraction tv env app in + Fol.App (s, List.map (tr_term tv bv env) args) + with NotFO -> + abstract (applist (app, [x])) l + end + in + let app,l = match cl with + | x :: l -> applist (f, [x]), l | [] -> raise NotFO + in + abstract app l + end + +and quantifiers n a b tv bv env = + let vars, env = coq_rename_vars env [n,a] in + let id = match vars with [x] -> x | _ -> assert false in + let b = subst1 (mkVar id) b in + let t = tr_type tv env a in + let bv = id :: bv in + id, t, bv, env, b + +(* assumption: f is of type Prop *) +and tr_formula tv bv env f = + let c, args = decompose_app f in + match kind_of_term c, args with + | Var id, [] -> + Fatom (Pred (rename_global (VarRef id), [])) + | _, [t;a;b] when c = build_coq_eq () -> + let ty = Typing.type_of env Evd.empty t in + if is_Set ty || is_Type ty then + let _ = tr_type tv env t in + Fatom (Eq (tr_term tv bv env a, tr_term tv bv env b)) + else + raise NotFO + (* comparisons on integers *) + | _, [a;b] when c = Lazy.force coq_Zle -> + Fatom (Le (tr_term tv bv env a, tr_term tv bv env b)) + | _, [a;b] when c = Lazy.force coq_Zlt -> + Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b)) + | _, [a;b] when c = Lazy.force coq_Zge -> + Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b)) + | _, [a;b] when c = Lazy.force coq_Zgt -> + Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b)) + (* comparisons on reals *) + | _, [a;b] when c = Lazy.force coq_Rle -> + Fatom (Le (tr_term tv bv env a, tr_term tv bv env b)) + | _, [a;b] when c = Lazy.force coq_Rlt -> + Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b)) + | _, [a;b] when c = Lazy.force coq_Rge -> + Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b)) + | _, [a;b] when c = Lazy.force coq_Rgt -> + Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b)) + | _, [] when c = build_coq_False () -> + False + | _, [] when c = build_coq_True () -> + True + | _, [a] when c = build_coq_not () -> + Not (tr_formula tv bv env a) + | _, [a;b] when c = build_coq_and () -> + And (tr_formula tv bv env a, tr_formula tv bv env b) + | _, [a;b] when c = build_coq_or () -> + Or (tr_formula tv bv env a, tr_formula tv bv env b) + | _, [a;b] when c = Lazy.force coq_iff -> + Iff (tr_formula tv bv env a, tr_formula tv bv env b) + | Prod (n, a, b), _ -> + if is_imp_term f then + Imp (tr_formula tv bv env a, tr_formula tv bv env b) + else + let id, t, bv, env, b = quantifiers n a b tv bv env in + Forall (string_of_id id, t, tr_formula tv bv env b) + | _, [_; a] when c = build_coq_ex () -> + begin match kind_of_term a with + | Lambda(n, a, b) -> + let id, t, bv, env, b = quantifiers n a b tv bv env in + Exists (string_of_id id, t, tr_formula tv bv env b) + | _ -> + (* unusual case of the shape (ex p) *) + raise NotFO (* TODO: we could eta-expanse *) + end + | _ -> + begin try + let r = global_of_constr c in + match tr_global env r with + | DeclPred (s, k, _) -> + let args = skip_k_args k args in + Fatom (Pred (s, List.map (tr_term tv bv env) args)) + | _ -> + raise NotFO + with Not_found -> + raise NotFO + end + + +let tr_goal gl = + Hashtbl.clear locals; + let tr_one_hyp (id, ty) = + try + let s = rename_global (VarRef id) in + let d = tr_decl (pf_env gl) s ty in + Hashtbl.add locals id (Gfo d); + d + with NotFO -> + Hashtbl.add locals id Gnot_fo; + raise NotFO + in + let hyps = + List.fold_right + (fun h acc -> try tr_one_hyp h :: acc with NotFO -> acc) + (pf_hyps_types gl) [] + in + let c = tr_formula [] [] (pf_env gl) (pf_concl gl) in + let hyps = List.rev_append !globals_stack (List.rev hyps) in + hyps, c + + +type prover = Simplify | Ergo | Yices | CVCLite | Harvey | Zenon | Gwhy | CVC3 | Z3 + +let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ()) + +let sprintf = Format.sprintf + +let file_contents f = + let buf = Buffer.create 1024 in + try + let c = open_in f in + begin try + while true do + let s = input_line c in Buffer.add_string buf s; + Buffer.add_char buf '\n' + done; + assert false + with End_of_file -> + close_in c; + Buffer.contents buf + end + with _ -> + sprintf "(cannot open %s)" f + +let timeout_sys_command cmd = + if !debug then Format.eprintf "command line: %s@." cmd; + let out = Filename.temp_file "out" "" in + let cmd = sprintf "why-cpulimit %d %s > %s 2>&1" !timeout cmd out in + let ret = Sys.command cmd in + if !debug then + Format.eprintf "Output file %s:@.%s@." out (file_contents out); + ret, out + +let timeout_or_failure c cmd out = + if c = 152 then + Timeout + else + Failure + (sprintf "command %s failed with output:\n%s " cmd (file_contents out)) + +let call_prover ?(opt="") file = + if !debug then Format.eprintf "calling prover on %s@." file; + let out = Filename.temp_file "out" "" in + let cmd = + sprintf "why-dp -timeout %d -batch %s > %s 2>&1" !timeout file out in + match Sys.command cmd with + 0 -> Valid None + | 1 -> Failure (sprintf "could not run why-dp\n%s" (file_contents out)) + | 2 -> Invalid + | 3 -> DontKnow + | 4 -> Timeout + | 5 -> Failure (sprintf "prover failed:\n%s" (file_contents out)) + | n -> Failure (sprintf "Unknown exit status of why-dp: %d" n) + +let prelude_files = ref ([] : string list) + +let set_prelude l = prelude_files := l + +let (dp_prelude_obj,_) = + declare_object + {(default_object "Dp_prelude") with + cache_function = (fun (_,x) -> set_prelude x); + load_function = (fun _ (_,x) -> set_prelude x)} + +let dp_prelude x = Lib.add_anonymous_leaf (dp_prelude_obj x) + +let why_files f = String.concat " " (!prelude_files @ [f]) + +let call_simplify fwhy = + let cmd = + sprintf "why --simplify %s" (why_files fwhy) + in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); + let fsx = Filename.chop_suffix fwhy ".why" ^ "_why.sx" in +(* + let cmd = + sprintf "why-cpulimit %d Simplify %s > out 2>&1 && grep -q -w Valid out" + !timeout fsx + in + let out = Sys.command cmd in + let r = + if out = 0 then Valid None else if out = 1 then Invalid else Timeout + in +*) + let r = call_prover fsx in + if not !debug then remove_files [fwhy; fsx]; + r + +let call_ergo fwhy = + let cmd = sprintf "why --alt-ergo %s" (why_files fwhy) in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); + let fwhy = Filename.chop_suffix fwhy ".why" ^ "_why.why" in + (*let ftrace = Filename.temp_file "ergo_trace" "" in*) + (*NB: why-dp can't handle -cctrace + let cmd = + if !trace then + sprintf "alt-ergo -cctrace %s %s" ftrace fwhy + + else + sprintf "alt-ergo %s" fwhy + in*) + let r = call_prover fwhy in + if not !debug then remove_files [fwhy; (*out*)]; + r + + +let call_zenon fwhy = + let cmd = + sprintf "why --no-zenon-prelude --zenon %s" (why_files fwhy) + in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); + let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in +(* why-dp won't let us having coqterm... + let out = Filename.temp_file "dp_out" "" in + let cmd = + sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out + in + let c = Sys.command cmd in + if not !debug then remove_files [fwhy; fznn]; + if c = 137 then + Timeout + else begin + if c <> 0 then anomaly ("command failed: " ^ cmd); + if Sys.command (sprintf "grep -q -w Error %s" out) = 0 then + error "Zenon failed"; + let c = Sys.command (sprintf "grep -q PROOF-FOUND %s" out) in + if c = 0 then Valid (Some out) else Invalid + end + *) + let r = call_prover fznn in + if not !debug then remove_files [fwhy; fznn]; + r + +let call_smt ~smt fwhy = + let cmd = + sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy) + in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); + let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in + let opt = "-smt-solver " ^ smt in + let r = call_prover ~opt fsmt in + if not !debug then remove_files [fwhy; fsmt]; + r + +(* +let call_yices fwhy = + let cmd = + sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy) + in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); + let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in + let cmd = + sprintf "why-cpulimit %d yices -pc 0 -smt %s > out 2>&1 && grep -q -w unsat out" + !timeout fsmt + in + let out = Sys.command cmd in + let r = + if out = 0 then Valid None else if out = 1 then Invalid else Timeout + in + if not !debug then remove_files [fwhy; fsmt]; + r + +let call_cvc3 fwhy = + let cmd = + sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy) + in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); + let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in + let cmd = + sprintf "why-cpulimit %d cvc3 -lang smt %s > out 2>&1 && grep -q -w unsat out" + !timeout fsmt + in + let out = Sys.command cmd in + let r = + if out = 0 then Valid None else if out = 1 then Invalid else Timeout + in + if not !debug then remove_files [fwhy; fsmt]; + r +*) + +let call_cvcl fwhy = + let cmd = + sprintf "why --cvcl --encoding sstrat %s" (why_files fwhy) + in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); + let fcvc = Filename.chop_suffix fwhy ".why" ^ "_why.cvc" in +(* + let cmd = + sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out" + !timeout fcvc + in + let out = Sys.command cmd in + let r = + if out = 0 then Valid None else if out = 1 then Invalid else Timeout + in +*) + let r = call_prover fcvc in + if not !debug then remove_files [fwhy; fcvc]; + r + +let call_harvey fwhy = + let cmd = + sprintf "why --harvey --encoding strat %s" (why_files fwhy) + in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); + let frv = Filename.chop_suffix fwhy ".why" ^ "_why.rv" in +(* + let out = Sys.command (sprintf "rvc -e -t %s > /dev/null 2>&1" frv) in + if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed"); + let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in + let outf = Filename.temp_file "rv" ".out" in + let out = + Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1" + !timeout f outf) + in + let r = + if out <> 0 then + Timeout + else + let cmd = + sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf + in + if Sys.command cmd = 0 then Valid None else Invalid + in + if not !debug then remove_files [fwhy; frv; outf]; +*) + let r = call_prover frv in + if not !debug then remove_files [fwhy; frv]; + r + +let call_gwhy fwhy = + let cmd = sprintf "gwhy %s" (why_files fwhy) in + if Sys.command cmd <> 0 then ignore (Sys.command (sprintf "emacs %s" fwhy)); + NoAnswer + +let ergo_proof_from_file f gl = + let s = + let buf = Buffer.create 1024 in + let c = open_in f in + try + while true do Buffer.add_string buf (input_line c) done; assert false + with End_of_file -> + close_in c; + Buffer.contents buf + in + let parsed_constr = Pcoq.parse_string Pcoq.Constr.constr s in + let t = Constrintern.interp_constr (project gl) (pf_env gl) parsed_constr in + exact_check t gl + +let call_prover prover q = + let fwhy = Filename.temp_file "coq_dp" ".why" in + Dp_why.output_file fwhy q; + match prover with + | Simplify -> call_simplify fwhy + | Ergo -> call_ergo fwhy + | CVC3 -> call_smt ~smt:"cvc3" fwhy + | Yices -> call_smt ~smt:"yices" fwhy + | Z3 -> call_smt ~smt:"z3" fwhy + | Zenon -> call_zenon fwhy + | CVCLite -> call_cvcl fwhy + | Harvey -> call_harvey fwhy + | Gwhy -> call_gwhy fwhy + +let dp prover gl = + Coqlib.check_required_library ["Coq";"ZArith";"ZArith"]; + let concl_type = pf_type_of gl (pf_concl gl) in + if not (is_Prop concl_type) then error "Conclusion is not a Prop"; + try + let q = tr_goal gl in + begin match call_prover prover q with + | Valid (Some f) when prover = Zenon -> Dp_zenon.proof_from_file f gl + | Valid (Some f) when prover = Ergo -> ergo_proof_from_file f gl + | Valid _ -> Tactics.admit_as_an_axiom gl + | Invalid -> error "Invalid" + | DontKnow -> error "Don't know" + | Timeout -> error "Timeout" + | Failure s -> error s + | NoAnswer -> Tacticals.tclIDTAC gl + end + with NotFO -> + error "Not a first order goal" + + +let simplify = tclTHEN intros (dp Simplify) +let ergo = tclTHEN intros (dp Ergo) +let cvc3 = tclTHEN intros (dp CVC3) +let yices = tclTHEN intros (dp Yices) +let z3 = tclTHEN intros (dp Z3) +let cvc_lite = tclTHEN intros (dp CVCLite) +let harvey = dp Harvey +let zenon = tclTHEN intros (dp Zenon) +let gwhy = tclTHEN intros (dp Gwhy) + +let dp_hint l = + let env = Global.env () in + let one_hint (qid,r) = + if not (mem_global r) then begin + let ty = Global.type_of_global r in + let s = Typing.type_of env Evd.empty ty in + if is_Prop s then + try + let id = rename_global r in + let tv, env, ty = decomp_type_quantifiers env ty in + let d = Axiom (id, tr_formula tv [] env ty) in + add_global r (Gfo d); + globals_stack := d :: !globals_stack + with NotFO -> + add_global r Gnot_fo; + msg_warning + (pr_reference qid ++ + str " ignored (not a first order proposition)") + else begin + add_global r Gnot_fo; + msg_warning + (pr_reference qid ++ str " ignored (not a proposition)") + end + end + in + List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l) + +let (dp_hint_obj,_) = + declare_object + {(default_object "Dp_hint") with + cache_function = (fun (_,l) -> dp_hint l); + load_function = (fun _ (_,l) -> dp_hint l)} + +let dp_hint l = Lib.add_anonymous_leaf (dp_hint_obj l) + +let dp_predefined qid s = + let r = Nametab.global qid in + let ty = Global.type_of_global r in + let env = Global.env () in + let id = rename_global r in + try + let d = match tr_decl env id ty with + | DeclType (_, n) -> DeclType (s, n) + | DeclFun (_, n, tyl, ty) -> DeclFun (s, n, tyl, ty) + | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl) + | Axiom _ as d -> d + in + match d with + | Axiom _ -> msg_warning (str " ignored (axiom)") + | d -> add_global r (Gfo d) + with NotFO -> + msg_warning (str " ignored (not a first order declaration)") + +let (dp_predefined_obj,_) = + declare_object + {(default_object "Dp_predefined") with + cache_function = (fun (_,(id,s)) -> dp_predefined id s); + load_function = (fun _ (_,(id,s)) -> dp_predefined id s)} + +let dp_predefined id s = Lib.add_anonymous_leaf (dp_predefined_obj (id,s)) + +let _ = declare_summary "Dp options" + { freeze_function = + (fun () -> !debug, !trace, !timeout, !prelude_files); + unfreeze_function = + (fun (d,tr,tm,pr) -> + debug := d; trace := tr; timeout := tm; prelude_files := pr); + init_function = + (fun () -> + debug := false; trace := false; timeout := 10; + prelude_files := []) } diff --git a/plugins/dp/dp.mli b/plugins/dp/dp.mli new file mode 100644 index 00000000..f40f8688 --- /dev/null +++ b/plugins/dp/dp.mli @@ -0,0 +1,20 @@ + +open Libnames +open Proof_type + +val simplify : tactic +val ergo : tactic +val cvc3 : tactic +val yices : tactic +val cvc_lite : tactic +val harvey : tactic +val zenon : tactic +val gwhy : tactic +val z3: tactic + +val dp_hint : reference list -> unit +val dp_timeout : int -> unit +val dp_debug : bool -> unit +val dp_trace : bool -> unit +val dp_prelude : string list -> unit +val dp_predefined : reference -> string -> unit diff --git a/plugins/dp/dp_plugin.mllib b/plugins/dp/dp_plugin.mllib new file mode 100644 index 00000000..63252d6a --- /dev/null +++ b/plugins/dp/dp_plugin.mllib @@ -0,0 +1,5 @@ +Dp_why +Dp_zenon +Dp +G_dp +Dp_plugin_mod diff --git a/plugins/dp/dp_why.ml b/plugins/dp/dp_why.ml new file mode 100644 index 00000000..9a62f39d --- /dev/null +++ b/plugins/dp/dp_why.ml @@ -0,0 +1,186 @@ + +(* Pretty-print PFOL (see fol.mli) in Why syntax *) + +open Format +open Fol + +type proof = + | Immediate of Term.constr + | Fun_def of string * (string * typ) list * typ * term + +let proofs = Hashtbl.create 97 +let proof_name = + let r = ref 0 in fun () -> incr r; "dp_axiom__" ^ string_of_int !r + +let add_proof pr = let n = proof_name () in Hashtbl.add proofs n pr; n + +let find_proof = Hashtbl.find proofs + +let rec print_list sep print fmt = function + | [] -> () + | [x] -> print fmt x + | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r + +let space fmt () = fprintf fmt "@ " +let comma fmt () = fprintf fmt ",@ " + +let is_why_keyword = + let h = Hashtbl.create 17 in + List.iter + (fun s -> Hashtbl.add h s ()) + ["absurd"; "and"; "array"; "as"; "assert"; "axiom"; "begin"; + "bool"; "do"; "done"; "else"; "end"; "exception"; "exists"; + "external"; "false"; "for"; "forall"; "fun"; "function"; "goal"; + "if"; "in"; "int"; "invariant"; "label"; "let"; "logic"; "not"; + "of"; "or"; "parameter"; "predicate"; "prop"; "raise"; "raises"; + "reads"; "real"; "rec"; "ref"; "returns"; "then"; "true"; "try"; + "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ]; + Hashtbl.mem h + +let ident fmt s = + if is_why_keyword s then fprintf fmt "coq__%s" s else fprintf fmt "%s" s + +let rec print_typ fmt = function + | Tvar x -> fprintf fmt "'%a" ident x + | Tid ("int", []) -> fprintf fmt "int" + | Tid ("real", []) -> fprintf fmt "real" + | Tid (x, []) -> fprintf fmt "%a" ident x + | Tid (x, [t]) -> fprintf fmt "%a %a" print_typ t ident x + | Tid (x,tl) -> fprintf fmt "(%a) %a" (print_list comma print_typ) tl ident x + +let print_arg fmt (id,typ) = fprintf fmt "%a: %a" ident id print_typ typ + +let rec print_term fmt = function + | Cst n -> + fprintf fmt "%s" (Big_int.string_of_big_int n) + | RCst s -> + fprintf fmt "%s.0" (Big_int.string_of_big_int s) + | Power2 n -> + fprintf fmt "0x1p%s" (Big_int.string_of_big_int n) + | Plus (a, b) -> + fprintf fmt "@[(%a +@ %a)@]" print_term a print_term b + | Moins (a, b) -> + fprintf fmt "@[(%a -@ %a)@]" print_term a print_term b + | Mult (a, b) -> + fprintf fmt "@[(%a *@ %a)@]" print_term a print_term b + | Div (a, b) -> + fprintf fmt "@[(%a /@ %a)@]" print_term a print_term b + | Opp (a) -> + fprintf fmt "@[(-@ %a)@]" print_term a + | App (id, []) -> + fprintf fmt "%a" ident id + | App (id, tl) -> + fprintf fmt "@[%a(%a)@]" ident id print_terms tl + +and print_terms fmt tl = + print_list comma print_term fmt tl + +let rec print_predicate fmt p = + let pp = print_predicate in + match p with + | True -> + fprintf fmt "true" + | False -> + fprintf fmt "false" + | Fatom (Eq (a, b)) -> + fprintf fmt "@[(%a =@ %a)@]" print_term a print_term b + | Fatom (Le (a, b)) -> + fprintf fmt "@[(%a <=@ %a)@]" print_term a print_term b + | Fatom (Lt (a, b))-> + fprintf fmt "@[(%a <@ %a)@]" print_term a print_term b + | Fatom (Ge (a, b)) -> + fprintf fmt "@[(%a >=@ %a)@]" print_term a print_term b + | Fatom (Gt (a, b)) -> + fprintf fmt "@[(%a >@ %a)@]" print_term a print_term b + | Fatom (Pred (id, [])) -> + fprintf fmt "%a" ident id + | Fatom (Pred (id, tl)) -> + fprintf fmt "@[%a(%a)@]" ident id print_terms tl + | Imp (a, b) -> + fprintf fmt "@[(%a ->@ %a)@]" pp a pp b + | Iff (a, b) -> + fprintf fmt "@[(%a <->@ %a)@]" pp a pp b + | And (a, b) -> + fprintf fmt "@[(%a and@ %a)@]" pp a pp b + | Or (a, b) -> + fprintf fmt "@[(%a or@ %a)@]" pp a pp b + | Not a -> + fprintf fmt "@[(not@ %a)@]" pp a + | Forall (id, t, p) -> + fprintf fmt "@[(forall %a:%a.@ %a)@]" ident id print_typ t pp p + | Exists (id, t, p) -> + fprintf fmt "@[(exists %a:%a.@ %a)@]" ident id print_typ t pp p + +let rec remove_iff args = function + Forall (id,t,p) -> remove_iff ((id,t)::args) p + | Iff(_,b) -> List.rev args, b + | _ -> raise Not_found + +let print_query fmt (decls,concl) = + let find_declared_preds l = + function + DeclPred (id,_,args) -> (id,args) :: l + | _ -> l + in + let find_defined_preds declared l = function + Axiom(id,f) -> + (try + let _decl = List.assoc id declared in + (id,remove_iff [] f)::l + with Not_found -> l) + | _ -> l + in + let declared_preds = + List.fold_left find_declared_preds [] decls in + let defined_preds = + List.fold_left (find_defined_preds declared_preds) [] decls + in + let print_dtype = function + | DeclType (id, 0) -> + fprintf fmt "@[type %a@]@\n@\n" ident id + | DeclType (id, 1) -> + fprintf fmt "@[type 'a %a@]@\n@\n" ident id + | DeclType (id, n) -> + fprintf fmt "@[type ("; + for i = 1 to n do + fprintf fmt "'a%d" i; if i < n then fprintf fmt ", " + done; + fprintf fmt ") %a@]@\n@\n" ident id + | DeclFun _ | DeclPred _ | Axiom _ -> + () + in + let print_dvar_dpred = function + | DeclFun (id, _, [], t) -> + fprintf fmt "@[logic %a : -> %a@]@\n@\n" ident id print_typ t + | DeclFun (id, _, l, t) -> + fprintf fmt "@[logic %a : %a -> %a@]@\n@\n" + ident id (print_list comma print_typ) l print_typ t + | DeclPred (id, _, []) when not (List.mem_assoc id defined_preds) -> + fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id + | DeclPred (id, _, l) when not (List.mem_assoc id defined_preds) -> + fprintf fmt "@[logic %a : %a -> prop@]@\n@\n" + ident id (print_list comma print_typ) l + | DeclType _ | Axiom _ | DeclPred _ -> + () + in + let print_assert = function + | Axiom(id,_) when List.mem_assoc id defined_preds -> + let args, def = List.assoc id defined_preds in + fprintf fmt "@[predicate %a(%a) =@\n%a@]@\n" ident id + (print_list comma print_arg) args print_predicate def + | Axiom (id, f) -> + fprintf fmt "@[axiom %a:@ %a@]@\n@\n" ident id print_predicate f + | DeclType _ | DeclFun _ | DeclPred _ -> + () + in + List.iter print_dtype decls; + List.iter print_dvar_dpred decls; + List.iter print_assert decls; + fprintf fmt "@[goal coq___goal: %a@]" print_predicate concl + +let output_file f q = + let c = open_out f in + let fmt = formatter_of_out_channel c in + fprintf fmt "include \"real.why\"@."; + fprintf fmt "@[%a@]@." print_query q; + close_out c diff --git a/plugins/dp/dp_why.mli b/plugins/dp/dp_why.mli new file mode 100644 index 00000000..0efa24a2 --- /dev/null +++ b/plugins/dp/dp_why.mli @@ -0,0 +1,17 @@ + +open Fol + +(* generation of the Why file *) + +val output_file : string -> query -> unit + +(* table to translate the proofs back to Coq (used in dp_zenon) *) + +type proof = + | Immediate of Term.constr + | Fun_def of string * (string * typ) list * typ * term + +val add_proof : proof -> string +val find_proof : string -> proof + + diff --git a/plugins/dp/dp_zenon.mli b/plugins/dp/dp_zenon.mli new file mode 100644 index 00000000..0a727d1f --- /dev/null +++ b/plugins/dp/dp_zenon.mli @@ -0,0 +1,7 @@ + +open Fol + +val set_debug : bool -> unit + +val proof_from_file : string -> Proof_type.tactic + diff --git a/plugins/dp/dp_zenon.mll b/plugins/dp/dp_zenon.mll new file mode 100644 index 00000000..949e91e3 --- /dev/null +++ b/plugins/dp/dp_zenon.mll @@ -0,0 +1,189 @@ + +{ + + open Lexing + open Pp + open Util + open Names + open Tacmach + open Dp_why + open Tactics + open Tacticals + + let debug = ref false + let set_debug b = debug := b + + let buf = Buffer.create 1024 + + let string_of_global env ref = + Libnames.string_of_qualid (Nametab.shortest_qualid_of_global env ref) + + let axioms = ref [] + + (* we cannot interpret the terms as we read them (since some lemmas + may need other lemmas to be already interpreted) *) + type lemma = { l_id : string; l_type : string; l_proof : string } + type zenon_proof = lemma list * string + +} + +let ident = ['a'-'z' 'A'-'Z' '_' '0'-'9' '\'']+ +let space = [' ' '\t' '\r'] + +rule start = parse +| "(* BEGIN-PROOF *)" "\n" { scan lexbuf } +| _ { start lexbuf } +| eof { anomaly "malformed Zenon proof term" } + +(* here we read the lemmas and the main proof term; + meanwhile we maintain the set of axioms that were used *) + +and scan = parse +| "Let" space (ident as id) space* ":" + { let t = read_coq_term lexbuf in + let p = read_lemma_proof lexbuf in + let l,pr = scan lexbuf in + { l_id = id; l_type = t; l_proof = p } :: l, pr } +| "Definition theorem:" + { let t = read_main_proof lexbuf in [], t } +| _ | eof + { anomaly "malformed Zenon proof term" } + +and read_coq_term = parse +| "." "\n" + { let s = Buffer.contents buf in Buffer.clear buf; s } +| "coq__" (ident as id) (* a Why keyword renamed *) + { Buffer.add_string buf id; read_coq_term lexbuf } +| ("dp_axiom__" ['0'-'9']+) as id + { axioms := id :: !axioms; Buffer.add_string buf id; read_coq_term lexbuf } +| _ as c + { Buffer.add_char buf c; read_coq_term lexbuf } +| eof + { anomaly "malformed Zenon proof term" } + +and read_lemma_proof = parse +| "Proof" space + { read_coq_term lexbuf } +| _ | eof + { anomaly "malformed Zenon proof term" } + +(* skip the main proof statement and then read its term *) +and read_main_proof = parse +| ":=" "\n" + { read_coq_term lexbuf } +| _ + { read_main_proof lexbuf } +| eof + { anomaly "malformed Zenon proof term" } + + +{ + + let read_zenon_proof f = + Buffer.clear buf; + let c = open_in f in + let lb = from_channel c in + let p = start lb in + close_in c; + if not !debug then begin try Sys.remove f with _ -> () end; + p + + let constr_of_string gl s = + let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in + Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s) + + (* we are lazy here: we build strings containing Coq terms using a *) + (* pretty-printer Fol -> Coq *) + module Coq = struct + open Format + open Fol + + let rec print_list sep print fmt = function + | [] -> () + | [x] -> print fmt x + | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r + + let space fmt () = fprintf fmt "@ " + let comma fmt () = fprintf fmt ",@ " + + let rec print_typ fmt = function + | Tvar x -> fprintf fmt "%s" x + | Tid ("int", []) -> fprintf fmt "Z" + | Tid (x, []) -> fprintf fmt "%s" x + | Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t + | Tid (x,tl) -> + fprintf fmt "(%s %a)" x (print_list comma print_typ) tl + + let rec print_term fmt = function + | Cst n -> + fprintf fmt "%s" (Big_int.string_of_big_int n) + | RCst s -> + fprintf fmt "%s" (Big_int.string_of_big_int s) + | Power2 n -> + fprintf fmt "@[(powerRZ 2 %s)@]" (Big_int.string_of_big_int n) + + (* TODO: bug, it might be operations on reals *) + | Plus (a, b) -> + fprintf fmt "@[(Zplus %a %a)@]" print_term a print_term b + | Moins (a, b) -> + fprintf fmt "@[(Zminus %a %a)@]" print_term a print_term b + | Mult (a, b) -> + fprintf fmt "@[(Zmult %a %a)@]" print_term a print_term b + | Div (a, b) -> + fprintf fmt "@[(Zdiv %a %a)@]" print_term a print_term b + | Opp (a) -> + fprintf fmt "@[(Zopp %a)@]" print_term a + | App (id, []) -> + fprintf fmt "%s" id + | App (id, tl) -> + fprintf fmt "@[(%s %a)@]" id print_terms tl + + and print_terms fmt tl = + print_list space print_term fmt tl + + (* builds the text for "forall vars, f vars = t" *) + let fun_def_axiom f vars t = + let binder fmt (x,t) = fprintf fmt "(%s: %a)" x print_typ t in + fprintf str_formatter + "@[(forall %a, %s %a = %a)@]@." + (print_list space binder) vars f + (print_list space (fun fmt (x,_) -> pp_print_string fmt x)) vars + print_term t; + flush_str_formatter () + + end + + let prove_axiom id = match Dp_why.find_proof id with + | Immediate t -> + exact_check t + | Fun_def (f, vars, ty, t) -> + tclTHENS + (fun gl -> + let s = Coq.fun_def_axiom f vars t in + if !debug then Format.eprintf "axiom fun def = %s@." s; + let c = constr_of_string gl s in + assert_tac (Name (id_of_string id)) c gl) + [tclTHEN intros reflexivity; tclIDTAC] + + let exact_string s gl = + let c = constr_of_string gl s in + exact_check c gl + + let interp_zenon_proof (ll,p) = + let interp_lemma l gl = + let ty = constr_of_string gl l.l_type in + tclTHENS + (assert_tac (Name (id_of_string l.l_id)) ty) + [exact_string l.l_proof; tclIDTAC] + gl + in + tclTHEN (tclMAP interp_lemma ll) (exact_string p) + + let proof_from_file f = + axioms := []; + msgnl (str "proof_from_file " ++ str f); + let zp = read_zenon_proof f in + msgnl (str "proof term is " ++ str (snd zp)); + tclTHEN (tclMAP prove_axiom !axioms) (interp_zenon_proof zp) + +} diff --git a/plugins/dp/fol.mli b/plugins/dp/fol.mli new file mode 100644 index 00000000..4fb763a6 --- /dev/null +++ b/plugins/dp/fol.mli @@ -0,0 +1,58 @@ + +(* Polymorphic First-Order Logic (that is Why's input logic) *) + +type typ = + | Tvar of string + | Tid of string * typ list + +type term = + | Cst of Big_int.big_int + | RCst of Big_int.big_int + | Power2 of Big_int.big_int + | Plus of term * term + | Moins of term * term + | Mult of term * term + | Div of term * term + | Opp of term + | App of string * term list + +and atom = + | Eq of term * term + | Le of term * term + | Lt of term * term + | Ge of term * term + | Gt of term * term + | Pred of string * term list + +and form = + | Fatom of atom + | Imp of form * form + | Iff of form * form + | And of form * form + | Or of form * form + | Not of form + | Forall of string * typ * form + | Exists of string * typ * form + | True + | False + +(* the integer indicates the number of type variables *) +type decl = + | DeclType of string * int + | DeclFun of string * int * typ list * typ + | DeclPred of string * int * typ list + | Axiom of string * form + +type query = decl list * form + + +(* prover result *) + +type prover_answer = + | Valid of string option + | Invalid + | DontKnow + | Timeout + | NoAnswer + | Failure of string + diff --git a/plugins/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4 new file mode 100644 index 00000000..82f86cd8 --- /dev/null +++ b/plugins/dp/g_dp.ml4 @@ -0,0 +1,79 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ simplify ] +END + +TACTIC EXTEND Ergo + [ "ergo" ] -> [ ergo ] +END + +TACTIC EXTEND Yices + [ "yices" ] -> [ yices ] +END + +TACTIC EXTEND CVC3 + [ "cvc3" ] -> [ cvc3 ] +END + +TACTIC EXTEND Z3 + [ "z3" ] -> [ z3 ] +END + +TACTIC EXTEND CVCLite + [ "cvcl" ] -> [ cvc_lite ] +END + +TACTIC EXTEND Harvey + [ "harvey" ] -> [ harvey ] +END + +TACTIC EXTEND Zenon + [ "zenon" ] -> [ zenon ] +END + +TACTIC EXTEND Gwhy + [ "gwhy" ] -> [ gwhy ] +END + +(* should be part of basic tactics syntax *) +TACTIC EXTEND admit + [ "admit" ] -> [ Tactics.admit_as_an_axiom ] +END + +VERNAC COMMAND EXTEND Dp_hint + [ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ] +END + +VERNAC COMMAND EXTEND Dp_timeout +| [ "Dp_timeout" natural(n) ] -> [ dp_timeout n ] +END + +VERNAC COMMAND EXTEND Dp_prelude +| [ "Dp_prelude" string_list(l) ] -> [ dp_prelude l ] +END + +VERNAC COMMAND EXTEND Dp_predefined +| [ "Dp_predefined" global(g) "=>" string(s) ] -> [ dp_predefined g s ] +END + +VERNAC COMMAND EXTEND Dp_debug +| [ "Dp_debug" ] -> [ dp_debug true; Dp_zenon.set_debug true ] +END + +VERNAC COMMAND EXTEND Dp_trace +| [ "Dp_trace" ] -> [ dp_trace true ] +END + diff --git a/plugins/dp/test2.v b/plugins/dp/test2.v new file mode 100644 index 00000000..0940b135 --- /dev/null +++ b/plugins/dp/test2.v @@ -0,0 +1,80 @@ +Require Import ZArith. +Require Import Classical. +Require Import List. + +Open Scope list_scope. +Open Scope Z_scope. + +Dp_debug. +Dp_timeout 3. +Require Export zenon. + +Definition neg (z:Z) : Z := match z with + | Z0 => Z0 + | Zpos p => Zneg p + | Zneg p => Zpos p + end. + +Goal forall z, neg (neg z) = z. + Admitted. + +Open Scope nat_scope. +Print plus. + +Goal forall x, x+0=x. + induction x; ergo. + (* simplify resoud le premier, pas le second *) + Admitted. + +Goal 1::2::3::nil = 1::2::(1+2)::nil. + zenon. + Admitted. + +Definition T := nat. +Parameter fct : T -> nat. +Goal fct O = O. + Admitted. + +Fixpoint even (n:nat) : Prop := + match n with + O => True + | S O => False + | S (S p) => even p + end. + +Goal even 4%nat. + try zenon. + Admitted. + +Definition p (A B:Set) (a:A) (b:B) : list (A*B) := cons (a,b) nil. + +Definition head := +fun (A : Set) (l : list A) => +match l with +| nil => None (A:=A) +| x :: _ => Some x +end. + +Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1. + +Admitted. + +(* +BUG avec head prédéfini : manque eta-expansion sur A:Set + +Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1. + +Print value. +Print Some. + +zenon. +*) + +Inductive IN (A:Set) : A -> list A -> Prop := + | IN1 : forall x l, IN A x (x::l) + | IN2: forall x l, IN A x l -> forall y, IN A x (y::l). +Implicit Arguments IN [A]. + +Goal forall x, forall (l:list nat), IN x l -> IN x (1%nat::l). + zenon. +Print In. diff --git a/plugins/dp/tests.v b/plugins/dp/tests.v new file mode 100644 index 00000000..dc85d2ee --- /dev/null +++ b/plugins/dp/tests.v @@ -0,0 +1,300 @@ + +Require Import ZArith. +Require Import Classical. +Require Export Reals. + + +(* real numbers *) + +Lemma real_expr: (0 <= 9 * 4)%R. +ergo. +Qed. + +Lemma powerRZ_translation: (powerRZ 2 15 < powerRZ 2 17)%R. +ergo. +Qed. + +Dp_debug. +Dp_timeout 3. + +(* module renamings *) + +Module M. + Parameter t : Set. +End M. + +Lemma test_module_0 : forall x:M.t, x=x. +ergo. +Qed. + +Module N := M. + +Lemma test_module_renaming_0 : forall x:N.t, x=x. +ergo. +Qed. + +Dp_predefined M.t => "int". + +Lemma test_module_renaming_1 : forall x:N.t, x=x. +ergo. +Qed. + +(* Coq lists *) + +Require Export List. + +Lemma test_pol_0 : forall l:list nat, l=l. +ergo. +Qed. + +Parameter nlist: list nat -> Prop. + +Lemma poly_1 : forall l, nlist l -> True. +intros. +simplify. +Qed. + +(* user lists *) + +Inductive list (A:Set) : Set := +| nil : list A +| cons: forall a:A, list A -> list A. + +Fixpoint app (A:Set) (l m:list A) {struct l} : list A := +match l with +| nil => m +| cons a l1 => cons A a (app A l1 m) +end. + +Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True. +intros; ergo. +Qed. + +(* polymorphism *) +Require Import List. + +Inductive mylist (A:Set) : Set := + mynil : mylist A +| mycons : forall a:A, mylist A -> mylist A. + +Parameter my_nlist: mylist nat -> Prop. + + Goal forall l, my_nlist l -> True. + intros. + simplify. +Qed. + +(* First example with the 0 and the equality translated *) + +Goal 0 = 0. +simplify. +Qed. + +(* Examples in the Propositional Calculus + and theory of equality *) + +Parameter A C : Prop. + +Goal A -> A. +simplify. +Qed. + + +Goal A -> (A \/ C). + +simplify. +Qed. + + +Parameter x y z : Z. + +Goal x = y -> y = z -> x = z. +ergo. +Qed. + + +Goal ((((A -> C) -> A) -> A) -> C) -> C. + +ergo. +Qed. + +(* Arithmetic *) +Open Scope Z_scope. + +Goal 1 + 1 = 2. +yices. +Qed. + + +Goal 2*x + 10 = 18 -> x = 4. + +simplify. +Qed. + + +(* Universal quantifier *) + +Goal (forall (x y : Z), x = y) -> 0=1. +try zenon. +ergo. +Qed. + +Goal forall (x: nat), (x + 0 = x)%nat. + +induction x0; ergo. +Qed. + + +(* No decision procedure can solve this problem + Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a. +*) + + +(* Functions definitions *) + +Definition fst (x y : Z) : Z := x. + +Goal forall (g : Z -> Z) (x y : Z), g (fst x y) = g x. + +simplify. +Qed. + + +(* Eta-expansion example *) + +Definition snd_of_3 (x y z : Z) : Z := y. + +Definition f : Z -> Z -> Z := snd_of_3 0. + +Goal forall (x y z z1 : Z), snd_of_3 x y z = f y z1. + +simplify. +Qed. + + +(* Inductive types definitions - call to dp/injection function *) + +Inductive even : Z -> Prop := +| even_0 : even 0 +| even_plus2 : forall z : Z, even z -> even (z + 2). + + +(* Simplify and Zenon can't prove this goal before the timeout + unlike CVC Lite *) + +Goal even 4. +ergo. +Qed. + + +Definition skip_z (z : Z) (n : nat) := n. + +Definition skip_z1 := skip_z. + +Goal forall (z : Z) (n : nat), skip_z z n = skip_z1 z n. +yices. +Qed. + + +(* Axioms definitions and dp_hint *) + +Parameter add : nat -> nat -> nat. +Axiom add_0 : forall (n : nat), add 0%nat n = n. +Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2). + +Dp_hint add_0. +Dp_hint add_S. + +(* Simplify can't prove this goal before the timeout + unlike zenon *) + +Goal forall n : nat, add n 0 = n. +induction n ; yices. +Qed. + + +Definition pred (n : nat) : nat := match n with + | 0%nat => 0%nat + | S n' => n' +end. + +Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat. +yices. +(*zenon.*) +Qed. + + +Fixpoint plus (n m : nat) {struct n} : nat := + match n with + | 0%nat => m + | S n' => S (plus n' m) +end. + +Goal forall n : nat, plus n 0%nat = n. + +induction n; ergo. +Qed. + + +(* Mutually recursive functions *) + +Fixpoint even_b (n : nat) : bool := match n with + | O => true + | S m => odd_b m +end +with odd_b (n : nat) : bool := match n with + | O => false + | S m => even_b m +end. + +Goal even_b (S (S O)) = true. +ergo. +(* +simplify. +zenon. +*) +Qed. + + +(* sorts issues *) + +Parameter foo : Set. +Parameter ff : nat -> foo -> foo -> nat. +Parameter g : foo -> foo. +Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O. +yices. +(*zenon.*) +Qed. + + + +(* abstractions *) + +Parameter poly_f : forall A:Set, A->A. + +Goal forall x:nat, poly_f nat x = poly_f nat x. +ergo. +(*zenon.*) +Qed. + + + +(* Anonymous mutually recursive functions : no equations are produced + +Definition mrf := + fix even2 (n : nat) : bool := match n with + | O => true + | S m => odd2 m + end + with odd2 (n : nat) : bool := match n with + | O => false + | S m => even2 m + end for even. + + Thus this goal is unsolvable + +Goal mrf (S (S O)) = true. + +zenon. + +*) diff --git a/plugins/dp/vo.itarget b/plugins/dp/vo.itarget new file mode 100644 index 00000000..4d282709 --- /dev/null +++ b/plugins/dp/vo.itarget @@ -0,0 +1 @@ +Dp.vo diff --git a/plugins/dp/zenon.v b/plugins/dp/zenon.v new file mode 100644 index 00000000..502465c6 --- /dev/null +++ b/plugins/dp/zenon.v @@ -0,0 +1,94 @@ +(* Copyright 2004 INRIA *) +(* $Id$ *) + +Require Export Classical. + +Lemma zenon_nottrue : + (~True -> False). +Proof. tauto. Qed. + +Lemma zenon_noteq : forall (T : Type) (t : T), + ((t <> t) -> False). +Proof. tauto. Qed. + +Lemma zenon_and : forall P Q : Prop, + (P -> Q -> False) -> (P /\ Q -> False). +Proof. tauto. Qed. + +Lemma zenon_or : forall P Q : Prop, + (P -> False) -> (Q -> False) -> (P \/ Q -> False). +Proof. tauto. Qed. + +Lemma zenon_imply : forall P Q : Prop, + (~P -> False) -> (Q -> False) -> ((P -> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_equiv : forall P Q : Prop, + (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notand : forall P Q : Prop, + (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notor : forall P Q : Prop, + (~P -> ~Q -> False) -> (~(P \/ Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notimply : forall P Q : Prop, + (P -> ~Q -> False) -> (~(P -> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_notequiv : forall P Q : Prop, + (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False). +Proof. tauto. Qed. + +Lemma zenon_ex : forall (T : Type) (P : T -> Prop), + (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False). +Proof. firstorder. Qed. + +Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T), + ((P t) -> False) -> ((forall x : T, (P x)) -> False). +Proof. firstorder. Qed. + +Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T), + (~(P t) -> False) -> (~(exists x : T, (P x)) -> False). +Proof. firstorder. Qed. + +Lemma zenon_notall : forall (T : Type) (P : T -> Prop), + (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False). +Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed. + +Lemma zenon_equal_base : forall (T : Type) (f : T), f = f. +Proof. auto. Qed. + +Lemma zenon_equal_step : + forall (S T : Type) (fa fb : S -> T) (a b : S), + (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)). +Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed. + +Lemma zenon_pnotp : forall P Q : Prop, + (P = Q) -> (P -> ~Q -> False). +Proof. intros P Q Ha. rewrite Ha. auto. Qed. + +Lemma zenon_notequal : forall (T : Type) (a b : T), + (a = b) -> (a <> b -> False). +Proof. auto. Qed. + +Ltac zenon_intro id := + intro id || let nid := fresh in (intro nid; clear nid) +. + +Definition zenon_and_s := fun P Q a b => zenon_and P Q b a. +Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a. +Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a. +Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a. +Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a. +Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a. +Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a. +Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a. +Definition zenon_ex_s := fun T P a b => zenon_ex T P b a. +Definition zenon_notall_s := fun T P a b => zenon_notall T P b a. + +Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b. +Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x. diff --git a/plugins/extraction/CHANGES b/plugins/extraction/CHANGES new file mode 100644 index 00000000..fbcd01a1 --- /dev/null +++ b/plugins/extraction/CHANGES @@ -0,0 +1,414 @@ +8.0 -> today + +See the main CHANGES file in the archive + + +7.4 -> 8.0 + +No revolution this time. Mostly "behind-the-scene" clean-up and bug-fixes, +but also a few steps toward a more user-friendly extraction: + +* syntax of extraction: +- The old (Recursive) Extraction Module M. + is now (Recursive) Extraction Library M. + The old name was misleading since this command only works with M being a + library M.v, and not a module produced by interactive command Module M. +- The other commands + Extraction foo. + Recursive Extraction foo bar. + Extraction "myfile.ml" foo bar. + now accept that foo can be a module name instead of just a constant name. + +* Support of type scheme axioms (i.e. axiom whose type is an arity + (x1:X1)...(xn:Xn)s with s a sort). For example: + + Axiom myprod : Set -> Set -> Set. + Extract Constant myprod "'a" "'b" => "'a * 'b". + Recursive Extraction myprod. + -------> type ('a,'b) myprod = 'a * 'b + +* More flexible support of axioms. When an axiom isn't realized via Extract + Constant before extraction, a warning is produced (instead of an error), + and the extracted code must be completed later by hand. To find what + needs to be completed, search for the following string: AXIOM TO BE REALIZED + +* Cosmetics: When extraction produces a file, it tells it. + +* (Experimental) It is allowed to extract under a opened interactive module + (but still outside sections). Feature to be used with caution. + +* A problem has been identified concerning .v files used as normal interactive + modules, like in + + + Definition foo :=O. + + + + Require A. + Module M:=A + Extraction M. + + I might try to support that in the future. In the meanwhile, the + current behaviour of extraction is to forbid this. + +* bug fixes: +- many concerning Records. +- a Stack Overflow with mutual inductive (PR#320) +- some optimizations have been removed since they were not type-safe: + For example if e has type: type 'x a = A + Then: match e with A -> A -----X----> e + To be investigated further. + + +7.3 -> 7.4 + +* The two main new features: + - Automatic generation of Obj.magic when the extracted code + in Ocaml is not directly typable. + - An experimental extraction of Coq's new modules to Ocaml modules. + +* Concerning those Obj.magic: + - The extraction now computes the expected type of any terms. Then + it compares it with the actual type of the produced code. And when + a mismatch is found, a Obj.magic is inserted. + + - As a rule, any extracted development that was compiling out of the box + should not contain any Obj.magic. At the other hand, generation of + Obj.magic is not optimized yet: there might be several of them at a place + were one would have been enough. + + - Examples of code needing those Obj.magic: + * plugins/extraction/test_extraction.v in the Coq source + * in the users' contributions: + Lannion + Lyon/CIRCUITS + Rocq/HIGMAN + + - As a side-effect of this Obj.magic feature, we now print the types + of the extracted terms, both in .ml files as commented documentation + and in interfaces .mli files + + - This feature hasn't been ported yet to Haskell. We are aware of + some unsafe casting functions like "unsafeCoerce" on some Haskell implems. + So it will eventually be done. + +* Concerning the extraction of Coq's new modules: + - Taking in account the new Coq's modules system has implied a *huge* + rewrite of most of the extraction code. + + - The extraction core (translation from Coq to an abstract mini-ML) + is now complete and fairly stable, and supports modules, modules type + and functors and all that stuff. + + - The ocaml pretty-print part, especially the renaming issue, is + clearly weaker, and certainly still contains bugs. + + - Nothing done for translating these Coq Modules to Haskell. + + - A temporary drawback of this module extraction implementation is that + efficiency (especially extraction speed) has been somehow neglected. + To improve ... + + - As an interesting side-effect, definitions are now printed according to + the user's original order. No more of this "dependency-correct but weird" + order. In particular realized axioms via Extract Constant are now at their + right place, and not at the beginning. + +* Other news: + + - Records are now printed using the Ocaml record syntax + + - Syntax output toward Scheme. Quite funny, but quite experimental and + not documented. I recommend using the bigloo compiler since it contains + natively some pattern matching. + + - the dummy constant "__" have changed. see README + + - a few bug-fixes (#191 and others) + +7.2 -> 7.3 + +* Improved documentation in the Reference Manual. + +* Theoretical bad news: +- a naughty example (see the end of test_extraction.v) +forced me to stop eliminating lambdas and arguments corresponding to +so-called "arity" in the general case. + +- The dummy constant used in extraction ( let prop = () in ocaml ) +may in some cases be applied to arguments. This problem is dealt by +generating sufficient abstraction before the (). + + +* Theoretical good news: +- there is now a mechanism that remove useless prop/arity lambdas at the +top of function declarations. If your function had signature +nat -> prop -> nat in the previous extraction, it will now be nat -> nat. +So the extractions of common terms should look very much like the old +V6.2 one, except in some particular cases (functions as parameters, partial +applications, etc). In particular the bad news above have nearly no +impact... + + +* By the way there is no more "let prop = ()" in ocaml. Those () are +directly inlined. And in Haskell the dummy constant is now __ (two +underscore) and is defined by +__ = Prelude.error "Logical or arity value used" +This dummy constant should never be evaluated when computing an +informative value, thanks to the lazy strategy. Hence the error message. + + +* Syntax changes, see Documentation for details: + +Extraction Language Ocaml. +Extraction Language Haskell. +Extraction Language Toplevel. + +That fixes the target language of extraction. Default is Ocaml, even in the +coq toplevel: you can now do copy-paste from the coq toplevel without +renaming problems. Toplevel language is the ocaml pseudo-language used +previously used inside the coq toplevel: coq names are printed with the coq +way, i.e. with no renaming. + +So there is no more particular commands for Haskell, like +Haskell Extraction "file" id. Just set your favourite language and go... + + +* Haskell extraction has been tested at last (and corrected...). +See specificities in Documentation. + + +* Extraction of CoInductive in Ocaml language is now correct: it uses the +Lazy.force and lazy features of Ocaml. + + +* Modular extraction in Ocaml is now far more readable: +instead of qualifying everywhere (A.foo), there are now some "open" at the +beginning of files. Possible clashes are dealt with. + + +* By default, any recursive function associated with an inductive type +(foo_rec and foo_rect when foo is inductive type) will now be inlined +in extracted code. + + +* A few constants are explicitely declared to be inlined in extracted code. +For the moment there are: + Wf.Acc_rec + Wf.Acc_rect + Wf.well_founded_induction + Wf.well_founded_induction_type +Those constants does not match the auto-inlining criterion based on strictness. +Of course, you can still overide this behaviour via some Extraction NoInline. + +* There is now a web page showing the extraction of all standard theories: +http://www.lri.fr/~letouzey/extraction + + +7.1 -> 7.2 : + +* Syntax changes, see Documentation for more details: + +Set/Unset Extraction Optimize. + +Default is Set. This control all optimizations made on the ML terms +(mostly reduction of dummy beta/iota redexes, but also simplications on +Cases, etc). Put this option to Unset if you what a ML term as close as +possible to the Coq term. + +Set/Unset Extraction AutoInline. + +Default in Set, so by default, the extraction mechanism feels free to +inline the bodies of some defined constants, according to some heuristics +like size of bodies, useness of some arguments, etc. Those heuristics are +not always perfect, you may want to disable this feature, do it by Unset. + +Extraction Inline toto foo. +Extraction NoInline titi faa bor. + +In addition to the automatic inline feature, you can now tell precisely to +inline some more constants by the Extraction Inline command. Conversely, +you can forbid the inlining of some specific constants by automatic inlining. +Those two commands enable a precise control of what is inlined and what is not. + +Print Extraction Inline. + +Sum up the current state of the table recording the custom inlings +(Extraction (No)Inline). + +Reset Extraction Inline. + +Put the table recording the custom inlings back to empty. + +As a consequence, there is no more need for options inside the commands of +extraction: + +Extraction foo. +Recursive Extraction foo bar. +Extraction "file" foo bar. +Extraction Module Mymodule. +Recursive Extraction Module Mymodule. + +New: The last syntax extracts the module Mymodule and all the modules +it depends on. + +You can also try the Haskell versions (not tested yet): + +Haskell Extraction foo. +Haskell Recursive Extraction foo bar. +Haskell Extraction "file" foo bar. +Haskell Extraction Module Mymodule. +Haskell Recursive Extraction Module Mymodule. + +And there's still the realization syntax: + +Extract Constant coq_bla => "caml_bla". +Extract Inlined Constant coq_bla => "caml_bla". +Extract Inductive myinductive => mycamlind [my_caml_constr1 ... ]. + +Note that now, the Extract Inlined Constant command is sugar for an Extract +Constant followed by a Extraction Inline. So be careful with +Reset Extraction Inline. + + + +* Lot of works around optimization of produced code. Should make code more +readable. + +- fixpoint definitions : there should be no more stupid printings like + +let foo x = + let rec f x = + .... (f y) .... + in f x + +but rather + +let rec foo x = + .... (foo y) .... + +- generalized iota (in particular iota and permutation cases/cases): + +A generalized iota redex is a "Cases e of ...." where e is ok. +And the recursive predicate "ok" is given by: +e is ok if e is a Constructor or a Cases where all branches are ok. +In the case of generalized iota redex, it might be good idea to reduce it, +so we do it. +Example: + +match (match t with + O -> Left + | S n -> match n with + O -> Right + | S m -> Left) with + Left -> blabla +| Right -> bloblo + +After simplification, that gives: + +match t with + O -> blabla +| S n -> match n with + O -> bloblo + | S n -> blabla + +As shown on the example, code duplication can occur. In practice +it seems not to happen frequently. + +- "constant" case: +In V7.1 we used to simplify cases where all branches are the same. +In V7.2 we can simplify in addition terms like + cases e of + C1 x y -> f (C x y) + | C2 z -> f (C2 z) +If x y z don't occur in f, we can produce (f e). + +- permutation cases/fun: +extracted code has frequenty functions in branches of cases: + +let foo x = match x with + O -> fun _ -> .... + | S y -> fun _ -> .... + +the optimization consist in lifting the common "fun _ ->", and that gives + +let foo x _ = match x with + O -> ..... + | S y -> .... + + +* Some bug corrections (many thanks in particular to Michel Levy). + +* Testing in coq contributions: +If you are interested in extraction, you can look at the extraction tests +I'have put in the following coq contributions + +Bordeaux/Additions computation of fibonacci(2000) +Bordeaux/EXCEPTIONS multiplication using exception. +Bordeaux/SearchTrees list -> binary tree. maximum. +Dyade/BDDS boolean tautology checker. +Lyon/CIRCUITS multiplication via a modelization of a circuit. +Lyon/FIRING-SQUAD print the states of the firing squad. +Marseille/CIRCUITS compares integers via a modelization of a circuit. +Nancy/FOUnify unification of two first-order terms. +Rocq/ARITH/Chinese computation of the chinese remainder. +Rocq/COC small coc typechecker. (test by B. Barras, not by me) +Rocq/HIGMAN run the proof on one example. +Rocq/GRAPHS linear constraints checker in Z. +Sophia-Antipolis/Stalmarck boolean tautology checker. +Suresnes/BDD boolean tautology checker. + +Just do "make" in those contributions, the extraction test is integrated. +More tests will follow on more contributions. + + + +7.0 -> 7.1 : mostly bug corrections. No theoretical problems dealed with. + +* The semantics of Extract Constant changed: If you provide a extraction +for p by Extract Constant p => "0", your generated ML file will begin by +a let p = 0. The old semantics, which was to replace p everywhere by the +provided terms, is still available via the Extract Inlined Constant p => +"0" syntax. + + +* There are more optimizations applied to the generated code: +- identity cases: match e with P x y -> P x y | Q z -> Q z | ... +is simplified into e. Especially interesting with the sumbool terms: +there will be no more match ... with Left -> Left | Right -> Right + +- constant cases: match e with P x y -> c | Q z -> c | ... +is simplified into c as soon as x, y, z do not occur in c. +So no more match ... with Left -> Left | Right -> Left. + + +* the extraction at Toplevel (Extraction foo and Recursive Extraction foo), +which was only a development tool at the beginning, is now closer to +the real extraction to a file. In particular optimizations are done, +and constants like recursors ( ..._rec ) are expanded. + + +* the singleton optimization is now protected against circular type. +( Remind : this optimization is the one that simplify +type 'a sig = Exists of 'a into type 'a sig = 'a and +match e with (Exists c) -> d into let c = e in d ) + + +* Fixed one bug concerning casted code + + +* The inductives generated should now have always correct type-var list +('a,'b,'c...) + + +* Code cleanup until three days before release. Messing-up code +in the last three days before release. + + + + + + + +6.x -> 7.0 : Everything changed. See README diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v new file mode 100644 index 00000000..f0135221 --- /dev/null +++ b/plugins/extraction/ExtrOcamlBasic.v @@ -0,0 +1,33 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool [ true false ]. +Extract Inductive option => option [ Some None ]. +Extract Inductive unit => unit [ "()" ]. +Extract Inductive list => list [ "[]" "( :: )" ]. +Extract Inductive prod => "( * )" [ "" ]. + +(** NB: The "" above is a hack, but produce nicer code than "(,)" *) + +(** Mapping sumbool to bool and sumor to option is not always nicer, + but it helps when realizing stuff like [lt_eq_lt_dec] *) + +Extract Inductive sumbool => bool [ true false ]. +Extract Inductive sumor => option [ Some None ]. + +(** Restore lazyness of andb, orb. + NB: without these Extract Constant, andb/orb would be inlined + by extraction in order to have lazyness, producing inelegant + (if ... then ... else false) and (if ... then true else ...). +*) + +Extract Inlined Constant andb => "(&&)". +Extract Inlined Constant orb => "(||)". + diff --git a/plugins/extraction/ExtrOcamlBigIntConv.v b/plugins/extraction/ExtrOcamlBigIntConv.v new file mode 100644 index 00000000..b4490545 --- /dev/null +++ b/plugins/extraction/ExtrOcamlBigIntConv.v @@ -0,0 +1,108 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bigint. +Parameter bigint_opp : bigint -> bigint. +Parameter bigint_twice : bigint -> bigint. + +Extract Inlined Constant bigint => "Big.big_int". +Extract Inlined Constant bigint_zero => "Big.zero". +Extract Inlined Constant bigint_succ => "Big.succ". +Extract Inlined Constant bigint_opp => "Big.opp". +Extract Inlined Constant bigint_twice => "Big.double". + +Definition bigint_of_nat : nat -> bigint := + (fix loop acc n := + match n with + | O => acc + | S n => loop (bigint_succ acc) n + end) bigint_zero. + +Fixpoint bigint_of_pos p := + match p with + | xH => bigint_succ bigint_zero + | xO p => bigint_twice (bigint_of_pos p) + | xI p => bigint_succ (bigint_twice (bigint_of_pos p)) + end. + +Fixpoint bigint_of_z z := + match z with + | Z0 => bigint_zero + | Zpos p => bigint_of_pos p + | Zneg p => bigint_opp (bigint_of_pos p) + end. + +Fixpoint bigint_of_n n := + match n with + | N0 => bigint_zero + | Npos p => bigint_of_pos p + end. + +(** NB: as for [pred] or [minus], [nat_of_bigint], [n_of_bigint] and + [pos_of_bigint] are total and return zero (resp. one) for + non-positive inputs. *) + +Parameter bigint_natlike_rec : forall A, A -> (A->A) -> bigint -> A. +Extract Constant bigint_natlike_rec => "Big.nat_rec". + +Definition nat_of_bigint : bigint -> nat := bigint_natlike_rec _ O S. + +Parameter bigint_poslike_rec : forall A, (A->A) -> (A->A) -> A -> bigint -> A. +Extract Constant bigint_poslike_rec => "Big.positive_rec". + +Definition pos_of_bigint : bigint -> positive := bigint_poslike_rec _ xI xO xH. + +Parameter bigint_zlike_case : + forall A, A -> (bigint->A) -> (bigint->A) -> bigint -> A. +Extract Constant bigint_zlike_case => "Big.z_rec". + +Definition z_of_bigint : bigint -> Z := + bigint_zlike_case _ Z0 (fun i => Zpos (pos_of_bigint i)) + (fun i => Zneg (pos_of_bigint i)). + +Definition n_of_bigint : bigint -> N := + bigint_zlike_case _ N0 (fun i => Npos (pos_of_bigint i)) (fun _ => N0). + +(* Tests: + +Definition small := 1234%nat. +Definition big := 12345678901234567890%positive. + +Definition nat_0 := nat_of_bigint (bigint_of_nat 0). +Definition nat_1 := nat_of_bigint (bigint_of_nat small). +Definition pos_1 := pos_of_bigint (bigint_of_pos 1). +Definition pos_2 := pos_of_bigint (bigint_of_pos big). +Definition n_0 := n_of_bigint (bigint_of_n 0). +Definition n_1 := n_of_bigint (bigint_of_n 1). +Definition n_2 := n_of_bigint (bigint_of_n (Npos big)). +Definition z_0 := z_of_bigint (bigint_of_z 0). +Definition z_1 := z_of_bigint (bigint_of_z 1). +Definition z_2 := z_of_bigint (bigint_of_z (Zpos big)). +Definition z_m1 := z_of_bigint (bigint_of_z (-1)). +Definition z_m2 := z_of_bigint (bigint_of_z (Zneg big)). + +Definition test := + (nat_0, nat_1, pos_1, pos_2, n_0, n_1, n_2, z_0, z_1, z_2, z_m1, z_m2). +Definition check := + (O, small, xH, big, 0%N, 1%N, Npos big, 0%Z, 1%Z, Zpos big, (-1)%Z, Zneg big). + +Extraction "/tmp/test.ml" check test. + +... and we check that test=check +*) \ No newline at end of file diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v new file mode 100644 index 00000000..e729d9ca --- /dev/null +++ b/plugins/extraction/ExtrOcamlIntConv.v @@ -0,0 +1,97 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* int. +Parameter int_opp : int -> int. +Parameter int_twice : int -> int. + +Extract Inlined Constant int => int. +Extract Inlined Constant int_zero => "0". +Extract Inlined Constant int_succ => "succ". +Extract Inlined Constant int_opp => "-". +Extract Inlined Constant int_twice => "2 *". + +Definition int_of_nat : nat -> int := + (fix loop acc n := + match n with + | O => acc + | S n => loop (int_succ acc) n + end) int_zero. + +Fixpoint int_of_pos p := + match p with + | xH => int_succ int_zero + | xO p => int_twice (int_of_pos p) + | xI p => int_succ (int_twice (int_of_pos p)) + end. + +Fixpoint int_of_z z := + match z with + | Z0 => int_zero + | Zpos p => int_of_pos p + | Zneg p => int_opp (int_of_pos p) + end. + +Fixpoint int_of_n n := + match n with + | N0 => int_zero + | Npos p => int_of_pos p + end. + +(** NB: as for [pred] or [minus], [nat_of_int], [n_of_int] and + [pos_of_int] are total and return zero (resp. one) for + non-positive inputs. *) + +Parameter int_natlike_rec : forall A, A -> (A->A) -> int -> A. +Extract Constant int_natlike_rec => +"fun fO fS -> + let rec loop acc i = if i <= 0 then acc else loop (fS acc) (i-1) + in loop fO". + +Definition nat_of_int : int -> nat := int_natlike_rec _ O S. + +Parameter int_poslike_rec : forall A, A -> (A->A) -> (A->A) -> int -> A. +Extract Constant int_poslike_rec => +"fun f1 f2x f2x1 -> + let rec loop i = if i <= 1 then f1 else + if i land 1 = 0 then f2x (loop (i lsr 1)) else f2x1 (loop (i lsr 1)) + in loop". + +Definition pos_of_int : int -> positive := int_poslike_rec _ xH xO xI. + +Parameter int_zlike_case : forall A, A -> (int->A) -> (int->A) -> int -> A. +Extract Constant int_zlike_case => +"fun f0 fpos fneg i -> + if i = 0 then f0 else if i>0 then fpos i else fneg (-i)". + +Definition z_of_int : int -> Z := + int_zlike_case _ Z0 (fun i => Zpos (pos_of_int i)) + (fun i => Zneg (pos_of_int i)). + +Definition n_of_int : int -> N := + int_zlike_case _ N0 (fun i => Npos (pos_of_int i)) (fun _ => N0). + +(** Warning: [z_of_int] is currently wrong for Ocaml's [min_int], + since [min_int] has no positive opposite ([-min_int = min_int]). +*) + +(* +Extraction "/tmp/test.ml" + nat_of_int int_of_nat + pos_of_int int_of_pos + z_of_int int_of_z + n_of_int int_of_n. +*) \ No newline at end of file diff --git a/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v new file mode 100644 index 00000000..491e0258 --- /dev/null +++ b/plugins/extraction/ExtrOcamlNatBigInt.v @@ -0,0 +1,69 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* "Big.big_int" [ "Big.zero" "Big.succ" ] + "Big.nat_case". + +(** Efficient (but uncertified) versions for usual [nat] functions *) + +Extract Constant plus => "Big.add". +Extract Constant mult => "Big.mult". +Extract Constant pred => "fun n -> Big.max Big.zero (Big.pred n)". +Extract Constant minus => "fun n m -> Big.max Big.zero (Big.sub n m)". +Extract Constant max => "Big.max". +Extract Constant min => "Big.min". +Extract Constant nat_beq => "Big.eq". +Extract Constant EqNat.beq_nat => "Big.eq". +Extract Constant EqNat.eq_nat_decide => "Big.eq". + +Extract Constant Peano_dec.eq_nat_dec => "Big.eq". + +Extract Constant Compare_dec.nat_compare => + "Big.compare_case Eq Lt Gt". + +Extract Constant Compare_dec.leb => "Big.le". +Extract Constant Compare_dec.le_lt_dec => "Big.le". +Extract Constant Compare_dec.lt_eq_lt_dec => + "Big.compare_case (Some false) (Some true) None". + +Extract Constant Even.even_odd_dec => + "fun n -> Big.sign (Big.mod n Big.two) = 0". +Extract Constant Div2.div2 => "fun n -> Big.div n Big.two". + +Extract Inductive Euclid.diveucl => "(Big.big_int * Big.big_int)" [""]. +Extract Constant Euclid.eucl_dev => "fun n m -> Big.quomod m n". +Extract Constant Euclid.quotient => "fun n m -> Big.div m n". +Extract Constant Euclid.modulo => "fun n m -> Big.modulo m n". + +(* +Require Import Euclid. +Definition test n m (H:m>0) := + let (q,r,_,_) := eucl_dev m H n in + nat_compare n (q*m+r). + +Extraction "/tmp/test.ml" test fact pred minus max min Div2.div2. +*) diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v new file mode 100644 index 00000000..fe03bc60 --- /dev/null +++ b/plugins/extraction/ExtrOcamlNatInt.v @@ -0,0 +1,75 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* int [ "0" "succ" ] + "(fun fO fS n -> if n=0 then fO () else fS (n-1))". + +(** Efficient (but uncertified) versions for usual [nat] functions *) + +Extract Constant plus => "(+)". +Extract Constant pred => "fun n -> max 0 (n-1)". +Extract Constant minus => "fun n m -> max 0 (n-m)". +Extract Constant mult => "( * )". +Extract Inlined Constant max => max. +Extract Inlined Constant min => min. +Extract Inlined Constant nat_beq => "(=)". +Extract Inlined Constant EqNat.beq_nat => "(=)". +Extract Inlined Constant EqNat.eq_nat_decide => "(=)". + +Extract Inlined Constant Peano_dec.eq_nat_dec => "(=)". + +Extract Constant Compare_dec.nat_compare => + "fun n m -> if n=m then Eq else if n "(<=)". +Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)". +Extract Constant Compare_dec.lt_eq_lt_dec => + "fun n m -> if n>m then None else Some (n "fun n -> n mod 2 = 0". +Extract Constant Div2.div2 => "fun n -> n/2". + +Extract Inductive Euclid.diveucl => "(int * int)" [ "" ]. +Extract Constant Euclid.eucl_dev => "fun n m -> (m/n, m mod n)". +Extract Constant Euclid.quotient => "fun n m -> m/n". +Extract Constant Euclid.modulo => "fun n m -> m mod n". + +(* +Definition test n m (H:m>0) := + let (q,r,_,_) := eucl_dev m H n in + nat_compare n (q*m+r). + +Recursive Extraction test fact. +*) \ No newline at end of file diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v new file mode 100644 index 00000000..3fcd01b0 --- /dev/null +++ b/plugins/extraction/ExtrOcamlString.v @@ -0,0 +1,38 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* char +[ +"(* If this appears, you're using Ascii internals. Please don't *) + (fun (b0,b1,b2,b3,b4,b5,b6,b7) -> + let f b i = if b then 1 lsl i else 0 in + Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))" +] +"(* If this appears, you're using Ascii internals. Please don't *) + (fun f c -> + let n = Char.code c in + let h i = (n land (1 lsl i)) <> 0 in + f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))". + +Extract Constant zero => "'\000'". +Extract Constant one => "'\001'". +Extract Constant shift => + "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)". + +Extract Inlined Constant ascii_dec => "(=)". + +Extract Inductive string => "char list" [ "[]" "(::)" ]. + +(* +Definition test := "ceci est un test"%string. +Recursive Extraction test Ascii.zero Ascii.one. +*) diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v new file mode 100644 index 00000000..08f43d3f --- /dev/null +++ b/plugins/extraction/ExtrOcamlZBigInt.v @@ -0,0 +1,85 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* "Big.big_int" + [ "Big.doubleplusone" "Big.double" "Big.one" ] "Big.positive_case". + +Extract Inductive Z => "Big.big_int" + [ "Big.zero" "" "Big.opp" ] "Big.z_case". + +Extract Inductive N => "Big.big_int" + [ "Big.zero" "" ] "Big.n_case". + +(** Nota: the "" above is used as an identity function "(fun p->p)" *) + +(** Efficient (but uncertified) versions for usual functions *) + +Extract Constant Pplus => "Big.add". +Extract Constant Psucc => "Big.succ". +Extract Constant Ppred => "fun n -> Big.max Big.one (Big.pred n)". +Extract Constant Pminus => "fun n m -> Big.max Big.one (Big.sub n m)". +Extract Constant Pmult => "Big.mult". +Extract Constant Pmin => "Big.min". +Extract Constant Pmax => "Big.max". +Extract Constant Pcompare => + "fun x y c -> Big.compare_case c Lt Gt x y". + +Extract Constant Nplus => "Big.add". +Extract Constant Nsucc => "Big.succ". +Extract Constant Npred => "fun n -> Big.max Big.zero (Big.pred n)". +Extract Constant Nminus => "fun n m -> Big.max Big.zero (Big.sub n m)". +Extract Constant Nmult => "Big.mult". +Extract Constant Nmin => "Big.min". +Extract Constant Nmax => "Big.max". +Extract Constant Ndiv => + "fun a b -> if Big.eq b Big.zero then Big.zero else Big.div a b". +Extract Constant Nmod => + "fun a b -> if Big.eq b Big.zero then Big.zero else Big.modulo a b". +Extract Constant Ncompare => "Big.compare_case Eq Lt Gt". + +Extract Constant Zplus => "Big.add". +Extract Constant Zsucc => "Big.succ". +Extract Constant Zpred => "Big.pred". +Extract Constant Zminus => "Big.sub". +Extract Constant Zmult => "Big.mult". +Extract Constant Zopp => "Big.opp". +Extract Constant Zabs => "Big.abs". +Extract Constant Zmin => "Big.min". +Extract Constant Zmax => "Big.max". +Extract Constant Zcompare => "Big.compare_case Eq Lt Gt". + +Extract Constant Z_of_N => "fun p -> p". +Extract Constant Zabs_N => "Big.abs". + +(** Zdiv and Zmod are quite complex to define in terms of (/) and (mod). + For the moment we don't even try *) + +(** Test: +Require Import ZArith NArith. + +Extraction "/tmp/test.ml" + Pplus Ppred Pminus Pmult Pcompare Npred Nminus Ndiv Nmod Ncompare + Zplus Zmult BinInt.Zcompare Z_of_N Zabs_N Zdiv.Zdiv Zmod. +*) diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v new file mode 100644 index 00000000..d3ea7372 --- /dev/null +++ b/plugins/extraction/ExtrOcamlZInt.v @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* int +[ "(fun p->1+2*p)" "(fun p->2*p)" "1" ] +"(fun f2p1 f2p f1 p -> + if p<=1 then f1 () else if p mod 2 = 0 then f2p (p/2) else f2p1 (p/2))". + +Extract Inductive Z => int [ "0" "" "(~-)" ] +"(fun f0 fp fn z -> if z=0 then f0 () else if z>0 then fp z else fn (-z))". + +Extract Inductive N => int [ "0" "" ] +"(fun f0 fp n -> if n=0 then f0 () else fp n)". + +(** Nota: the "" above is used as an identity function "(fun p->p)" *) + +(** Efficient (but uncertified) versions for usual functions *) + +Extract Constant Pplus => "(+)". +Extract Constant Psucc => "succ". +Extract Constant Ppred => "fun n -> max 1 (n-1)". +Extract Constant Pminus => "fun n m -> max 1 (n-m)". +Extract Constant Pmult => "( * )". +Extract Constant Pmin => "min". +Extract Constant Pmax => "max". +Extract Constant Pcompare => + "fun x y c -> if x=y then c else if x "(+)". +Extract Constant Nsucc => "succ". +Extract Constant Npred => "fun n -> max 0 (n-1)". +Extract Constant Nminus => "fun n m -> max 0 (n-m)". +Extract Constant Nmult => "( * )". +Extract Constant Nmin => "min". +Extract Constant Nmax => "max". +Extract Constant Ndiv => "fun a b -> if b=0 then 0 else a/b". +Extract Constant Nmod => "fun a b -> if b=0 then a else a mod b". +Extract Constant Ncompare => + "fun x y -> if x=y then Eq else if x "(+)". +Extract Constant Zsucc => "succ". +Extract Constant Zpred => "pred". +Extract Constant Zminus => "(-)". +Extract Constant Zmult => "( * )". +Extract Constant Zopp => "(~-)". +Extract Constant Zabs => "abs". +Extract Constant Zmin => "min". +Extract Constant Zmax => "max". +Extract Constant Zcompare => + "fun x y -> if x=y then Eq else if x "fun p -> p". +Extract Constant Zabs_N => "abs". + +(** Zdiv and Zmod are quite complex to define in terms of (/) and (mod). + For the moment we don't even try *) + + diff --git a/plugins/extraction/README b/plugins/extraction/README new file mode 100644 index 00000000..64c871fd --- /dev/null +++ b/plugins/extraction/README @@ -0,0 +1,147 @@ + + Coq Extraction + ============== + + +What is it ? +------------ + +The extraction is a mechanism allowing to produce functional code +(Ocaml/Haskell/Scheme) out of any Coq terms (either programs or +proofs). + +Who did it ? +------------ + +The current implementation (from version 7.0 up to now) has been done +by P. Letouzey during his PhD, helped by J.C. Filliâtre and supervised +by C. Paulin. + +An earlier implementation (versions 6.x) was due to B. Werner and +C. Paulin. + + +Where can we find more information ? +------------------------------------ + +- Coq Reference Manual includes a full chapter about extraction +- P. Letouzey's PhD thesis [3] forms a complete document about + both theory and implementation and test-cases of Coq-extraction +- A more recent article [4] proposes a short overview of extraction +- earlier documents [1] [2] may also be useful. + + +Why a complete re-implementation ? +---------------------------------- + +Extraction code has been completely rewritten since version V6.3. + +1) Principles + +The main goal of the new extraction is to handle any Coq term, even +those upon sort Type, and to produce code that always compiles. +Thus it will never answer something like "Not an ML type", but rather +a dummy term like the ML unit. + +Translation between Coq and ML is based upon the following principles: + +- Terms of sort Prop don't have any computational meaning, so they are +merged into one ML term "__". This part is done according to P. Letouzey's +works [1] and [2]. + +This dummy constant "__" used to be implemented by the unit (), but +we recently found that this constant might be applied in some cases. +So "__" is now in Ocaml a fixpoint that forgets its arguments: + + let __ = let rec f _ = Obj.repr f in Obj.repr f + + +- Terms that are type schemes (i.e. something of type ( : )( : )...s with +s a sort ) don't have any ML counterpart at the term level, since they +are types transformers. In fact they do not have any computational +meaning either. So we also merge them into that dummy term "__". + +- A Coq term gives a ML term or a ML type depending of its type: +type schemes will (try to) give ML types, and all other terms give ML terms. + +And the rest of the translation is (almost) straightforward: an inductive +gives an inductive, etc... + +This gives ML code that have no special reason to typecheck, due +to the incompatibilities between Coq and ML typing systems. In fact +most of the time everything goes right. + +We now verify during extraction that the produced code is typecheckable, +and if it is not we insert unsafe type casting at critical points in the +code, with either "Obj.magic" in Ocaml or "unsafeCoerce" in Haskell. + + +2) Differences with previous extraction (V6.3 and before) + +2.a) The pros + +The ability to extract every Coq term, as explain in the previous +paragraph. + +The ability to extract from a file an ML module (cf Extraction Library in the +documentation) + +You can have a taste of extraction directly at the toplevel by +using the "Extraction " or the "Recursive Extraction ". +This toplevel extraction was already there in V6.3, but was printing +Fw terms. It now prints in the language of your choice: +Ocaml, Haskell or Scheme. + +The optimization done on extracted code has been ported between +V6.3 and V7 and enhanced, and in particular the mechanism of automatic +expansion. + +2.b) The cons + +The presence of some parasite "__" as dummy arguments +in functions. This denotes the rests of a proof part. The previous +extraction was able to remove them totally. The current implementation +removes a good deal of them, but not all. + +This problem is due to extraction upon Type. +For example, let's take this pathological term: + (if b then Set else Prop) : Type +The only way to know if this is an Set (to keep) or a Prop (to remove) +is to compute the boolean b, and we do not want to do that during +extraction. + +There is no more "ML import" feature. You can compensate by using +Axioms, and then "Extract Constant ..." + + + + + +[1]: +Exécution de termes de preuves: une nouvelle méthode d'extraction +pour le Calcul des Constructions Inductives, Pierre Letouzey, +DEA thesis, 2000, +http://www.pps.jussieu.fr/~letouzey/download/rapport_dea.ps.gz + +[2]: +A New Extraction for Coq, Pierre Letouzey, +Types 2002 Post-Workshop Proceedings. +http://www.pps.jussieu.fr/~letouzey/download/extraction2002.ps.gz + +[3]: +Programmation fonctionnelle certifiée: l'extraction de programmes +dans l'assistant Coq. Pierre Letouzey, PhD thesis, 2004. +http://www.pps.jussieu.fr/~letouzey/download/these_letouzey.ps.gz +http://www.pps.jussieu.fr/~letouzey/download/these_letouzey_English.ps.gz + +[4]: +Coq Extraction, An overview. Pierre Letouzey. CiE2008. +http://www.pps.jussieu.fr/~letouzey/download/letouzey_extr_cie08.pdf + + + + + + + + diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml new file mode 100644 index 00000000..9a5bf56b --- /dev/null +++ b/plugins/extraction/big.ml @@ -0,0 +1,154 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 0 then fp z else fn (opp z) + +let compare_case e l g x y = + let s = compare x y in if s = 0 then e else if s<0 then l else g + +let nat_rec fO fS = + let rec loop acc n = + if sign n <= 0 then acc else loop (fS acc) (pred n) + in loop fO + +let positive_rec f2p1 f2p f1 = + let rec loop n = + if le n one then f1 + else + let (q,r) = quomod n two in + if eq r zero then f2p (loop q) else f2p1 (loop q) + in loop + +let z_rec fO fp fn = z_case (fun _ -> fO) fp fn diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml new file mode 100644 index 00000000..1db1c786 --- /dev/null +++ b/plugins/extraction/common.ml @@ -0,0 +1,535 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* true | _ -> false + +(*s Some pretty-print utility functions. *) + +let pp_par par st = if par then str "(" ++ st ++ str ")" else st + +let pp_apply st par args = match args with + | [] -> st + | _ -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args)) + +let pr_binding = function + | [] -> mt () + | l -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l + +let fnl2 () = fnl () ++ fnl () + +let space_if = function true -> str " " | false -> mt () + +let sec_space_if = function true -> spc () | false -> mt () + +let is_digit = function + | '0'..'9' -> true + | _ -> false + +let begins_with_CoqXX s = + let n = String.length s in + n >= 4 && s.[0] = 'C' && s.[1] = 'o' && s.[2] = 'q' && + let i = ref 3 in + try while !i < n do + if s.[!i] = '_' then i:=n (*Stop*) + else if is_digit s.[!i] then incr i + else raise Not_found + done; true + with Not_found -> false + +let unquote s = + if lang () <> Scheme then s + else + let s = String.copy s in + for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done; + s + +let rec qualify delim = function + | [] -> assert false + | [s] -> s + | ""::l -> qualify delim l + | s::l -> s^delim^(qualify delim l) + +let dottify = qualify "." +let pseudo_qualify = qualify "__" + +(*s Uppercase/lowercase renamings. *) + +let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false +let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false + +let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id)) +let uppercase_id id = + let s = string_of_id id in + assert (s<>""); + if s.[0] = '_' then id_of_string ("Coq_"^s) + else id_of_string (String.capitalize s) + +type kind = Term | Type | Cons | Mod + +let upperkind = function + | Type -> lang () = Haskell + | Term -> false + | Cons | Mod -> true + +let kindcase_id k id = + if upperkind k then uppercase_id id else lowercase_id id + +(*s de Bruijn environments for programs *) + +type env = identifier list * Idset.t + +(*s Generic renaming issues for local variable names. *) + +let rec rename_id id avoid = + if Idset.mem id avoid then rename_id (lift_subscript id) avoid else id + +let rec rename_vars avoid = function + | [] -> + [], avoid + | id :: idl when id == dummy_name -> + (* we don't rename dummy binders *) + let (idl', avoid') = rename_vars avoid idl in + (id :: idl', avoid') + | id :: idl -> + let (idl, avoid) = rename_vars avoid idl in + let id = rename_id (lowercase_id id) avoid in + (id :: idl, Idset.add id avoid) + +let rename_tvars avoid l = + let rec rename avoid = function + | [] -> [],avoid + | id :: idl -> + let id = rename_id (lowercase_id id) avoid in + let idl, avoid = rename (Idset.add id avoid) idl in + (id :: idl, avoid) in + fst (rename avoid l) + +let push_vars ids (db,avoid) = + let ids',avoid' = rename_vars avoid ids in + ids', (ids' @ db, avoid') + +let get_db_name n (db,_) = + let id = List.nth db (pred n) in + if id = dummy_name then id_of_string "__" else id + + +(*S Renamings of global objects. *) + +(*s Tables of global renamings *) + +let register_cleanup, do_cleanup = + let funs = ref [] in + (fun f -> funs:=f::!funs), (fun () -> List.iter (fun f -> f ()) !funs) + +type phase = Pre | Impl | Intf + +let set_phase, get_phase = + let ph = ref Impl in ((:=) ph), (fun () -> !ph) + +let set_keywords, get_keywords = + let k = ref Idset.empty in + ((:=) k), (fun () -> !k) + +let add_global_ids, get_global_ids = + let ids = ref Idset.empty in + register_cleanup (fun () -> ids := get_keywords ()); + let add s = ids := Idset.add s !ids + and get () = !ids + in (add,get) + +let empty_env () = [], get_global_ids () + +let mktable autoclean = + let h = Hashtbl.create 97 in + if autoclean then register_cleanup (fun () -> Hashtbl.clear h); + (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h) + +(* A table recording objects in the first level of all MPfile *) + +let add_mpfiles_content,get_mpfiles_content,clear_mpfiles_content = + mktable false + +(*s The list of external modules that will be opened initially *) + +let mpfiles_add, mpfiles_mem, mpfiles_list, mpfiles_clear = + let m = ref MPset.empty in + let add mp = m:=MPset.add mp !m + and mem mp = MPset.mem mp !m + and list () = MPset.elements !m + and clear () = m:=MPset.empty + in + register_cleanup clear; + (add,mem,list,clear) + +(*s List of module parameters that we should alpha-rename *) + +let params_ren_add, params_ren_mem = + let m = ref MPset.empty in + let add mp = m:=MPset.add mp !m + and mem mp = MPset.mem mp !m + and clear () = m:=MPset.empty + in + register_cleanup clear; + (add,mem) + +(*s table indicating the visible horizon at a precise moment, + i.e. the stack of structures we are inside. + + - The sequence of [mp] parts should have the following form: + a [MPfile] at the beginning, and then more and more [MPdot] + over this [MPfile], or [MPbound] when inside the type of a + module parameter. + + - the [params] are the [MPbound] when [mp] is a functor, + the innermost [MPbound] coming first in the list. + + - The [content] part is used to record all the names already + seen at this level. +*) + +type visible_layer = { mp : module_path; + params : module_path list; + content : ((kind*string),label) Hashtbl.t } + +let pop_visible, push_visible, get_visible = + let vis = ref [] in + register_cleanup (fun () -> vis := []); + let pop () = + let v = List.hd !vis in + (* we save the 1st-level-content of MPfile for later use *) + if get_phase () = Impl && modular () && is_modfile v.mp + then add_mpfiles_content v.mp v.content; + vis := List.tl !vis + and push mp mps = + vis := { mp = mp; params = mps; content = Hashtbl.create 97 } :: !vis + and get () = !vis + in (pop,push,get) + +let get_visible_mps () = List.map (function v -> v.mp) (get_visible ()) +let top_visible () = match get_visible () with [] -> assert false | v::_ -> v +let top_visible_mp () = (top_visible ()).mp +let add_visible ks l = Hashtbl.add (top_visible ()).content ks l + +(* table of local module wrappers used to provide non-ambiguous names *) + +let add_duplicate, check_duplicate = + let index = ref 0 and dups = ref Gmap.empty in + register_cleanup (fun () -> index := 0; dups := Gmap.empty); + let add mp l = + incr index; + let ren = "Coq__" ^ string_of_int (!index) in + dups := Gmap.add (mp,l) ren !dups + and check mp l = Gmap.find (mp, l) !dups + in (add,check) + +type reset_kind = AllButExternal | Everything + +let reset_renaming_tables flag = + do_cleanup (); + if flag = Everything then clear_mpfiles_content () + +(*S Renaming functions *) + +(* This function creates from [id] a correct uppercase/lowercase identifier. + This is done by adding a [Coq_] or [coq_] prefix. To avoid potential clashes + with previous [Coq_id] variable, these prefixes are duplicated if already + existing. *) + +let modular_rename k id = + let s = string_of_id id in + let prefix,is_ok = + if upperkind k then "Coq_",is_upper else "coq_",is_lower + in + if not (is_ok s) || + (Idset.mem id (get_keywords ())) || + (String.length s >= 4 && String.sub s 0 4 = prefix) + then prefix ^ s + else s + +(*s For monolithic extraction, first-level modules might have to be renamed + with unique numbers *) + +let modfstlev_rename = + let add_prefixes,get_prefixes,_ = mktable true in + fun l -> + let coqid = id_of_string "Coq" in + let id = id_of_label l in + try + let coqset = get_prefixes id in + let nextcoq = next_ident_away coqid coqset in + add_prefixes id (nextcoq::coqset); + (string_of_id nextcoq)^"_"^(string_of_id id) + with Not_found -> + let s = string_of_id id in + if is_lower s || begins_with_CoqXX s then + (add_prefixes id [coqid]; "Coq_"^s) + else + (add_prefixes id []; s) + +(*s Creating renaming for a [module_path] : first, the real function ... *) + +let rec mp_renaming_fun mp = match mp with + | _ when not (modular ()) && at_toplevel mp -> [""] + | MPdot (mp,l) -> + let lmp = mp_renaming mp in + if lmp = [""] then (modfstlev_rename l)::lmp + else (modular_rename Mod (id_of_label l))::lmp + | MPbound mbid -> + let s = modular_rename Mod (id_of_mbid mbid) in + if not (params_ren_mem mp) then [s] + else let i,_,_ = repr_mbid mbid in [s^"__"^string_of_int i] + | MPfile _ when not (modular ()) -> assert false (* see [at_toplevel] above *) + | MPfile _ -> + assert (get_phase () = Pre); + let current_mpfile = (list_last (get_visible ())).mp in + if mp <> current_mpfile then mpfiles_add mp; + [string_of_modfile mp] + +(* ... and its version using a cache *) + +and mp_renaming = + let add,get,_ = mktable true in + fun x -> + try if is_mp_bound (base_mp x) then raise Not_found; get x + with Not_found -> let y = mp_renaming_fun x in add x y; y + +(*s Renamings creation for a [global_reference]: we build its fully-qualified + name in a [string list] form (head is the short name). *) + +let ref_renaming_fun (k,r) = + let mp = modpath_of_r r in + let l = mp_renaming mp in + let l = if lang () <> Ocaml && not (modular ()) then [""] else l in + let s = + if l = [""] (* this happens only at toplevel of the monolithic case *) + then + let globs = Idset.elements (get_global_ids ()) in + let id = next_ident_away (kindcase_id k (safe_basename_of_global r)) globs in + string_of_id id + else modular_rename k (safe_basename_of_global r) + in + add_global_ids (id_of_string s); + s::l + +(* Cached version of the last function *) + +let ref_renaming = + let add,get,_ = mktable true in + fun x -> + try if is_mp_bound (base_mp (modpath_of_r (snd x))) then raise Not_found; get x + with Not_found -> let y = ref_renaming_fun x in add x y; y + +(* [visible_clash mp0 (k,s)] checks if [mp0-s] of kind [k] + can be printed as [s] in the current context of visible + modules. More precisely, we check if there exists a + visible [mp] that contains [s]. + The verification stops if we encounter [mp=mp0]. *) + +let rec clash mem mp0 ks = function + | [] -> false + | mp :: _ when mp = mp0 -> false + | mp :: _ when mem mp ks -> true + | _ :: mpl -> clash mem mp0 ks mpl + +let mpfiles_clash mp0 ks = + clash (fun mp -> Hashtbl.mem (get_mpfiles_content mp)) mp0 ks + (List.rev (mpfiles_list ())) + +let rec params_lookup mp0 ks = function + | [] -> false + | param :: _ when mp0 = param -> true + | param :: params -> + if ks = (Mod, List.hd (mp_renaming param)) then params_ren_add param; + params_lookup mp0 ks params + +let visible_clash mp0 ks = + let rec clash = function + | [] -> false + | v :: _ when v.mp = mp0 -> false + | v :: vis -> + let b = Hashtbl.mem v.content ks in + if b && not (is_mp_bound mp0) then true + else begin + if b then params_ren_add mp0; + if params_lookup mp0 ks v.params then false + else clash vis + end + in clash (get_visible ()) + +(* Same, but with verbose output (and mp0 shouldn't be a MPbound) *) + +let visible_clash_dbg mp0 ks = + let rec clash = function + | [] -> None + | v :: _ when v.mp = mp0 -> None + | v :: vis -> + try Some (v.mp,Hashtbl.find v.content ks) + with Not_found -> + if params_lookup mp0 ks v.params then None + else clash vis + in clash (get_visible ()) + +(* After the 1st pass, we can decide which modules will be opened initially *) + +let opened_libraries () = + if not (modular ()) then [] + else + let used = mpfiles_list () in + let rec check_elsewhere avoid = function + | [] -> [] + | mp :: mpl -> + let clash s = Hashtbl.mem (get_mpfiles_content mp) (Mod,s) in + if List.exists clash avoid + then check_elsewhere avoid mpl + else mp :: check_elsewhere (string_of_modfile mp :: avoid) mpl + in + let opened = check_elsewhere [] used in + mpfiles_clear (); + List.iter mpfiles_add opened; + opened + +(*s On-the-fly qualification issues for both monolithic or modular extraction. *) + +(* First, a function that factorize the printing of both [global_reference] + and module names for ocaml. When [k=Mod] then [olab=None], otherwise it + contains the label of the reference to print. + [rls] is the string list giving the qualified name, short name at the end. + Invariant: [List.length rls >= 2], simpler situations are handled elsewhere. *) + +(* In Coq, we can qualify [M.t] even if we are inside [M], but in Ocaml we + cannot do that. So, if [t] gets hidden and we need a long name for it, + we duplicate the _definition_ of t in a Coq__XXX module, and similarly + for a sub-module [M.N] *) + +let pp_duplicate k' prefix mp rls olab = + let rls', lbl = + if k'<>Mod then + (* Here rls=[s], the ref to print is ., and olab<>None *) + rls, Option.get olab + else + (* Here rls=s::rls', we search the label for s inside mp *) + List.tl rls, get_nth_label_mp (mp_length mp - mp_length prefix) mp + in + try dottify (check_duplicate prefix lbl :: rls') + with Not_found -> + assert (get_phase () = Pre); (* otherwise it's too late *) + add_duplicate prefix lbl; dottify rls + +let fstlev_ks k = function + | [] -> assert false + | [s] -> k,s + | s::_ -> Mod,s + +(* [pp_ocaml_local] : [mp] has something in common with [top_visible ()] + but isn't equal to it *) + +let pp_ocaml_local k prefix mp rls olab = + (* what is the largest prefix of [mp] that belongs to [visible]? *) + assert (k <> Mod || mp <> prefix); (* mp as whole module isn't in itself *) + let rls' = list_skipn (mp_length prefix) rls in + let k's = fstlev_ks k rls' in + (* Reference r / module path mp is of the form [.s.<...>]. *) + if not (visible_clash prefix k's) then dottify rls' + else pp_duplicate (fst k's) prefix mp rls' olab + +(* [pp_ocaml_bound] : [mp] starts with a [MPbound], and we are not inside + (i.e. we are not printing the type of the module parameter) *) + +let pp_ocaml_bound base rls = + (* clash with a MPbound will be detected and fixed by renaming this MPbound *) + if get_phase () = Pre then ignore (visible_clash base (Mod,List.hd rls)); + dottify rls + +(* [pp_ocaml_extern] : [mp] isn't local, it is defined in another [MPfile]. *) + +let pp_ocaml_extern k base rls = match rls with + | [] | [_] -> assert false + | base_s :: rls' -> + let k's = fstlev_ks k rls' in + if modular () && (mpfiles_mem base) && + (not (mpfiles_clash base k's)) && + (not (visible_clash base k's)) + then (* Standard situation of an object in another file: *) + (* Thanks to the "open" of this file we remove its name *) + dottify rls' + else match visible_clash_dbg base (Mod,base_s) with + | None -> dottify rls + | Some (mp,l) -> error_module_clash base (MPdot (mp,l)) + +(* [pp_ocaml_gen] : choosing between [pp_ocaml_extern] or [pp_ocaml_extern] *) + +let pp_ocaml_gen k mp rls olab = + match common_prefix_from_list mp (get_visible_mps ()) with + | Some prefix -> pp_ocaml_local k prefix mp rls olab + | None -> + let base = base_mp mp in + if is_mp_bound base then pp_ocaml_bound base rls + else pp_ocaml_extern k base rls + +(* For Haskell, things are simplier: we have removed (almost) all structures *) + +let pp_haskell_gen k mp rls = match rls with + | [] -> assert false + | s::rls' -> + (if base_mp mp <> top_visible_mp () then s ^ "." else "") ^ + (if upperkind k then "" else "_") ^ pseudo_qualify rls' + +(* Main name printing function for a reference *) + +let pp_global k r = + let ls = ref_renaming (k,r) in + assert (List.length ls > 1); + let s = List.hd ls in + let mp,_,l = repr_of_r r in + if mp = top_visible_mp () then + (* simpliest situation: definition of r (or use in the same context) *) + (* we update the visible environment *) + (add_visible (k,s) l; unquote s) + else + let rls = List.rev ls in (* for what come next it's easier this way *) + match lang () with + | Scheme -> unquote s (* no modular Scheme extraction... *) + | Haskell -> if modular () then pp_haskell_gen k mp rls else s + | Ocaml -> pp_ocaml_gen k mp rls (Some l) + +(* The next function is used only in Ocaml extraction...*) + +let pp_module mp = + let ls = mp_renaming mp in + match mp with + | MPdot (mp0,l) when mp0 = top_visible_mp () -> + (* simpliest situation: definition of mp (or use in the same context) *) + (* we update the visible environment *) + let s = List.hd ls in + add_visible (Mod,s) l; s + | _ -> pp_ocaml_gen Mod mp (List.rev ls) None + + diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli new file mode 100644 index 00000000..93be15d1 --- /dev/null +++ b/plugins/extraction/common.mli @@ -0,0 +1,59 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds +val space_if : bool -> std_ppcmds +val sec_space_if : bool -> std_ppcmds + +val pp_par : bool -> std_ppcmds -> std_ppcmds +val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds +val pr_binding : identifier list -> std_ppcmds + +val rename_id : identifier -> Idset.t -> identifier + +type env = identifier list * Idset.t +val empty_env : unit -> env + +val rename_vars: Idset.t -> identifier list -> env +val rename_tvars: Idset.t -> identifier list -> identifier list +val push_vars : identifier list -> env -> identifier list * env +val get_db_name : int -> env -> identifier + +type phase = Pre | Impl | Intf + +val set_phase : phase -> unit +val get_phase : unit -> phase + +val opened_libraries : unit -> module_path list + +type kind = Term | Type | Cons | Mod + +val pp_global : kind -> global_reference -> string +val pp_module : module_path -> string + +val top_visible_mp : unit -> module_path +(* In [push_visible], the [module_path list] corresponds to + module parameters, the innermost one coming first in the list *) +val push_visible : module_path -> module_path list -> unit +val pop_visible : unit -> unit + +val check_duplicate : module_path -> label -> string + +type reset_kind = AllButExternal | Everything + +val reset_renaming_tables : reset_kind -> unit + +val set_keywords : Idset.t -> unit diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml new file mode 100644 index 00000000..ab9c242a --- /dev/null +++ b/plugins/extraction/extract_env.ml @@ -0,0 +1,540 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + let mp,_,l = repr_kn kn in + let seb = match Libobject.object_tag o with + | "CONSTANT" -> SFBconst (Global.lookup_constant (constant_of_kn kn)) + | "INDUCTIVE" -> SFBmind (Global.lookup_mind (mind_of_kn kn)) + | "MODULE" -> SFBmodule (Global.lookup_module (MPdot (mp,l))) + | "MODULE TYPE" -> + SFBmodtype (Global.lookup_modtype (MPdot (mp,l))) + | _ -> failwith "caught" + in l,seb + | _ -> failwith "caught" + in + match current_toplevel () with + | _ -> SEBstruct (List.rev (map_succeed get_reference seg)) + + +let environment_until dir_opt = + let rec parse = function + | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()] + | [] -> [] + | d :: l -> + match (Global.lookup_module (MPfile d)).mod_expr with + | Some meb -> + if dir_opt = Some d then [MPfile d, meb] + else (MPfile d, meb) :: (parse l) + | _ -> assert false + in parse (Library.loaded_libraries ()) + + +(*s Visit: + a structure recording the needed dependencies for the current extraction *) + +module type VISIT = sig + (* Reset the dependencies by emptying the visit lists *) + val reset : unit -> unit + + (* Add the module_path and all its prefixes to the mp visit list *) + val add_mp : module_path -> unit + + (* Add kernel_name / constant / reference / ... in the visit lists. + These functions silently add the mp of their arg in the mp list *) + val add_kn : mutual_inductive -> unit + val add_con : constant -> unit + val add_ref : global_reference -> unit + val add_decl_deps : ml_decl -> unit + val add_spec_deps : ml_spec -> unit + + (* Test functions: + is a particular object a needed dependency for the current extraction ? *) + val needed_kn : mutual_inductive -> bool + val needed_con : constant -> bool + val needed_mp : module_path -> bool +end + +module Visit : VISIT = struct + (* What used to be in a single KNset should now be split into a KNset + (for inductives and modules names) and a Cset for constants + (and still the remaining MPset) *) + type must_visit = + { mutable kn : Mindset.t; mutable con : Cset.t; mutable mp : MPset.t } + (* the imperative internal visit lists *) + let v = { kn = Mindset.empty ; con = Cset.empty ; mp = MPset.empty } + (* the accessor functions *) + let reset () = v.kn <- Mindset.empty; v.con <- Cset.empty; v.mp <- MPset.empty + let needed_kn kn = Mindset.mem kn v.kn + let needed_con c = Cset.mem c v.con + let needed_mp mp = MPset.mem mp v.mp + let add_mp mp = + check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp + let add_kn kn = v.kn <- Mindset.add kn v.kn; add_mp (mind_modpath kn) + let add_con c = v.con <- Cset.add c v.con; add_mp (con_modpath c) + let add_ref = function + | ConstRef c -> add_con c + | IndRef (kn,_) | ConstructRef ((kn,_),_) -> add_kn kn + | VarRef _ -> assert false + let add_decl_deps = decl_iter_references add_ref add_ref add_ref + let add_spec_deps = spec_iter_references add_ref add_ref add_ref +end + +exception Impossible + +let check_arity env cb = + let t = Typeops.type_of_constant_type env cb.const_type in + if Reduction.is_arity env t then raise Impossible + +let check_fix env cb i = + match cb.const_body with + | None -> raise Impossible + | Some lbody -> + match kind_of_term (Declarations.force lbody) with + | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd) + | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd) + | _ -> raise Impossible + +let factor_fix env l cb msb = + let _,recd as check = check_fix env cb 0 in + let n = Array.length (let fi,_,_ = recd in fi) in + if n = 1 then [|l|], recd, msb + else begin + if List.length msb < n-1 then raise Impossible; + let msb', msb'' = list_chop (n-1) msb in + let labels = Array.make n l in + list_iter_i + (fun j -> + function + | (l,SFBconst cb') -> + if check <> check_fix env cb' (j+1) then raise Impossible; + labels.(j+1) <- l; + | _ -> raise Impossible) msb'; + labels, recd, msb'' + end + +(** Expanding a [struct_expr_body] into a version without abbreviations + or functor applications. This is done via a detour to entries + (hack proposed by Elie) +*) + +let rec seb2mse = function + | SEBapply (s,s',_) -> Entries.MSEapply(seb2mse s, seb2mse s') + | SEBident mp -> Entries.MSEident mp + | _ -> failwith "seb2mse: received a non-atomic seb" + +let expand_seb env mp seb = + let seb,_,_,_ = + Mod_typing.translate_struct_module_entry env mp true (seb2mse seb) + in seb + +(** When possible, we use the nicer, shorter, algebraic type structures + instead of the expanded ones. *) + +let my_type_of_mb mb = + let m0 = mb.mod_type in + match mb.mod_type_alg with Some m -> m0,m | None -> m0,m0 + +let my_type_of_mtb mtb = + let m0 = mtb.typ_expr in + match mtb.typ_expr_alg with Some m -> m0,m | None -> m0,m0 + +(** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def]. + To check with Elie. *) + +let rec msid_of_seb = function + | SEBident mp -> mp + | SEBwith (seb,_) -> msid_of_seb seb + | _ -> assert false + +let env_for_mtb_with env mp seb idl = + let sig_b = match seb with + | SEBstruct(sig_b) -> sig_b + | _ -> assert false + in + let l = label_of_id (List.hd idl) in + let before = fst (list_split_when (fun (l',_) -> l=l') sig_b) in + Modops.add_signature mp before empty_delta_resolver env + +(* From a [structure_body] (i.e. a list of [structure_field_body]) + to specifications. *) + +let rec extract_sfb_spec env mp = function + | [] -> [] + | (l,SFBconst cb) :: msig -> + let kn = make_con mp empty_dirpath l in + let s = extract_constant_spec env kn cb in + let specs = extract_sfb_spec env mp msig in + if logical_spec s then specs + else begin Visit.add_spec_deps s; (l,Spec s) :: specs end + | (l,SFBmind _) :: msig -> + let kn = make_kn mp empty_dirpath l in + let mind = mind_of_kn kn in + let s = Sind (kn, extract_inductive env mind) in + let specs = extract_sfb_spec env mp msig in + if logical_spec s then specs + else begin Visit.add_spec_deps s; (l,Spec s) :: specs end + | (l,SFBmodule mb) :: msig -> + let specs = extract_sfb_spec env mp msig in + let spec = extract_seb_spec env mb.mod_mp (my_type_of_mb mb) in + (l,Smodule spec) :: specs + | (l,SFBmodtype mtb) :: msig -> + let specs = extract_sfb_spec env mp msig in + let spec = extract_seb_spec env mtb.typ_mp (my_type_of_mtb mtb) in + (l,Smodtype spec) :: specs + +(* From [struct_expr_body] to specifications *) + +(* Invariant: the [seb] given to [extract_seb_spec] should either come + from a [mod_type] or [type_expr] field, or their [_alg] counterparts. + This way, any encountered [SEBident] should be a true module type. +*) + +and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with + | SEBident mp -> Visit.add_mp mp; MTident mp + | SEBwith(seb',With_definition_body(idl,cb))-> + let env' = env_for_mtb_with env (msid_of_seb seb') seb idl in + let mt = extract_seb_spec env mp1 (seb,seb') in + (match extract_with_type env' cb with (* cb peut contenir des kn *) + | None -> mt + | Some (vl,typ) -> MTwith(mt,ML_With_type(idl,vl,typ))) + | SEBwith(seb',With_module_body(idl,mp))-> + Visit.add_mp mp; + MTwith(extract_seb_spec env mp1 (seb,seb'), + ML_With_module(idl,mp)) + | SEBfunctor (mbid, mtb, seb_alg') -> + let seb' = match seb with + | SEBfunctor (mbid',_,seb') when mbid' = mbid -> seb' + | _ -> assert false + in + let mp = MPbound mbid in + let env' = Modops.add_module (Modops.module_body_of_type mp mtb) env in + MTfunsig (mbid, extract_seb_spec env mp (my_type_of_mtb mtb), + extract_seb_spec env' mp1 (seb',seb_alg')) + | SEBstruct (msig) -> + let env' = Modops.add_signature mp1 msig empty_delta_resolver env in + MTsig (mp1, extract_sfb_spec env' mp1 msig) + | SEBapply _ -> + if seb <> seb_alg then extract_seb_spec env mp1 (seb,seb) + else assert false + + + +(* From a [structure_body] (i.e. a list of [structure_field_body]) + to implementations. + + NB: when [all=false], the evaluation order of the list is + important: last to first ensures correct dependencies. +*) + +let rec extract_sfb env mp all = function + | [] -> [] + | (l,SFBconst cb) :: msb -> + (try + let vl,recd,msb = factor_fix env l cb msb in + let vc = Array.map (make_con mp empty_dirpath) vl in + let ms = extract_sfb env mp all msb in + let b = array_exists Visit.needed_con vc in + if all || b then + let d = extract_fixpoint env vc recd in + if (not b) && (logical_decl d) then ms + else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end + else ms + with Impossible -> + let ms = extract_sfb env mp all msb in + let c = make_con mp empty_dirpath l in + let b = Visit.needed_con c in + if all || b then + let d = extract_constant env c cb in + if (not b) && (logical_decl d) then ms + else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end + else ms) + | (l,SFBmind mib) :: msb -> + let ms = extract_sfb env mp all msb in + let kn = make_kn mp empty_dirpath l in + let mind = mind_of_kn kn in + let b = Visit.needed_kn mind in + if all || b then + let d = Dind (kn, extract_inductive env mind) in + if (not b) && (logical_decl d) then ms + else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end + else ms + | (l,SFBmodule mb) :: msb -> + let ms = extract_sfb env mp all msb in + let mp = MPdot (mp,l) in + if all || Visit.needed_mp mp then + (l,SEmodule (extract_module env mp true mb)) :: ms + else ms + | (l,SFBmodtype mtb) :: msb -> + let ms = extract_sfb env mp all msb in + let mp = MPdot (mp,l) in + if all || Visit.needed_mp mp then + (l,SEmodtype (extract_seb_spec env mp (my_type_of_mtb mtb))) :: ms + else ms + +(* From [struct_expr_body] to implementations *) + +and extract_seb env mp all = function + | (SEBident _ | SEBapply _) as seb when lang () <> Ocaml -> + (* in Haskell/Scheme, we expand everything *) + extract_seb env mp all (expand_seb env mp seb) + | SEBident mp -> + if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; + Visit.add_mp mp; MEident mp + | SEBapply (meb, meb',_) -> + MEapply (extract_seb env mp true meb, + extract_seb env mp true meb') + | SEBfunctor (mbid, mtb, meb) -> + let mp1 = MPbound mbid in + let env' = Modops.add_module (Modops.module_body_of_type mp1 mtb) + env in + MEfunctor (mbid, extract_seb_spec env mp1 (my_type_of_mtb mtb), + extract_seb env' mp true meb) + | SEBstruct (msb) -> + let env' = Modops.add_signature mp msb empty_delta_resolver env in + MEstruct (mp,extract_sfb env' mp all msb) + | SEBwith (_,_) -> anomaly "Not available yet" + +and extract_module env mp all mb = + (* [mb.mod_expr <> None ], since we look at modules from outside. *) + (* Example of module with empty [mod_expr] is X inside a Module F [X:SIG]. *) + { ml_mod_expr = extract_seb env mp all (Option.get mb.mod_expr); + ml_mod_type = extract_seb_spec env mp (my_type_of_mb mb) } + + +let unpack = function MEstruct (_,sel) -> sel | _ -> assert false + +let mono_environment refs mpl = + Visit.reset (); + List.iter Visit.add_ref refs; + List.iter Visit.add_mp mpl; + let env = Global.env () in + let l = List.rev (environment_until None) in + List.rev_map + (fun (mp,m) -> mp, unpack (extract_seb env mp false m)) l + +(**************************************) +(*S Part II : Input/Output primitives *) +(**************************************) + +let descr () = match lang () with + | Ocaml -> Ocaml.ocaml_descr + | Haskell -> Haskell.haskell_descr + | Scheme -> Scheme.scheme_descr + +(* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli" + Works similarly for the other languages. *) + +let default_id = id_of_string "Main" + +let mono_filename f = + let d = descr () in + match f with + | None -> None, None, default_id + | Some f -> + let f = + if Filename.check_suffix f d.file_suffix then + Filename.chop_suffix f d.file_suffix + else f + in + let id = + if lang () <> Haskell then default_id + else try id_of_string (Filename.basename f) + with _ -> error "Extraction: provided filename is not a valid identifier" + in + Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id + +(* Builds a suitable filename from a module id *) + +let module_filename mp = + let f = file_of_modfile mp in + let d = descr () in + Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id_of_string f + +(*s Extraction of one decl to stdout. *) + +let print_one_decl struc mp decl = + let d = descr () in + reset_renaming_tables AllButExternal; + set_phase Pre; + ignore (d.pp_struct struc); + set_phase Impl; + push_visible mp []; + msgnl (d.pp_decl decl); + pop_visible () + +(*s Extraction of a ml struct to a file. *) + +let formatter dry file = + if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) + else match file with + | None -> !Pp_control.std_ft + | Some cout -> + let ft = Pp_control.with_output_to cout in + Option.iter (Format.pp_set_margin ft) (Pp_control.get_margin ()); + ft + +let print_structure_to_file (fn,si,mo) dry struc = + let d = descr () in + reset_renaming_tables AllButExternal; + let unsafe_needs = { + mldummy = struct_ast_search ((=) MLdummy) struc; + tdummy = struct_type_search Mlutil.isDummy struc; + tunknown = struct_type_search ((=) Tunknown) struc; + magic = + if lang () <> Haskell then false + else struct_ast_search (function MLmagic _ -> true | _ -> false) struc } + in + (* First, a dry run, for computing objects to rename or duplicate *) + set_phase Pre; + let devnull = formatter true None in + msg_with devnull (d.pp_struct struc); + let opened = opened_libraries () in + (* Print the implementation *) + let cout = if dry then None else Option.map open_out fn in + let ft = formatter dry cout in + begin try + (* The real printing of the implementation *) + set_phase Impl; + msg_with ft (d.preamble mo opened unsafe_needs); + msg_with ft (d.pp_struct struc); + Option.iter close_out cout; + with e -> + Option.iter close_out cout; raise e + end; + if not dry then Option.iter info_file fn; + (* Now, let's print the signature *) + Option.iter + (fun si -> + let cout = open_out si in + let ft = formatter false (Some cout) in + begin try + set_phase Intf; + msg_with ft (d.sig_preamble mo opened unsafe_needs); + msg_with ft (d.pp_sig (signature_of_structure struc)); + close_out cout; + with e -> + close_out cout; raise e + end; + info_file si) + (if dry then None else si) + + +(*********************************************) +(*s Part III: the actual extraction commands *) +(*********************************************) + + +let reset () = + Visit.reset (); reset_tables (); reset_renaming_tables Everything + +let init modular = + check_inside_section (); check_inside_module (); + set_keywords (descr ()).keywords; + set_modular modular; + reset (); + if modular && lang () = Scheme then error_scheme () + +(* From a list of [reference], let's retrieve whether they correspond + to modules or [global_reference]. Warn the user if both is possible. *) + +let rec locate_ref = function + | [] -> [],[] + | r::l -> + let q = snd (qualid_of_reference r) in + let mpo = try Some (Nametab.locate_module q) with Not_found -> None + and ro = try Some (Nametab.locate q) with Not_found -> None in + match mpo, ro with + | None, None -> Nametab.error_global_not_found q + | None, Some r -> let refs,mps = locate_ref l in r::refs,mps + | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps + | Some mp, Some r -> + warning_both_mod_and_cst q mp r; + let refs,mps = locate_ref l in refs,mp::mps + +(*s Recursive extraction in the Coq toplevel. The vernacular command is + \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when + extracting to a file with the command: + \verb!Extraction "file"! [qualid1] ... [qualidn]. *) + +let full_extr f (refs,mps) = + init false; + List.iter (fun mp -> if is_modfile mp then error_MPfile_as_mod mp true) mps; + let struc = optimize_struct refs (mono_environment refs mps) in + warning_axioms (); + print_structure_to_file (mono_filename f) false struc; + reset () + +let full_extraction f lr = full_extr f (locate_ref lr) + +(*s Simple extraction in the Coq toplevel. The vernacular command + is \verb!Extraction! [qualid]. *) + +let simple_extraction r = match locate_ref [r] with + | ([], [mp]) as p -> full_extr None p + | [r],[] -> + init false; + let struc = optimize_struct [r] (mono_environment [r] []) in + let d = get_decl_in_structure r struc in + warning_axioms (); + if is_custom r then msgnl (str "(** User defined extraction *)"); + print_one_decl struc (modpath_of_r r) d; + reset () + | _ -> assert false + + +(*s (Recursive) Extraction of a library. The vernacular command is + \verb!(Recursive) Extraction Library! [M]. *) + +let extraction_library is_rec m = + init true; + let dir_m = + let q = qualid_of_ident m in + try Nametab.full_name_module q with Not_found -> error_unknown_module q + in + Visit.add_mp (MPfile dir_m); + let env = Global.env () in + let l = List.rev (environment_until (Some dir_m)) in + let select l (mp,meb) = + if Visit.needed_mp mp + then (mp, unpack (extract_seb env mp true meb)) :: l + else l + in + let struc = List.fold_left select [] l in + let struc = optimize_struct [] struc in + warning_axioms (); + let print = function + | (MPfile dir as mp, sel) as e -> + let dry = not is_rec && dir <> dir_m in + print_structure_to_file (module_filename mp) dry [e] + | _ -> assert false + in + List.iter print struc; + reset () diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli new file mode 100644 index 00000000..dcb4601e --- /dev/null +++ b/plugins/extraction/extract_env.mli @@ -0,0 +1,23 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit +val full_extraction : string option -> reference list -> unit +val extraction_library : bool -> identifier -> unit + +(* For debug / external output via coqtop.byte + Drop : *) + +val mono_environment : + global_reference list -> module_path list -> Miniml.ml_structure diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml new file mode 100644 index 00000000..99682ae6 --- /dev/null +++ b/plugins/extraction/extraction.ml @@ -0,0 +1,982 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* flag_of_type (push_rel (x,None,t) env) c + | Sort (Prop Null) -> (Logic,TypeScheme) + | Sort _ -> (Info,TypeScheme) + | _ -> if (sort_of env t) = InProp then (Logic,Default) else (Info,Default) + +(*s Two particular cases of [flag_of_type]. *) + +let is_default env t = (flag_of_type env t = (Info, Default)) + +exception NotDefault of kill_reason + +let check_default env t = + match flag_of_type env t with + | _,TypeScheme -> raise (NotDefault Ktype) + | Logic,_ -> raise (NotDefault Kother) + | _ -> () + +let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme)) + +(*s [type_sign] gernerates a signature aimed at treating a type application. *) + +let rec type_sign env c = + match kind_of_term (whd_betadeltaiota env none c) with + | Prod (n,t,d) -> + (if is_info_scheme env t then Keep else Kill Kother) + :: (type_sign (push_rel_assum (n,t) env) d) + | _ -> [] + +let rec type_scheme_nb_args env c = + match kind_of_term (whd_betadeltaiota env none c) with + | Prod (n,t,d) -> + let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in + if is_info_scheme env t then n+1 else n + | _ -> 0 + +let _ = register_type_scheme_nb_args type_scheme_nb_args + +(*s [type_sign_vl] does the same, plus a type var list. *) + +let rec type_sign_vl env c = + match kind_of_term (whd_betadeltaiota env none c) with + | Prod (n,t,d) -> + let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in + if not (is_info_scheme env t) then Kill Kother::s, vl + else Keep::s, (next_ident_away (id_of_name n) vl) :: vl + | _ -> [],[] + +let rec nb_default_params env c = + match kind_of_term (whd_betadeltaiota env none c) with + | Prod (n,t,d) -> + let n = nb_default_params (push_rel_assum (n,t) env) d in + if is_default env t then n+1 else n + | _ -> 0 + +(* Enriching a signature with implicit information *) + +let sign_with_implicits r s = + let implicits = implicits_of_global r in + let rec add_impl i = function + | [] -> [] + | sign::s -> + let sign' = + if sign = Keep && List.mem i implicits then Kill Kother else sign + in sign' :: add_impl (succ i) s + in + add_impl 1 s + +(* Enriching a exception message *) + +let rec handle_exn r n fn_name = function + | MLexn s -> + (try Scanf.sscanf s "UNBOUND %d" + (fun i -> + assert ((0 < i) && (i <= n)); + MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i))) + with _ -> MLexn s) + | a -> ast_map (handle_exn r n fn_name) a + +(*S Management of type variable contexts. *) + +(* A De Bruijn variable context (db) is a context for translating Coq [Rel] + into ML type [Tvar]. *) + +(*s From a type signature toward a type variable context (db). *) + +let db_from_sign s = + let rec make i acc = function + | [] -> acc + | Keep :: l -> make (i+1) (i::acc) l + | Kill _ :: l -> make i (0::acc) l + in make 1 [] s + +(*s Create a type variable context from indications taken from + an inductive type (see just below). *) + +let rec db_from_ind dbmap i = + if i = 0 then [] + else (try Intmap.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1)) + +(*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument + of a constructor corresponds to the j-th type var of the ML inductive. *) + +(* \begin{itemize} + \item [si] : signature of the inductive + \item [i] : counter of Coq args for [(I args)] + \item [j] : counter of ML type vars + \item [relmax] : total args number of the constructor + \end{itemize} *) + +let parse_ind_args si args relmax = + let rec parse i j = function + | [] -> Intmap.empty + | Kill _ :: s -> parse (i+1) j s + | Keep :: s -> + (match kind_of_term args.(i-1) with + | Rel k -> Intmap.add (relmax+1-k) j (parse (i+1) (j+1) s) + | _ -> parse (i+1) (j+1) s) + in parse 1 1 si + +(*S Extraction of a type. *) + +(* [extract_type env db c args] is used to produce an ML type from the + coq term [(c args)], which is supposed to be a Coq type. *) + +(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *) + +(* [j] stands for the next ML type var. [j=0] means we do not + generate ML type var anymore (in subterms for example). *) + + +let rec extract_type env db j c args = + match kind_of_term (whd_betaiotazeta Evd.empty c) with + | App (d, args') -> + (* We just accumulate the arguments. *) + extract_type env db j d (Array.to_list args' @ args) + | Lambda (_,_,d) -> + (match args with + | [] -> assert false (* otherwise the lambda would be reductible. *) + | a :: args -> extract_type env db j (subst1 a d) args) + | Prod (n,t,d) -> + assert (args = []); + let env' = push_rel_assum (n,t) env in + (match flag_of_type env t with + | (Info, Default) -> + (* Standard case: two [extract_type] ... *) + let mld = extract_type env' (0::db) j d [] in + (match expand env mld with + | Tdummy d -> Tdummy d + | _ -> Tarr (extract_type env db 0 t [], mld)) + | (Info, TypeScheme) when j > 0 -> + (* A new type var. *) + let mld = extract_type env' (j::db) (j+1) d [] in + (match expand env mld with + | Tdummy d -> Tdummy d + | _ -> Tarr (Tdummy Ktype, mld)) + | _,lvl -> + let mld = extract_type env' (0::db) j d [] in + (match expand env mld with + | Tdummy d -> Tdummy d + | _ -> + let reason = if lvl=TypeScheme then Ktype else Kother in + Tarr (Tdummy reason, mld))) + | Sort _ -> Tdummy Ktype (* The two logical cases. *) + | _ when sort_of env (applist (c, args)) = InProp -> Tdummy Kother + | Rel n -> + (match lookup_rel n env with + | (_,Some t,_) -> extract_type env db j (lift n t) args + | _ -> + (* Asks [db] a translation for [n]. *) + if n > List.length db then Tunknown + else let n' = List.nth db (n-1) in + if n' = 0 then Tunknown else Tvar n') + | Const kn -> + let r = ConstRef kn in + let cb = lookup_constant kn env in + let typ = Typeops.type_of_constant_type env cb.const_type in + (match flag_of_type env typ with + | (Info, TypeScheme) -> + let mlt = extract_type_app env db (r, type_sign env typ) args in + (match cb.const_body with + | None -> mlt + | Some _ when is_custom r -> mlt + | Some lbody -> + let newc = applist (Declarations.force lbody, args) in + let mlt' = extract_type env db j newc [] in + (* ML type abbreviations interact badly with Coq *) + (* reduction, so [mlt] and [mlt'] might be different: *) + (* The more precise is [mlt'], extracted after reduction *) + (* The shortest is [mlt], which use abbreviations *) + (* If possible, we take [mlt], otherwise [mlt']. *) + if expand env mlt = expand env mlt' then mlt else mlt') + | _ -> (* only other case here: Info, Default, i.e. not an ML type *) + (match cb.const_body with + | None -> Tunknown (* Brutal approximation ... *) + | Some lbody -> + (* We try to reduce. *) + let newc = applist (Declarations.force lbody, args) in + extract_type env db j newc [])) + | Ind (kn,i) -> + let s = (extract_ind env kn).ind_packets.(i).ip_sign in + extract_type_app env db (IndRef (kn,i),s) args + | Case _ | Fix _ | CoFix _ -> Tunknown + | _ -> assert false + +(* [extract_maybe_type] calls [extract_type] when used on a Coq type, + and otherwise returns [Tdummy] or [Tunknown] *) + +and extract_maybe_type env db c = + let t = whd_betadeltaiota env none (type_of env c) in + if isSort t then extract_type env db 0 c [] + else if sort_of env t = InProp then Tdummy Kother else Tunknown + +(*s Auxiliary function dealing with type application. + Precondition: [r] is a type scheme represented by the signature [s], + and is completely applied: [List.length args = List.length s]. *) + +and extract_type_app env db (r,s) args = + let ml_args = + List.fold_right + (fun (b,c) a -> if b=Keep then + let p = List.length (fst (splay_prod env none (type_of env c))) in + let db = iterate (fun l -> 0 :: l) p db in + (extract_type_scheme env db c p) :: a + else a) + (List.combine s args) [] + in Tglob (r, ml_args) + +(*S Extraction of a type scheme. *) + +(* [extract_type_scheme env db c p] works on a Coq term [c] which is + an informative type scheme. It means that [c] is not a Coq type, but will + be when applied to sufficiently many arguments ([p] in fact). + This function decomposes p lambdas, with eta-expansion if needed. *) + +(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *) + +and extract_type_scheme env db c p = + if p=0 then extract_type env db 0 c [] + else + let c = whd_betaiotazeta Evd.empty c in + match kind_of_term c with + | Lambda (n,t,d) -> + extract_type_scheme (push_rel_assum (n,t) env) db d (p-1) + | _ -> + let rels = fst (splay_prod env none (type_of env c)) in + let env = push_rels_assum rels env in + let eta_args = List.rev_map mkRel (interval 1 p) in + extract_type env db 0 (lift p c) eta_args + + +(*S Extraction of an inductive type. *) + +and extract_ind env kn = (* kn is supposed to be in long form *) + let mib = Environ.lookup_mind kn env in + try + (* For a same kn, we can get various bodies due to module substitutions. + We hence check that the mib has not changed from recording + time to retrieving time. Ideally we should also check the env. *) + let (mib0,ml_ind) = lookup_ind kn in + if not (mib = mib0) then raise Not_found; + ml_ind + with Not_found -> + (* First, if this inductive is aliased via a Module, *) + (* we process the original inductive. *) + let equiv = + if (canonical_mind kn) = (user_mind kn) then + NoEquiv + else + begin + ignore (extract_ind env (mind_of_kn (canonical_mind kn))); + Equiv (canonical_mind kn) + end + in + (* Everything concerning parameters. *) + (* We do that first, since they are common to all the [mib]. *) + let mip0 = mib.mind_packets.(0) in + let npar = mib.mind_nparams in + let epar = push_rel_context mib.mind_params_ctxt env in + (* First pass: we store inductive signatures together with *) + (* their type var list. *) + let packets = + Array.map + (fun mip -> + let b = snd (mind_arity mip) <> InProp in + let ar = Inductive.type_of_inductive env (mib,mip) in + let s,v = if b then type_sign_vl env ar else [],[] in + let t = Array.make (Array.length mip.mind_nf_lc) [] in + { ip_typename = mip.mind_typename; + ip_consnames = mip.mind_consnames; + ip_logical = (not b); + ip_sign = s; + ip_vars = v; + ip_types = t; + ip_optim_id_ok = None }) + mib.mind_packets + in + + add_ind kn mib + {ind_info = Standard; + ind_nparams = npar; + ind_packets = packets; + ind_equiv = equiv + }; + (* Second pass: we extract constructors *) + for i = 0 to mib.mind_ntypes - 1 do + let p = packets.(i) in + if not p.ip_logical then + let types = arities_of_constructors env (kn,i) in + for j = 0 to Array.length types - 1 do + let t = snd (decompose_prod_n npar types.(j)) in + let prods,head = dest_prod epar t in + let nprods = List.length prods in + let args = match kind_of_term head with + | App (f,args) -> args (* [kind_of_term f = Ind ip] *) + | _ -> [||] + in + let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in + let db = db_from_ind dbmap npar in + p.ip_types.(j) <- extract_type_cons epar db dbmap t (npar+1) + done + done; + (* Third pass: we determine special cases. *) + let ind_info = + try + if not mib.mind_finite then raise (I Coinductive); + if mib.mind_ntypes <> 1 then raise (I Standard); + let p = packets.(0) in + if p.ip_logical then raise (I Standard); + if Array.length p.ip_types <> 1 then raise (I Standard); + let typ = p.ip_types.(0) in + let l = List.filter (fun t -> not (isDummy (expand env t))) typ in + if List.length l = 1 && not (type_mem_kn kn (List.hd l)) + then raise (I Singleton); + if l = [] then raise (I Standard); + if not mib.mind_record then raise (I Standard); + let ip = (kn, 0) in + let r = IndRef ip in + if is_custom r then raise (I Standard); + (* Now we're sure it's a record. *) + (* First, we find its field names. *) + let rec names_prod t = match kind_of_term t with + | Prod(n,_,t) -> n::(names_prod t) + | LetIn(_,_,_,t) -> names_prod t + | Cast(t,_,_) -> names_prod t + | _ -> [] + in + let field_names = + list_skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in + assert (List.length field_names = List.length typ); + let projs = ref Cset.empty in + let mp,d,_ = repr_mind kn in + let rec select_fields l typs = match l,typs with + | [],[] -> [] + | (Name id)::l, typ::typs -> + if isDummy (expand env typ) then select_fields l typs + else + let knp = make_con mp d (label_of_id id) in + if List.for_all ((=) Keep) (type2signature env typ) + then + projs := Cset.add knp !projs; + (ConstRef knp) :: (select_fields l typs) + | Anonymous::l, typ::typs -> + if isDummy (expand env typ) then select_fields l typs + else error_record r + | _ -> assert false + in + let field_glob = select_fields field_names typ + in + (* Is this record officially declared with its projections ? *) + (* If so, we use this information. *) + begin try + let n = nb_default_params env + (Inductive.type_of_inductive env (mib,mip0)) + in + List.iter + (Option.iter + (fun kn -> if Cset.mem kn !projs then add_projection n kn)) + (lookup_projections ip) + with Not_found -> () + end; + Record field_glob + with (I info) -> info + in + let i = {ind_info = ind_info; + ind_nparams = npar; + ind_packets = packets; + ind_equiv = equiv } + in + add_ind kn mib i; + i + +(*s [extract_type_cons] extracts the type of an inductive + constructor toward the corresponding list of ML types. + + - [db] is a context for translating Coq [Rel] into ML type [Tvar] + - [dbmap] is a translation map (produced by a call to [parse_in_args]) + - [i] is the rank of the current product (initially [params_nb+1]) +*) + +and extract_type_cons env db dbmap c i = + match kind_of_term (whd_betadeltaiota env none c) with + | Prod (n,t,d) -> + let env' = push_rel_assum (n,t) env in + let db' = (try Intmap.find i dbmap with Not_found -> 0) :: db in + let l = extract_type_cons env' db' dbmap d (i+1) in + (extract_type env db 0 t []) :: l + | _ -> [] + +(*s Recording the ML type abbreviation of a Coq type scheme constant. *) + +and mlt_env env r = match r with + | ConstRef kn -> + (try + if not (visible_con kn) then raise Not_found; + match lookup_term kn with + | Dtype (_,vl,mlt) -> Some mlt + | _ -> None + with Not_found -> + let cb = Environ.lookup_constant kn env in + let typ = Typeops.type_of_constant_type env cb.const_type in + match cb.const_body with + | None -> None + | Some l_body -> + (match flag_of_type env typ with + | Info,TypeScheme -> + let body = Declarations.force l_body in + let s,vl = type_sign_vl env typ in + let db = db_from_sign s in + let t = extract_type_scheme env db body (List.length s) + in add_term kn (Dtype (r, vl, t)); Some t + | _ -> None)) + | _ -> None + +and expand env = type_expand (mlt_env env) +and type2signature env = type_to_signature (mlt_env env) +let type2sign env = type_to_sign (mlt_env env) +let type_expunge env = type_expunge (mlt_env env) +let type_expunge_from_sign env = type_expunge_from_sign (mlt_env env) + +(*s Extraction of the type of a constant. *) + +let record_constant_type env kn opt_typ = + try + if not (visible_con kn) then raise Not_found; + lookup_type kn + with Not_found -> + let typ = match opt_typ with + | None -> Typeops.type_of_constant env kn + | Some typ -> typ + in let mlt = extract_type env [] 1 typ [] + in let schema = (type_maxvar mlt, mlt) + in add_type kn schema; schema + +(*S Extraction of a term. *) + +(* Precondition: [(c args)] is not a type scheme, and is informative. *) + +(* [mle] is a ML environment [Mlenv.t]. *) +(* [mlt] is the ML type we want our extraction of [(c args)] to have. *) + +let rec extract_term env mle mlt c args = + match kind_of_term c with + | App (f,a) -> + extract_term env mle mlt f (Array.to_list a @ args) + | Lambda (n, t, d) -> + let id = id_of_name n in + (match args with + | a :: l -> + (* We make as many [LetIn] as possible. *) + let d' = mkLetIn (Name id,a,t,applistc d (List.map (lift 1) l)) + in extract_term env mle mlt d' [] + | [] -> + let env' = push_rel_assum (Name id, t) env in + let id, a = + try check_default env t; Id id, new_meta() + with NotDefault d -> Dummy, Tdummy d + in + let b = new_meta () in + (* If [mlt] cannot be unified with an arrow type, then magic! *) + let magic = needs_magic (mlt, Tarr (a, b)) in + let d' = extract_term env' (Mlenv.push_type mle a) b d [] in + put_magic_if magic (MLlam (id, d'))) + | LetIn (n, c1, t1, c2) -> + let id = id_of_name n in + let env' = push_rel (Name id, Some c1, t1) env in + let args' = List.map (lift 1) args in + (try + check_default env t1; + let a = new_meta () in + let c1' = extract_term env mle a c1 [] in + (* The type of [c1'] is generalized and stored in [mle]. *) + let mle' = Mlenv.push_gen mle a in + MLletin (Id id, c1', extract_term env' mle' mlt c2 args') + with NotDefault d -> + let mle' = Mlenv.push_std_type mle (Tdummy d) in + ast_pop (extract_term env' mle' mlt c2 args')) + | Const kn -> + extract_cst_app env mle mlt kn args + | Construct cp -> + extract_cons_app env mle mlt cp args + | Rel n -> + (* As soon as the expected [mlt] for the head is known, *) + (* we unify it with an fresh copy of the stored type of [Rel n]. *) + let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n) + in extract_app env mle mlt extract_rel args + | Case ({ci_ind=ip},_,c0,br) -> + extract_app env mle mlt (extract_case env mle (ip,c0,br)) args + | Fix ((_,i),recd) -> + extract_app env mle mlt (extract_fix env mle i recd) args + | CoFix (i,recd) -> + extract_app env mle mlt (extract_fix env mle i recd) args + | Cast (c,_,_) -> extract_term env mle mlt c args + | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ | Var _ -> assert false + +(*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) + +and extract_maybe_term env mle mlt c = + try check_default env (type_of env c); + extract_term env mle mlt c [] + with NotDefault d -> + put_magic (mlt, Tdummy d) MLdummy + +(*s Generic way to deal with an application. *) + +(* We first type all arguments starting with unknown meta types. + This gives us the expected type of the head. Then we use the + [mk_head] to produce the ML head from this type. *) + +and extract_app env mle mlt mk_head args = + let metas = List.map new_meta args in + let type_head = type_recomp (metas, mlt) in + let mlargs = List.map2 (extract_maybe_term env mle) metas args in + mlapp (mk_head type_head) mlargs + +(*s Auxiliary function used to extract arguments of constant or constructor. *) + +and make_mlargs env e s args typs = + let rec f = function + | [], [], _ -> [] + | a::la, t::lt, [] -> extract_maybe_term env e t a :: (f (la,lt,[])) + | a::la, t::lt, Keep::s -> extract_maybe_term env e t a :: (f (la,lt,s)) + | _::la, _::lt, _::s -> f (la,lt,s) + | _ -> assert false + in f (args,typs,s) + +(*s Extraction of a constant applied to arguments. *) + +and extract_cst_app env mle mlt kn args = + (* First, the [ml_schema] of the constant, in expanded version. *) + let nb,t = record_constant_type env kn None in + let schema = nb, expand env t in + (* Can we instantiate types variables for this constant ? *) + (* In Ocaml, inside the definition of this constant, the answer is no. *) + let instantiated = + if lang () = Ocaml && List.mem kn !current_fixpoints then var2var' (snd schema) + else instantiation schema + in + (* Then the expected type of this constant. *) + let a = new_meta () in + (* We compare stored and expected types in two steps. *) + (* First, can [kn] be applied to all args ? *) + let metas = List.map new_meta args in + let magic1 = needs_magic (type_recomp (metas, a), instantiated) in + (* Second, is the resulting type compatible with the expected type [mlt] ? *) + let magic2 = needs_magic (a, mlt) in + (* The internal head receives a magic if [magic1] *) + let head = put_magic_if magic1 (MLglob (ConstRef kn)) in + (* Now, the extraction of the arguments. *) + let s_full = type2signature env (snd schema) in + let s_full = sign_with_implicits (ConstRef kn) s_full in + let s = sign_no_final_keeps s_full in + let ls = List.length s in + let la = List.length args in + (* The ml arguments, already expunged from known logical ones *) + let mla = make_mlargs env mle s args metas in + let mla = + if not magic1 then + try + let l,l' = list_chop (projection_arity (ConstRef kn)) mla in + if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l' + else mla + with _ -> mla + else mla + in + (* For strict languages, purely logical signatures with at least + one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left + accordingly. *) + let optdummy = match sign_kind s_full with + | UnsafeLogicalSig when lang () <> Haskell -> [MLdummy] + | _ -> [] + in + (* Different situations depending of the number of arguments: *) + if la >= ls + then + (* Enough args, cleanup already done in [mla], we only add the + additionnal dummy if needed. *) + put_magic_if (magic2 && not magic1) (mlapp head (optdummy @ mla)) + else + (* Partially applied function with some logical arg missing. + We complete via eta and expunge logical args. *) + let ls' = ls-la in + let s' = list_skipn la s in + let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in + let e = anonym_or_dummy_lams (mlapp head mla) s' in + put_magic_if magic2 (remove_n_lams (List.length optdummy) e) + +(*s Extraction of an inductive constructor applied to arguments. *) + +(* \begin{itemize} + \item In ML, contructor arguments are uncurryfied. + \item We managed to suppress logical parts inside inductive definitions, + but they must appears outside (for partial applications for instance) + \item We also suppressed all Coq parameters to the inductives, since + they are fixed, and thus are not used for the computation. + \end{itemize} *) + +and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = + (* First, we build the type of the constructor, stored in small pieces. *) + let mi = extract_ind env kn in + let params_nb = mi.ind_nparams in + let oi = mi.ind_packets.(i) in + let nb_tvars = List.length oi.ip_vars + and types = List.map (expand env) oi.ip_types.(j-1) in + let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in + let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in + let type_cons = instantiation (nb_tvars, type_cons) in + (* Then, the usual variables [s], [ls], [la], ... *) + let s = List.map (type2sign env) types in + let s = sign_with_implicits (ConstructRef cp) s in + let ls = List.length s in + let la = List.length args in + assert (la <= ls + params_nb); + let la' = max 0 (la - params_nb) in + let args' = list_lastn la' args in + (* Now, we build the expected type of the constructor *) + let metas = List.map new_meta args' in + (* If stored and expected types differ, then magic! *) + let a = new_meta () in + let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in + let magic2 = needs_magic (a, mlt) in + let head mla = + if mi.ind_info = Singleton then + put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *) + else put_magic_if magic1 (MLcons (mi.ind_info, ConstructRef cp, mla)) + in + (* Different situations depending of the number of arguments: *) + if la < params_nb then + let head' = head (eta_args_sign ls s) in + put_magic_if magic2 + (dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la)) + else + let mla = make_mlargs env mle s args' metas in + if la = ls + params_nb + then put_magic_if (magic2 && not magic1) (head mla) + else (* [ params_nb <= la <= ls + params_nb ] *) + let ls' = params_nb + ls - la in + let s' = list_lastn ls' s in + let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in + put_magic_if magic2 (anonym_or_dummy_lams (head mla) s') + +(*S Extraction of a case. *) + +and extract_case env mle ((kn,i) as ip,c,br) mlt = + (* [br]: bodies of each branch (in functional form) *) + (* [ni]: number of arguments without parameters in each branch *) + let ni = mis_constr_nargs_env env ip in + let br_size = Array.length br in + assert (Array.length ni = br_size); + if br_size = 0 then begin + add_recursors env kn; (* May have passed unseen if logical ... *) + MLexn "absurd case" + end else + (* [c] has an inductive type, and is not a type scheme type. *) + let t = type_of env c in + (* The only non-informative case: [c] is of sort [Prop] *) + if (sort_of env t) = InProp then + begin + add_recursors env kn; (* May have passed unseen if logical ... *) + (* Logical singleton case: *) + (* [match c with C i j k -> t] becomes [t'] *) + assert (br_size = 1); + let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in + let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in + let e = extract_maybe_term env mle mlt br.(0) in + snd (case_expunge s e) + end + else + let mi = extract_ind env kn in + let oi = mi.ind_packets.(i) in + let metas = Array.init (List.length oi.ip_vars) new_meta in + (* The extraction of the head. *) + let type_head = Tglob (IndRef ip, Array.to_list metas) in + let a = extract_term env mle type_head c [] in + (* The extraction of each branch. *) + let extract_branch i = + let r = ConstructRef (ip,i+1) in + (* The types of the arguments of the corresponding constructor. *) + let f t = type_subst_vect metas (expand env t) in + let l = List.map f oi.ip_types.(i) in + (* the corresponding signature *) + let s = List.map (type2sign env) oi.ip_types.(i) in + let s = sign_with_implicits r s in + (* Extraction of the branch (in functional form). *) + let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in + (* We suppress dummy arguments according to signature. *) + let ids,e = case_expunge s e in + let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in + (r, List.rev ids, e') + in + if mi.ind_info = Singleton then + begin + (* Informative singleton case: *) + (* [match c with C i -> t] becomes [let i = c' in t'] *) + assert (br_size = 1); + let (_,ids,e') = extract_branch 0 in + assert (List.length ids = 1); + MLletin (tmp_id (List.hd ids),a,e') + end + else + (* Standard case: we apply [extract_branch]. *) + MLcase ((mi.ind_info,BranchNone), a, Array.init br_size extract_branch) + +(*s Extraction of a (co)-fixpoint. *) + +and extract_fix env mle i (fi,ti,ci as recd) mlt = + let env = push_rec_types recd env in + let metas = Array.map new_meta fi in + metas.(i) <- mlt; + let mle = Array.fold_left Mlenv.push_type mle metas in + let ei = array_map2 (extract_maybe_term env mle) metas ci in + MLfix (i, Array.map id_of_name fi, ei) + +(*S ML declarations. *) + +(* [decomp_lams_eta env c t] finds the number [n] of products in the type [t], + and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *) + +let rec decomp_lams_eta_n n m env c t = + let rels = fst (splay_prod_n env none n t) in + let rels = List.map (fun (id,_,c) -> (id,c)) rels in + let rels',c = decompose_lam c in + let d = n - m in + (* we'd better keep rels' as long as possible. *) + let rels = (list_firstn d rels) @ rels' in + let eta_args = List.rev_map mkRel (interval 1 d) in + rels, applist (lift d c,eta_args) + +(*s From a constant to a ML declaration. *) + +let extract_std_constant env kn body typ = + reset_meta_count (); + (* The short type [t] (i.e. possibly with abbreviations). *) + let t = snd (record_constant_type env kn (Some typ)) in + (* The real type [t']: without head products, expanded, *) + (* and with [Tvar] translated to [Tvar'] (not instantiable). *) + let l,t' = type_decomp (expand env (var2var' t)) in + let s = List.map (type2sign env) l in + (* Check for user-declared implicit information *) + let s = sign_with_implicits (ConstRef kn) s in + (* Decomposing the top level lambdas of [body]. + If there isn't enough, it's ok, as long as remaining args + aren't to be pruned (and initial lambdas aren't to be all + removed if the target language is strict). In other situations, + eta-expansions create artificially enough lams (but that may + break user's clever let-ins and partial applications). *) + let rels, c = + let n = List.length s + and m = nb_lam body in + if n <= m then decompose_lam_n n body + else + let s,s' = list_split_at m s in + if List.for_all ((=) Keep) s' && + (lang () = Haskell || sign_kind s <> UnsafeLogicalSig) + then decompose_lam_n m body + else decomp_lams_eta_n n m env body typ + in + let n = List.length rels in + let s = list_firstn n s in + let l,l' = list_split_at n l in + let t' = type_recomp (l',t') in + (* The initial ML environment. *) + let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in + (* The lambdas names. *) + let ids = List.map (fun (n,_) -> Id (id_of_name n)) rels in + (* The according Coq environment. *) + let env = push_rels_assum rels env in + (* The real extraction: *) + let e = extract_term env mle t' c [] in + (* Expunging term and type from dummy lambdas. *) + let trm = term_expunge s (ids,e) in + let trm = handle_exn (ConstRef kn) n (fun i -> fst (List.nth rels (i-1))) trm + in + trm, type_expunge_from_sign env s t + +let extract_fixpoint env vkn (fi,ti,ci) = + let n = Array.length vkn in + let types = Array.make n (Tdummy Kother) + and terms = Array.make n MLdummy in + let kns = Array.to_list vkn in + current_fixpoints := kns; + (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *) + let sub = List.rev_map mkConst kns in + for i = 0 to n-1 do + if sort_of env ti.(i) <> InProp then begin + let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in + terms.(i) <- e; + types.(i) <- t; + end + done; + current_fixpoints := []; + Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) + +let extract_constant env kn cb = + let r = ConstRef kn in + let typ = Typeops.type_of_constant_type env cb.const_type in + match cb.const_body with + | None -> (* A logical axiom is risky, an informative one is fatal. *) + (match flag_of_type env typ with + | (Info,TypeScheme) -> + if not (is_custom r) then add_info_axiom r; + let n = type_scheme_nb_args env typ in + let ids = iterate (fun l -> anonymous_name::l) n [] in + Dtype (r, ids, Taxiom) + | (Info,Default) -> + if not (is_custom r) then add_info_axiom r; + let t = snd (record_constant_type env kn (Some typ)) in + Dterm (r, MLaxiom, type_expunge env t) + | (Logic,TypeScheme) -> + add_log_axiom r; Dtype (r, [], Tdummy Ktype) + | (Logic,Default) -> + add_log_axiom r; Dterm (r, MLdummy, Tdummy Kother)) + | Some body -> + (match flag_of_type env typ with + | (Logic, Default) -> Dterm (r, MLdummy, Tdummy Kother) + | (Logic, TypeScheme) -> Dtype (r, [], Tdummy Ktype) + | (Info, Default) -> + let e,t = extract_std_constant env kn (force body) typ in + Dterm (r,e,t) + | (Info, TypeScheme) -> + let s,vl = type_sign_vl env typ in + let db = db_from_sign s in + let t = extract_type_scheme env db (force body) (List.length s) + in Dtype (r, vl, t)) + +let extract_constant_spec env kn cb = + let r = ConstRef kn in + let typ = Typeops.type_of_constant_type env cb.const_type in + match flag_of_type env typ with + | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) + | (Logic, Default) -> Sval (r, Tdummy Kother) + | (Info, TypeScheme) -> + let s,vl = type_sign_vl env typ in + (match cb.const_body with + | None -> Stype (r, vl, None) + | Some body -> + let db = db_from_sign s in + let t = extract_type_scheme env db (force body) (List.length s) + in Stype (r, vl, Some t)) + | (Info, Default) -> + let t = snd (record_constant_type env kn (Some typ)) in + Sval (r, type_expunge env t) + +let extract_with_type env cb = + let typ = Typeops.type_of_constant_type env cb.const_type in + match flag_of_type env typ with + | (Info, TypeScheme) -> + let s,vl = type_sign_vl env typ in + let body = Option.get cb.const_body in + let db = db_from_sign s in + let t = extract_type_scheme env db (force body) (List.length s) in + Some (vl, t) + | _ -> None + + +let extract_inductive env kn = + let ind = extract_ind env kn in + add_recursors env kn; + let f i j l = + let implicits = implicits_of_global (ConstructRef ((kn,i),j+1)) in + let rec filter i = function + | [] -> [] + | t::l -> + let l' = filter (succ i) l in + if isDummy (expand env t) || List.mem i implicits then l' + else t::l' + in filter 1 l + in + let packets = + Array.mapi (fun i p -> { p with ip_types = Array.mapi (f i) p.ip_types }) + ind.ind_packets + in { ind with ind_packets = packets } + +(*s Is a [ml_decl] logical ? *) + +let logical_decl = function + | Dterm (_,MLdummy,Tdummy _) -> true + | Dtype (_,[],Tdummy _) -> true + | Dfix (_,av,tv) -> + (array_for_all ((=) MLdummy) av) && + (array_for_all isDummy tv) + | Dind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets + | _ -> false + +(*s Is a [ml_spec] logical ? *) + +let logical_spec = function + | Stype (_, [], Some (Tdummy _)) -> true + | Sval (_,Tdummy _) -> true + | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets + | _ -> false diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli new file mode 100644 index 00000000..6bcd2476 --- /dev/null +++ b/plugins/extraction/extraction.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constant -> constant_body -> ml_decl + +val extract_constant_spec : env -> constant -> constant_body -> ml_spec + +val extract_with_type : env -> constant_body -> ( identifier list * ml_type ) option + +val extract_fixpoint : + env -> constant array -> (constr, types) prec_declaration -> ml_decl + +val extract_inductive : env -> mutual_inductive -> ml_ind + +(*s Is a [ml_decl] or a [ml_spec] logical ? *) + +val logical_decl : ml_decl -> bool +val logical_spec : ml_spec -> bool diff --git a/plugins/extraction/extraction_plugin.mllib b/plugins/extraction/extraction_plugin.mllib new file mode 100644 index 00000000..b7f45861 --- /dev/null +++ b/plugins/extraction/extraction_plugin.mllib @@ -0,0 +1,11 @@ +Table +Mlutil +Modutil +Extraction +Common +Ocaml +Haskell +Scheme +Extract_env +G_extraction +Extraction_plugin_mod diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 new file mode 100644 index 00000000..18828241 --- /dev/null +++ b/plugins/extraction/g_extraction.ml4 @@ -0,0 +1,142 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ id ] +| [ string(s) ] -> [ s ] +END + +let pr_int_or_id _ _ _ = function + | ArgInt i -> int i + | ArgId id -> pr_id id + +ARGUMENT EXTEND int_or_id + TYPED AS int_or_id + PRINTED BY pr_int_or_id +| [ preident(id) ] -> [ ArgId (id_of_string id) ] +| [ integer(i) ] -> [ ArgInt i ] +END + +let pr_language = function + | Ocaml -> str "Ocaml" + | Haskell -> str "Haskell" + | Scheme -> str "Scheme" + +VERNAC ARGUMENT EXTEND language +PRINTED BY pr_language +| [ "Ocaml" ] -> [ Ocaml ] +| [ "Haskell" ] -> [ Haskell ] +| [ "Scheme" ] -> [ Scheme ] +END + +(* Extraction commands *) + +VERNAC COMMAND EXTEND Extraction +(* Extraction in the Coq toplevel *) +| [ "Extraction" global(x) ] -> [ simple_extraction x ] +| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ] + +(* Monolithic extraction to a file *) +| [ "Extraction" string(f) ne_global_list(l) ] + -> [ full_extraction (Some f) l ] +END + +(* Modular extraction (one Coq library = one ML module) *) +VERNAC COMMAND EXTEND ExtractionLibrary +| [ "Extraction" "Library" ident(m) ] + -> [ extraction_library false m ] +END + +VERNAC COMMAND EXTEND RecursiveExtractionLibrary +| [ "Recursive" "Extraction" "Library" ident(m) ] + -> [ extraction_library true m ] +END + +(* Target Language *) +VERNAC COMMAND EXTEND ExtractionLanguage +| [ "Extraction" "Language" language(l) ] + -> [ extraction_language l ] +END + +VERNAC COMMAND EXTEND ExtractionInline +(* Custom inlining directives *) +| [ "Extraction" "Inline" ne_global_list(l) ] + -> [ extraction_inline true l ] +END + +VERNAC COMMAND EXTEND ExtractionNoInline +| [ "Extraction" "NoInline" ne_global_list(l) ] + -> [ extraction_inline false l ] +END + +VERNAC COMMAND EXTEND PrintExtractionInline +| [ "Print" "Extraction" "Inline" ] + -> [ print_extraction_inline () ] +END + +VERNAC COMMAND EXTEND ResetExtractionInline +| [ "Reset" "Extraction" "Inline" ] + -> [ reset_extraction_inline () ] +END + +VERNAC COMMAND EXTEND ExtractionImplicit +(* Custom implicit arguments of some csts/inds/constructors *) +| [ "Extraction" "Implicit" global(r) "[" int_or_id_list(l) "]" ] + -> [ extraction_implicit r l ] +END + +VERNAC COMMAND EXTEND ExtractionBlacklist +(* Force Extraction to not use some filenames *) +| [ "Extraction" "Blacklist" ne_ident_list(l) ] + -> [ extraction_blacklist l ] +END + +VERNAC COMMAND EXTEND PrintExtractionBlacklist +| [ "Print" "Extraction" "Blacklist" ] + -> [ print_extraction_blacklist () ] +END + +VERNAC COMMAND EXTEND ResetExtractionBlacklist +| [ "Reset" "Extraction" "Blacklist" ] + -> [ reset_extraction_blacklist () ] +END + + +(* Overriding of a Coq object by an ML one *) +VERNAC COMMAND EXTEND ExtractionConstant +| [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ] + -> [ extract_constant_inline false x idl y ] +END + +VERNAC COMMAND EXTEND ExtractionInlinedConstant +| [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ] + -> [ extract_constant_inline true x [] y ] +END + +VERNAC COMMAND EXTEND ExtractionInductive +| [ "Extract" "Inductive" global(x) "=>" + mlname(id) "[" mlname_list(idl) "]" string_opt(o) ] + -> [ extract_inductive x id idl o ] +END diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml new file mode 100644 index 00000000..bb1dbd48 --- /dev/null +++ b/plugins/extraction/haskell.ml @@ -0,0 +1,357 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Idset.add (id_of_string s)) + [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else"; + "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance"; + "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__"; + "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ] + Idset.empty + +let preamble mod_name used_modules usf = + let pp_import mp = str ("import qualified "^ string_of_modfile mp ^"\n") + in + (if not usf.magic then mt () + else + str "{-# OPTIONS_GHC -cpp -fglasgow-exts #-}\n" ++ + str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}\n\n") + ++ + str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++ + str "import qualified Prelude" ++ fnl () ++ + prlist pp_import used_modules ++ fnl () ++ + (if used_modules = [] then mt () else fnl ()) ++ + (if not usf.magic then mt () + else str "\ +#ifdef __GLASGOW_HASKELL__ +import qualified GHC.Base +unsafeCoerce = GHC.Base.unsafeCoerce# +#else +-- HUGS +import qualified IOExts +unsafeCoerce = IOExts.unsafeCoerce +#endif" ++ fnl2 ()) + ++ + (if not usf.mldummy then mt () + else str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) + +let pp_abst = function + | [] -> (mt ()) + | l -> (str "\\" ++ + prlist_with_sep (fun () -> (str " ")) pr_id l ++ + str " ->" ++ spc ()) + +(*s The pretty-printer for haskell syntax *) + +let pp_global k r = + if is_inline_custom r then str (find_custom r) + else str (Common.pp_global k r) + +(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses + are needed or not. *) + +let kn_sig = + let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in + make_kn specif empty_dirpath (mk_label "sig") + +let rec pp_type par vl t = + let rec pp_rec par = function + | Tmeta _ | Tvar' _ -> assert false + | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i)) + | Tglob (r,[]) -> pp_global Type r + | Tglob (r,l) -> + if r = IndRef (mind_of_kn kn_sig,0) then + pp_type true vl (List.hd l) + else + pp_par par + (pp_global Type r ++ spc () ++ + prlist_with_sep spc (pp_type true vl) l) + | Tarr (t1,t2) -> + pp_par par + (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) + | Tdummy _ -> str "()" + | Tunknown -> str "()" + | Taxiom -> str "() -- AXIOM TO BE REALIZED\n" + in + hov 0 (pp_rec par t) + +(*s Pretty-printing of expressions. [par] indicates whether + parentheses are needed or not. [env] is the list of names for the + de Bruijn variables. [args] is the list of collected arguments + (already pretty-printed). *) + +let expr_needs_par = function + | MLlam _ -> true + | MLcase _ -> true + | _ -> false + + +let rec pp_expr par env args = + let par' = args <> [] || par + and apply st = pp_apply st par args in + function + | MLrel n -> + let id = get_db_name n env in apply (pr_id id) + | MLapp (f,args') -> + let stl = List.map (pp_expr true env []) args' in + pp_expr par env (stl @ args) f + | MLlam _ as a -> + let fl,a' = collect_lams a in + let fl,env' = push_vars (List.map id_of_mlid fl) env in + let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in + apply (pp_par par' st) + | MLletin (id,a1,a2) -> + let i,env' = push_vars [id_of_mlid id] env in + let pp_id = pr_id (List.hd i) + and pp_a1 = pp_expr false env [] a1 + and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in + hv 0 + (apply + (pp_par par' + (hv 0 + (hov 5 + (str "let" ++ spc () ++ pp_id ++ str " = " ++ pp_a1) ++ + spc () ++ str "in") ++ + spc () ++ hov 0 pp_a2))) + | MLglob r -> + apply (pp_global Term r) + | MLcons (_,r,[]) -> + assert (args=[]); pp_global Cons r + | MLcons (_,r,[a]) -> + assert (args=[]); + pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a) + | MLcons (_,r,args') -> + assert (args=[]); + pp_par par (pp_global Cons r ++ spc () ++ + prlist_with_sep spc (pp_expr true env []) args') + | MLcase (_,t, pv) when is_custom_match pv -> + let mkfun (_,ids,e) = + if ids <> [] then named_lams (List.rev ids) e + else dummy_lams (ast_lift 1 e) 1 + in + hov 2 (str (find_custom_match pv) ++ fnl () ++ + prvect (fun tr -> pp_expr true env [] (mkfun tr) ++ fnl ()) pv + ++ pp_expr true env [] t) + | MLcase ((_,factors),t, pv) -> + apply (pp_par par' + (v 0 (str "case " ++ pp_expr false env [] t ++ str " of" ++ + fnl () ++ str " " ++ pp_pat env factors pv))) + | MLfix (i,ids,defs) -> + let ids',env' = push_vars (List.rev (Array.to_list ids)) env in + pp_fix par env' i (Array.of_list (List.rev ids'),defs) args + | MLexn s -> + (* An [MLexn] may be applied, but I don't really care. *) + pp_par par (str "Prelude.error" ++ spc () ++ qs s) + | MLdummy -> + str "__" (* An [MLdummy] may be applied, but I don't really care. *) + | MLmagic a -> + pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args) + | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") + +and pp_pat env factors pv = + let pp_one_pat (name,ids,t) = + let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in + let par = expr_needs_par t in + hov 2 (pp_global Cons name ++ + (match ids with + | [] -> mt () + | _ -> (str " " ++ + prlist_with_sep + (fun () -> (spc ())) pr_id (List.rev ids))) ++ + str " ->" ++ spc () ++ pp_expr par env' [] t) + in + let factor_br, factor_l = try match factors with + | BranchFun (i::_ as l) -> check_function_branch pv.(i), l + | BranchCst (i::_ as l) -> ast_pop (check_constant_branch pv.(i)), l + | _ -> MLdummy, [] + with Impossible -> MLdummy, [] + in + let par = expr_needs_par factor_br in + let last = Array.length pv - 1 in + prvecti + (fun i x -> if List.mem i factor_l then mt () else + (pp_one_pat pv.(i) ++ + if i = last && factor_l = [] then mt () else + fnl () ++ str " ")) pv + ++ + if factor_l = [] then mt () else match factors with + | BranchFun _ -> + let ids, env' = push_vars [anonymous_name] env in + pr_id (List.hd ids) ++ str " ->" ++ spc () ++ + pp_expr par env' [] factor_br + | BranchCst _ -> + str "_ ->" ++ spc () ++ pp_expr par env [] factor_br + | BranchNone -> mt () + +(*s names of the functions ([ids]) are already pushed in [env], + and passed here just for convenience. *) + +and pp_fix par env i (ids,bl) args = + pp_par par + (v 0 + (v 2 (str "let" ++ fnl () ++ + prvect_with_sep fnl + (fun (fi,ti) -> pp_function env (pr_id fi) ti) + (array_map2 (fun a b -> a,b) ids bl)) ++ + fnl () ++ + hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) + +and pp_function env f t = + let bl,t' = collect_lams t in + let bl,env' = push_vars (List.map id_of_mlid bl) env in + (f ++ pr_binding (List.rev bl) ++ + str " =" ++ fnl () ++ str " " ++ + hov 2 (pp_expr false env' [] t')) + +(*s Pretty-printing of inductive types declaration. *) + +let pp_comment s = str "-- " ++ s ++ fnl () + +let pp_logical_ind packet = + pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ + pp_comment (str "with constructors : " ++ + prvect_with_sep spc pr_id packet.ip_consnames) + +let pp_singleton kn packet = + let l = rename_tvars keywords packet.ip_vars in + let l' = List.rev l in + hov 2 (str "type " ++ pp_global Type (IndRef (kn,0)) ++ spc () ++ + prlist_with_sep spc pr_id l ++ + (if l <> [] then str " " else mt ()) ++ str "=" ++ spc () ++ + pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++ + pp_comment (str "singleton inductive, whose constructor was " ++ + pr_id packet.ip_consnames.(0))) + +let pp_one_ind ip pl cv = + let pl = rename_tvars keywords pl in + let pp_constructor (r,l) = + (pp_global Cons r ++ + match l with + | [] -> (mt ()) + | _ -> (str " " ++ + prlist_with_sep + (fun () -> (str " ")) (pp_type true pl) l)) + in + str (if Array.length cv = 0 then "type " else "data ") ++ + pp_global Type (IndRef ip) ++ str " " ++ + prlist_with_sep (fun () -> str " ") pr_lower_id pl ++ + (if pl = [] then mt () else str " ") ++ + if Array.length cv = 0 then str "= () -- empty inductive" + else + (v 0 (str "= " ++ + prvect_with_sep (fun () -> fnl () ++ str "| ") pp_constructor + (Array.mapi (fun i c -> ConstructRef (ip,i+1),c) cv))) + +let rec pp_ind first kn i ind = + if i >= Array.length ind.ind_packets then + if first then mt () else fnl () + else + let ip = (kn,i) in + let p = ind.ind_packets.(i) in + if is_custom (IndRef (kn,i)) then pp_ind first kn (i+1) ind + else + if p.ip_logical then + pp_logical_ind p ++ pp_ind first kn (i+1) ind + else + pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++ + pp_ind false kn (i+1) ind + + +(*s Pretty-printing of a declaration. *) + +let pp_string_parameters ids = prlist (fun id -> str id ++ str " ") + +let pp_decl = function + | Dind (kn,i) when i.ind_info = Singleton -> + pp_singleton (mind_of_kn kn) i.ind_packets.(0) ++ fnl () + | Dind (kn,i) -> hov 0 (pp_ind true (mind_of_kn kn) 0 i) + | Dtype (r, l, t) -> + if is_inline_custom r then mt () + else + let l = rename_tvars keywords l in + let st = + try + let ids,s = find_type_custom r in + prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s + with not_found -> + prlist (fun id -> pr_id id ++ str " ") l ++ + if t = Taxiom then str "= () -- AXIOM TO BE REALIZED\n" + else str "=" ++ spc () ++ pp_type false l t + in + hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 () + | Dfix (rv, defs, typs) -> + let max = Array.length rv in + let rec iter i = + if i = max then mt () + else + let e = pp_global Term rv.(i) in + e ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl () + ++ pp_function (empty_env ()) e defs.(i) ++ fnl2 () + ++ iter (i+1) + in iter 0 + | Dterm (r, a, t) -> + if is_inline_custom r then mt () + else + let e = pp_global Term r in + e ++ str " :: " ++ pp_type false [] t ++ fnl () ++ + if is_custom r then + hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ()) + else + hov 0 (pp_function (empty_env ()) e a ++ fnl2 ()) + +let rec pp_structure_elem = function + | (l,SEdecl d) -> pp_decl d + | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr + | (l,SEmodtype m) -> mt () + (* for the moment we simply discard module type *) + +and pp_module_expr = function + | MEstruct (mp,sel) -> prlist_strict pp_structure_elem sel + | MEfunctor _ -> mt () + (* for the moment we simply discard unapplied functors *) + | MEident _ | MEapply _ -> assert false + (* should be expansed in extract_env *) + +let pp_struct = + let pp_sel (mp,sel) = + push_visible mp []; + let p = prlist_strict pp_structure_elem sel in + pop_visible (); p + in + prlist_strict pp_sel + + +let haskell_descr = { + keywords = keywords; + file_suffix = ".hs"; + preamble = preamble; + pp_struct = pp_struct; + sig_suffix = None; + sig_preamble = (fun _ _ _ -> mt ()); + pp_sig = (fun _ -> mt ()); + pp_decl = pp_decl; +} diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli new file mode 100644 index 00000000..1b5dbc71 --- /dev/null +++ b/plugins/extraction/haskell.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* module_path list -> unsafe_needs -> std_ppcmds; + pp_struct : ml_structure -> std_ppcmds; + + (* Concerning a possible interface file *) + sig_suffix : string option; + sig_preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds; + pp_sig : ml_signature -> std_ppcmds; + + (* for an isolated declaration print *) + pp_decl : ml_decl -> std_ppcmds; + +} diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml new file mode 100644 index 00000000..6dd43c44 --- /dev/null +++ b/plugins/extraction/mlutil.ml @@ -0,0 +1,1293 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* anonymous_name + | Name id when id = dummy_name -> anonymous_name + | Name id -> id + +let id_of_mlid = function + | Dummy -> dummy_name + | Id id -> id + | Tmp id -> id + +let tmp_id = function + | Id id -> Tmp id + | a -> a + +let is_tmp = function Tmp _ -> true | _ -> false + +(*S Operations upon ML types (with meta). *) + +let meta_count = ref 0 + +let reset_meta_count () = meta_count := 0 + +let new_meta _ = + incr meta_count; + Tmeta {id = !meta_count; contents = None} + +(*s Sustitution of [Tvar i] by [t] in a ML type. *) + +let type_subst i t0 t = + let rec subst t = match t with + | Tvar j when i = j -> t0 + | Tmeta {contents=None} -> t + | Tmeta {contents=Some u} -> subst u + | Tarr (a,b) -> Tarr (subst a, subst b) + | Tglob (r, l) -> Tglob (r, List.map subst l) + | a -> a + in subst t + +(* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *) + +let type_subst_list l t = + let rec subst t = match t with + | Tvar j -> List.nth l (j-1) + | Tmeta {contents=None} -> t + | Tmeta {contents=Some u} -> subst u + | Tarr (a,b) -> Tarr (subst a, subst b) + | Tglob (r, l) -> Tglob (r, List.map subst l) + | a -> a + in subst t + +(* Simultaneous substitution of [[|Tvar 1; ... ; Tvar n|]] by [v] in a ML type. *) + +let type_subst_vect v t = + let rec subst t = match t with + | Tvar j -> v.(j-1) + | Tmeta {contents=None} -> t + | Tmeta {contents=Some u} -> subst u + | Tarr (a,b) -> Tarr (subst a, subst b) + | Tglob (r, l) -> Tglob (r, List.map subst l) + | a -> a + in subst t + +(*s From a type schema to a type. All [Tvar] become fresh [Tmeta]. *) + +let instantiation (nb,t) = type_subst_vect (Array.init nb new_meta) t + +(*s Occur-check of a free meta in a type *) + +let rec type_occurs alpha t = + match t with + | Tmeta {id=beta; contents=None} -> alpha = beta + | Tmeta {contents=Some u} -> type_occurs alpha u + | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2 + | Tglob (r,l) -> List.exists (type_occurs alpha) l + | _ -> false + +(*s Most General Unificator *) + +let rec mgu = function + | Tmeta m, Tmeta m' when m.id = m'.id -> () + | Tmeta m, t when m.contents=None -> + if type_occurs m.id t then raise Impossible + else m.contents <- Some t + | t, Tmeta m when m.contents=None -> + if type_occurs m.id t then raise Impossible + else m.contents <- Some t + | Tmeta {contents=Some u}, t -> mgu (u, t) + | t, Tmeta {contents=Some u} -> mgu (t, u) + | Tarr(a, b), Tarr(a', b') -> + mgu (a, a'); mgu (b, b') + | Tglob (r,l), Tglob (r',l') when r = r' -> + List.iter mgu (List.combine l l') + | Tvar i, Tvar j when i = j -> () + | Tvar' i, Tvar' j when i = j -> () + | Tdummy _, Tdummy _ -> () + | Tunknown, Tunknown -> () + | _ -> raise Impossible + +let needs_magic p = try mgu p; false with Impossible -> true + +let put_magic_if b a = if b && lang () <> Scheme then MLmagic a else a + +let put_magic p a = if needs_magic p && lang () <> Scheme then MLmagic a else a + + +(*S ML type env. *) + +module Mlenv = struct + + let meta_cmp m m' = compare m.id m'.id + module Metaset = Set.Make(struct type t = ml_meta let compare = meta_cmp end) + + (* Main MLenv type. [env] is the real environment, whereas [free] + (tries to) record the free meta variables occurring in [env]. *) + + type t = { env : ml_schema list; mutable free : Metaset.t} + + (* Empty environment. *) + + let empty = { env = []; free = Metaset.empty } + + (* [get] returns a instantiated copy of the n-th most recently added + type in the environment. *) + + let get mle n = + assert (List.length mle.env >= n); + instantiation (List.nth mle.env (n-1)) + + (* [find_free] finds the free meta in a type. *) + + let rec find_free set = function + | Tmeta m when m.contents = None -> Metaset.add m set + | Tmeta {contents = Some t} -> find_free set t + | Tarr (a,b) -> find_free (find_free set a) b + | Tglob (_,l) -> List.fold_left find_free set l + | _ -> set + + (* The [free] set of an environment can be outdate after + some unifications. [clean_free] takes care of that. *) + + let clean_free mle = + let rem = ref Metaset.empty + and add = ref Metaset.empty in + let clean m = match m.contents with + | None -> () + | Some u -> rem := Metaset.add m !rem; add := find_free !add u + in + Metaset.iter clean mle.free; + mle.free <- Metaset.union (Metaset.diff mle.free !rem) !add + + (* From a type to a type schema. If a [Tmeta] is still uninstantiated + and does appears in the [mle], then it becomes a [Tvar]. *) + + let generalization mle t = + let c = ref 0 in + let map = ref (Intmap.empty : int Intmap.t) in + let add_new i = incr c; map := Intmap.add i !c !map; !c in + let rec meta2var t = match t with + | Tmeta {contents=Some u} -> meta2var u + | Tmeta ({id=i} as m) -> + (try Tvar (Intmap.find i !map) + with Not_found -> + if Metaset.mem m mle.free then t + else Tvar (add_new i)) + | Tarr (t1,t2) -> Tarr (meta2var t1, meta2var t2) + | Tglob (r,l) -> Tglob (r, List.map meta2var l) + | t -> t + in !c, meta2var t + + (* Adding a type in an environment, after generalizing. *) + + let push_gen mle t = + clean_free mle; + { env = generalization mle t :: mle.env; free = mle.free } + + (* Adding a type with no [Tvar], hence no generalization needed. *) + + let push_type {env=e;free=f} t = + { env = (0,t) :: e; free = find_free f t} + + (* Adding a type with no [Tvar] nor [Tmeta]. *) + + let push_std_type {env=e;free=f} t = + { env = (0,t) :: e; free = f} + +end + +(*S Operations upon ML types (without meta). *) + +(*s Does a section path occur in a ML type ? *) + +let rec type_mem_kn kn = function + | Tmeta {contents = Some t} -> type_mem_kn kn t + | Tglob (r,l) -> occur_kn_in_ref kn r || List.exists (type_mem_kn kn) l + | Tarr (a,b) -> (type_mem_kn kn a) || (type_mem_kn kn b) + | _ -> false + +(*s Greatest variable occurring in [t]. *) + +let type_maxvar t = + let rec parse n = function + | Tmeta {contents = Some t} -> parse n t + | Tvar i -> max i n + | Tarr (a,b) -> parse (parse n a) b + | Tglob (_,l) -> List.fold_left parse n l + | _ -> n + in parse 0 t + +(*s What are the type variables occurring in [t]. *) + +let intset_union_map_list f l = + List.fold_left (fun s t -> Intset.union s (f t)) Intset.empty l + +let intset_union_map_array f a = + Array.fold_left (fun s t -> Intset.union s (f t)) Intset.empty a + +let rec type_listvar = function + | Tmeta {contents = Some t} -> type_listvar t + | Tvar i | Tvar' i -> Intset.singleton i + | Tarr (a,b) -> Intset.union (type_listvar a) (type_listvar b) + | Tglob (_,l) -> intset_union_map_list type_listvar l + | _ -> Intset.empty + +(*s From [a -> b -> c] to [[a;b],c]. *) + +let rec type_decomp = function + | Tmeta {contents = Some t} -> type_decomp t + | Tarr (a,b) -> let l,h = type_decomp b in a::l, h + | a -> [],a + +(*s The converse: From [[a;b],c] to [a -> b -> c]. *) + +let rec type_recomp (l,t) = match l with + | [] -> t + | a::l -> Tarr (a, type_recomp (l,t)) + +(*s Translating [Tvar] to [Tvar'] to avoid clash. *) + +let rec var2var' = function + | Tmeta {contents = Some t} -> var2var' t + | Tvar i -> Tvar' i + | Tarr (a,b) -> Tarr (var2var' a, var2var' b) + | Tglob (r,l) -> Tglob (r, List.map var2var' l) + | a -> a + +type abbrev_map = global_reference -> ml_type option + +(*s Delta-reduction of type constants everywhere in a ML type [t]. + [env] is a function of type [ml_type_env]. *) + +let type_expand env t = + let rec expand = function + | Tmeta {contents = Some t} -> expand t + | Tglob (r,l) -> + (match env r with + | Some mlt -> expand (type_subst_list l mlt) + | None -> Tglob (r, List.map expand l)) + | Tarr (a,b) -> Tarr (expand a, expand b) + | a -> a + in if Table.type_expand () then expand t else t + +(*s Generating a signature from a ML type. *) + +let type_to_sign env t = match type_expand env t with + | Tdummy d -> Kill d + | _ -> Keep + +let type_to_signature env t = + let rec f = function + | Tmeta {contents = Some t} -> f t + | Tarr (Tdummy d, b) -> Kill d :: f b + | Tarr (_, b) -> Keep :: f b + | _ -> [] + in f (type_expand env t) + +let isKill = function Kill _ -> true | _ -> false + +let isDummy = function Tdummy _ -> true | _ -> false + +let sign_of_id = function + | Dummy -> Kill Kother + | _ -> Keep + +(* Classification of signatures *) + +type sign_kind = + | EmptySig + | NonLogicalSig (* at least a [Keep] *) + | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *) + | SafeLogicalSig (* only [Kill Ktype] *) + +let rec sign_kind = function + | [] -> EmptySig + | Keep :: _ -> NonLogicalSig + | Kill k :: s -> + match sign_kind s with + | NonLogicalSig -> NonLogicalSig + | UnsafeLogicalSig -> UnsafeLogicalSig + | SafeLogicalSig | EmptySig -> + if k = Kother then UnsafeLogicalSig else SafeLogicalSig + +(* Removing the final [Keep] in a signature *) + +let rec sign_no_final_keeps = function + | [] -> [] + | k :: s -> + let s' = k :: sign_no_final_keeps s in + if s' = [Keep] then [] else s' + +(*s Removing [Tdummy] from the top level of a ML type. *) + +let type_expunge_from_sign env s t = + let rec expunge s t = + if s = [] then t else match t with + | Tmeta {contents = Some t} -> expunge s t + | Tarr (a,b) -> + let t = expunge (List.tl s) b in + if List.hd s = Keep then Tarr (a, t) else t + | Tglob (r,l) -> + (match env r with + | Some mlt -> expunge s (type_subst_list l mlt) + | None -> assert false) + | _ -> assert false + in + let t = expunge (sign_no_final_keeps s) t in + if lang () <> Haskell && sign_kind s = UnsafeLogicalSig then + Tarr (Tdummy Kother, t) + else t + +let type_expunge env t = + type_expunge_from_sign env (type_to_signature env t) t + +(*S Generic functions over ML ast terms. *) + +let mlapp f a = if a = [] then f else MLapp (f,a) + +(*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care + of the number of bingings crossed before reaching the [MLrel]. *) + +let ast_iter_rel f = + let rec iter n = function + | MLrel i -> f (i-n) + | MLlam (_,a) -> iter (n+1) a + | MLletin (_,a,b) -> iter n a; iter (n+1) b + | MLcase (_,a,v) -> + iter n a; Array.iter (fun (_,l,t) -> iter (n + (List.length l)) t) v + | MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v + | MLapp (a,l) -> iter n a; List.iter (iter n) l + | MLcons (_,_,l) -> List.iter (iter n) l + | MLmagic a -> iter n a + | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () + in iter 0 + +(*s Map over asts. *) + +let ast_map_case f (c,ids,a) = (c,ids,f a) + +let ast_map f = function + | MLlam (i,a) -> MLlam (i, f a) + | MLletin (i,a,b) -> MLletin (i, f a, f b) + | MLcase (i,a,v) -> MLcase (i,f a, Array.map (ast_map_case f) v) + | MLfix (i,ids,v) -> MLfix (i, ids, Array.map f v) + | MLapp (a,l) -> MLapp (f a, List.map f l) + | MLcons (i,c,l) -> MLcons (i,c, List.map f l) + | MLmagic a -> MLmagic (f a) + | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a + +(*s Map over asts, with binding depth as parameter. *) + +let ast_map_lift_case f n (c,ids,a) = (c,ids, f (n+(List.length ids)) a) + +let ast_map_lift f n = function + | MLlam (i,a) -> MLlam (i, f (n+1) a) + | MLletin (i,a,b) -> MLletin (i, f n a, f (n+1) b) + | MLcase (i,a,v) -> MLcase (i,f n a,Array.map (ast_map_lift_case f n) v) + | MLfix (i,ids,v) -> + let k = Array.length ids in MLfix (i,ids,Array.map (f (k+n)) v) + | MLapp (a,l) -> MLapp (f n a, List.map (f n) l) + | MLcons (i,c,l) -> MLcons (i,c, List.map (f n) l) + | MLmagic a -> MLmagic (f n a) + | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a + +(*s Iter over asts. *) + +let ast_iter_case f (c,ids,a) = f a + +let ast_iter f = function + | MLlam (i,a) -> f a + | MLletin (i,a,b) -> f a; f b + | MLcase (_,a,v) -> f a; Array.iter (ast_iter_case f) v + | MLfix (i,ids,v) -> Array.iter f v + | MLapp (a,l) -> f a; List.iter f l + | MLcons (_,c,l) -> List.iter f l + | MLmagic a -> f a + | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () + +(*S Operations concerning De Bruijn indices. *) + +(*s [ast_occurs k t] returns [true] if [(Rel k)] occurs in [t]. *) + +let ast_occurs k t = + try + ast_iter_rel (fun i -> if i = k then raise Found) t; false + with Found -> true + +(*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)] + in [t] with [k<=i<=k'] *) + +let ast_occurs_itvl k k' t = + try + ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false + with Found -> true + +(*s Number of occurences of [Rel k] (resp. [Rel 1]) in [t]. *) + +let nb_occur_k k t = + let cpt = ref 0 in + ast_iter_rel (fun i -> if i = k then incr cpt) t; + !cpt + +let nb_occur t = nb_occur_k 1 t + +(* Number of occurences of [Rel 1] in [t], with special treatment of match: + occurences in different branches aren't added, but we rather use max. *) + +let nb_occur_match = + let rec nb k = function + | MLrel i -> if i = k then 1 else 0 + | MLcase(_,a,v) -> + (nb k a) + + Array.fold_left + (fun r (_,ids,a) -> max r (nb (k+(List.length ids)) a)) 0 v + | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b) + | MLfix (_,ids,v) -> let k = k+(Array.length ids) in + Array.fold_left (fun r a -> r+(nb k a)) 0 v + | MLlam (_,a) -> nb (k+1) a + | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l + | MLcons (_,_,l) -> List.fold_left (fun r a -> r+(nb k a)) 0 l + | MLmagic a -> nb k a + | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0 + in nb 1 + +(*s Lifting on terms. + [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *) + +let ast_lift k t = + let rec liftrec n = function + | MLrel i as a -> if i-n < 1 then a else MLrel (i+k) + | a -> ast_map_lift liftrec n a + in if k = 0 then t else liftrec 0 t + +let ast_pop t = ast_lift (-1) t + +(*s [permut_rels k k' c] translates [Rel 1 ... Rel k] to [Rel (k'+1) ... + Rel (k'+k)] and [Rel (k+1) ... Rel (k+k')] to [Rel 1 ... Rel k'] *) + +let permut_rels k k' = + let rec permut n = function + | MLrel i as a -> + let i' = i-n in + if i'<1 || i'>k+k' then a + else if i'<=k then MLrel (i+k') + else MLrel (i-k) + | a -> ast_map_lift permut n a + in permut 0 + +(*s Substitution. [ml_subst e t] substitutes [e] for [Rel 1] in [t]. + Lifting (of one binder) is done at the same time. *) + +let ast_subst e = + let rec subst n = function + | MLrel i as a -> + let i' = i-n in + if i'=1 then ast_lift n e + else if i'<1 then a + else MLrel (i-1) + | a -> ast_map_lift subst n a + in subst 0 + +(*s Generalized substitution. + [gen_subst v d t] applies to [t] the substitution coded in the + [v] array: [(Rel i)] becomes [v.(i-1)]. [d] is the correction applies + to [Rel] greater than [Array.length v]. *) + +let gen_subst v d t = + let rec subst n = function + | MLrel i as a -> + let i'= i-n in + if i' < 1 then a + else if i' <= Array.length v then + match v.(i'-1) with + | None -> MLexn ("UNBOUND " ^ string_of_int i') + | Some u -> ast_lift n u + else MLrel (i+d) + | a -> ast_map_lift subst n a + in subst 0 t + +(*S Operations concerning lambdas. *) + +(*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns + [[idn;...;id1]] and the term [t]. *) + +let collect_lams = + let rec collect acc = function + | MLlam(id,t) -> collect (id::acc) t + | x -> acc,x + in collect [] + +(*s [collect_n_lams] does the same for a precise number of [MLlam]. *) + +let collect_n_lams = + let rec collect acc n t = + if n = 0 then acc,t + else match t with + | MLlam(id,t) -> collect (id::acc) (n-1) t + | _ -> assert false + in collect [] + +(*s [remove_n_lams] just removes some [MLlam]. *) + +let rec remove_n_lams n t = + if n = 0 then t + else match t with + | MLlam(_,t) -> remove_n_lams (n-1) t + | _ -> assert false + +(*s [nb_lams] gives the number of head [MLlam]. *) + +let rec nb_lams = function + | MLlam(_,t) -> succ (nb_lams t) + | _ -> 0 + +(*s [named_lams] does the converse of [collect_lams]. *) + +let rec named_lams ids a = match ids with + | [] -> a + | id :: ids -> named_lams ids (MLlam (id,a)) + +(*s The same for a specific identifier (resp. anonymous, dummy) *) + +let rec many_lams id a = function + | 0 -> a + | n -> many_lams id (MLlam (id,a)) (pred n) + +let anonym_lams a n = many_lams anonymous a n +let anonym_tmp_lams a n = many_lams (Tmp anonymous_name) a n +let dummy_lams a n = many_lams Dummy a n + +(*s mixed according to a signature. *) + +let rec anonym_or_dummy_lams a = function + | [] -> a + | Keep :: s -> MLlam(anonymous, anonym_or_dummy_lams a s) + | Kill _ :: s -> MLlam(Dummy, anonym_or_dummy_lams a s) + +(*S Operations concerning eta. *) + +(*s The following function creates [MLrel n;...;MLrel 1] *) + +let rec eta_args n = + if n = 0 then [] else (MLrel n)::(eta_args (pred n)) + +(*s Same, but filtered by a signature. *) + +let rec eta_args_sign n = function + | [] -> [] + | Keep :: s -> (MLrel n) :: (eta_args_sign (n-1) s) + | Kill _ :: s -> eta_args_sign (n-1) s + +(*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *) + +let rec test_eta_args_lift k n = function + | [] -> n=0 + | a :: q -> (a = (MLrel (k+n))) && (test_eta_args_lift k (pred n) q) + +(*s Computes an eta-reduction. *) + +let eta_red e = + let ids,t = collect_lams e in + let n = List.length ids in + if n = 0 then e + else match t with + | MLapp (f,a) -> + let m = List.length a in + let ids,body,args = + if m = n then + [], f, a + else if m < n then + list_skipn m ids, f, a + else (* m > n *) + let a1,a2 = list_chop (m-n) a in + [], MLapp (f,a1), a2 + in + let p = List.length args in + if test_eta_args_lift 0 p args && not (ast_occurs_itvl 1 p body) + then named_lams ids (ast_lift (-p) body) + else e + | _ -> e + +(*s Computes all head linear beta-reductions possible in [(t a)]. + Non-linear head beta-redex become let-in. *) + +let rec linear_beta_red a t = match a,t with + | [], _ -> t + | a0::a, MLlam (id,t) -> + (match nb_occur_match t with + | 0 -> linear_beta_red a (ast_pop t) + | 1 -> linear_beta_red a (ast_subst a0 t) + | _ -> + let a = List.map (ast_lift 1) a in + MLletin (id, a0, linear_beta_red a t)) + | _ -> MLapp (t, a) + +let rec tmp_head_lams = function + | MLlam (id, t) -> MLlam (tmp_id id, tmp_head_lams t) + | e -> e + +(*s Applies a substitution [s] of constants by their body, plus + linear beta reductions at modified positions. + Moreover, we mark some lambdas as suitable for later linear + reduction (this helps the inlining of recursors). +*) + +let rec ast_glob_subst s t = match t with + | MLapp ((MLglob ((ConstRef kn) as refe)) as f, a) -> + let a = List.map (fun e -> tmp_head_lams (ast_glob_subst s e)) a in + (try linear_beta_red a (Refmap.find refe s) + with Not_found -> MLapp (f, a)) + | MLglob ((ConstRef kn) as refe) -> + (try Refmap.find refe s with Not_found -> t) + | _ -> ast_map (ast_glob_subst s) t + + +(*S Auxiliary functions used in simplification of ML cases. *) + +(*s [check_function_branch (r,l,c)] checks if branch [c] can be seen + as a function [f] applied to [MLcons(r,l)]. For that it transforms + any [MLcons(r,l)] in [MLrel 1] and raises [Impossible] if any + variable in [l] occurs outside such a [MLcons] *) + +let check_function_branch (r,l,c) = + let nargs = List.length l in + let rec genrec n = function + | MLrel i as c -> + let i' = i-n in + if i'<1 then c + else if i'>nargs then MLrel (i-nargs+1) + else raise Impossible + | MLcons(_,r',args) when r=r' && (test_eta_args_lift n nargs args) -> + MLrel (n+1) + | a -> ast_map_lift genrec n a + in genrec 0 c + +(*s [check_constant_branch (r,l,c)] checks if branch [c] is independent + from the pattern [MLcons(r,l)]. For that is raises [Impossible] if any + variable in [l] occurs in [c], and otherwise returns [c] lifted to + appear like a function with one arg (for uniformity with the + branch-as-function optimization) *) + +let check_constant_branch (_,l,c) = + let n = List.length l in + if ast_occurs_itvl 1 n c then raise Impossible; + ast_lift (1-n) c + +(* The following structure allows to record which element occurred + at what position, and then finally return the most frequent + element and its positions. *) + +let census_add, census_max, census_clean = + let h = Hashtbl.create 13 in + let clear () = Hashtbl.clear h in + let add e i = + let l = try Hashtbl.find h e with Not_found -> [] in + Hashtbl.replace h e (i::l) + in + let max e0 = + let len = ref 0 and lst = ref [] and elm = ref e0 in + Hashtbl.iter + (fun e l -> + let n = List.length l in + if n > !len then begin len := n; lst := l; elm := e end) + h; + (!elm,!lst) + in + (add,max,clear) + +(* Given an abstraction function [abstr] (one of [check_*_branch]), + return the longest possible list of branches that have the + same abstraction, along with this abstraction. *) + +let factor_branches abstr br = + census_clean (); + for i = 0 to Array.length br - 1 do + try census_add (abstr br.(i)) i with Impossible -> () + done; + let br_factor, br_list = census_max MLdummy in + if br_list = [] then None + else if Array.length br >= 2 && List.length br_list < 2 then None + else Some (br_factor, br_list) + +(*s [check_generalizable_case] checks if all branches can be seen as the + same function [f] applied to the term matched. It is a generalized version + of both the identity case optimization and the constant case optimisation + ([f] can be a constant function) *) + +(* The optimisation [factor_branches check_function_branch] breaks types + in some special case. Example: [type 'x a = A]. + Then [let f = function A -> A] has type ['x a -> 'y a], + which is incompatible with the type of [let f x = x]. + We check first that there isn't such phantom variable in the inductive type + we're considering. *) + +let check_optim_id br = + let (kn,i) = + match br.(0) with (ConstructRef (c,_),_,_) -> c | _ -> assert false + in + let ip = (snd (lookup_ind kn)).ind_packets.(i) in + match ip.ip_optim_id_ok with + | Some ok -> ok + | None -> + let tvars = + intset_union_map_array (intset_union_map_list type_listvar) + ip.ip_types + in + let ok = (Intset.cardinal tvars = List.length ip.ip_vars) in + ip.ip_optim_id_ok <- Some ok; + ok + +(*s If all branches are functions, try to permut the case and the functions. *) + +let rec merge_ids ids ids' = match ids,ids' with + | [],l -> l + | l,[] -> l + | i::ids, i'::ids' -> + (if i = Dummy then i' else i) :: (merge_ids ids ids') + +let is_exn = function MLexn _ -> true | _ -> false + +let rec permut_case_fun br acc = + let nb = ref max_int in + Array.iter (fun (_,_,t) -> + let ids, c = collect_lams t in + let n = List.length ids in + if (n < !nb) && (not (is_exn c)) then nb := n) br; + if !nb = max_int || !nb = 0 then ([],br) + else begin + let br = Array.copy br in + let ids = ref [] in + for i = 0 to Array.length br - 1 do + let (r,l,t) = br.(i) in + let local_nb = nb_lams t in + if local_nb < !nb then (* t = MLexn ... *) + br.(i) <- (r,l,remove_n_lams local_nb t) + else begin + let local_ids,t = collect_n_lams !nb t in + ids := merge_ids !ids local_ids; + br.(i) <- (r,l,permut_rels !nb (List.length l) t) + end + done; + (!ids,br) + end + +(*S Generalized iota-reduction. *) + +(* Definition of a generalized iota-redex: it's a [MLcase(e,_)] + with [(is_iota_gen e)=true]. Any generalized iota-redex is + transformed into beta-redexes. *) + +let rec is_iota_gen = function + | MLcons _ -> true + | MLcase(_,_,br)-> array_for_all (fun (_,_,t)->is_iota_gen t) br + | _ -> false + +let constructor_index = function + | ConstructRef (_,j) -> pred j + | _ -> assert false + +let iota_gen br = + let rec iota k = function + | MLcons (i,r,a) -> + let (_,ids,c) = br.(constructor_index r) in + let c = List.fold_right (fun id t -> MLlam (id,t)) ids c in + let c = ast_lift k c in + MLapp (c,a) + | MLcase(i,e,br') -> + let new_br = + Array.map (fun (n,i,c)->(n,i,iota (k+(List.length i)) c)) br' + in MLcase(i,e, new_br) + | _ -> assert false + in iota 0 + +let is_atomic = function + | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true + | _ -> false + +let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false + +(*S The main simplification function. *) + +(* Some beta-iota reductions + simplifications. *) + +let rec simpl o = function + | MLapp (f, []) -> simpl o f + | MLapp (f, a) -> simpl_app o (List.map (simpl o) a) (simpl o f) + | MLcase (i,e,br) -> + let br = Array.map (fun (n,l,t) -> (n,l,simpl o t)) br in + simpl_case o i br (simpl o e) + | MLletin(Dummy,_,e) -> simpl o (ast_pop e) + | MLletin(id,c,e) -> + let e = simpl o e in + if + (is_atomic c) || (is_atomic e) || + (let n = nb_occur_match e in + (n = 0 || (n=1 && (is_tmp id || is_imm_apply e || o.opt_lin_let)))) + then + simpl o (ast_subst c e) + else + MLletin(id, simpl o c, e) + | MLfix(i,ids,c) -> + let n = Array.length ids in + if ast_occurs_itvl 1 n c.(i) then + MLfix (i, ids, Array.map (simpl o) c) + else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *) + | a -> ast_map (simpl o) a + +(* invariant : list [a] of arguments is non-empty *) + +and simpl_app o a = function + | MLapp (f',a') -> simpl_app o (a'@a) f' + | MLlam (Dummy,t) -> + simpl o (MLapp (ast_pop t, List.tl a)) + | MLlam (id,t) -> (* Beta redex *) + (match nb_occur_match t with + | 0 -> simpl o (MLapp (ast_pop t, List.tl a)) + | 1 when (is_tmp id || o.opt_lin_beta) -> + simpl o (MLapp (ast_subst (List.hd a) t, List.tl a)) + | _ -> + let a' = List.map (ast_lift 1) (List.tl a) in + simpl o (MLletin (id, List.hd a, MLapp (t, a')))) + | MLletin (id,e1,e2) when o.opt_let_app -> + (* Application of a letin: we push arguments inside *) + MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) + | MLcase (i,e,br) when o.opt_case_app -> + (* Application of a case: we push arguments inside *) + let br' = + Array.map + (fun (n,l,t) -> + let k = List.length l in + let a' = List.map (ast_lift k) a in + (n, l, simpl o (MLapp (t,a')))) br + in simpl o (MLcase (i,e,br')) + | (MLdummy | MLexn _) as e -> e + (* We just discard arguments in those cases. *) + | f -> MLapp (f,a) + +(* Invariant : all empty matches should now be [MLexn] *) + +and simpl_case o i br e = + if o.opt_case_iot && (is_iota_gen e) then (* Generalized iota-redex *) + simpl o (iota_gen br e) + else + (* Swap the case and the lam if possible *) + let ids,br = if o.opt_case_fun then permut_case_fun br [] else [],br in + let n = List.length ids in + if n <> 0 then + simpl o (named_lams ids (MLcase (i,ast_lift n e, br))) + else + (* Does a term [f] exist such that many branches are [(f e)] ? *) + let opt1 = + if o.opt_case_idr && (o.opt_case_idg || check_optim_id br) then + factor_branches check_function_branch br + else None + in + (* Detect common constant branches. Often a particular case of + branch-as-function optim, but not always (e.g. A->A|B->A) *) + let opt2 = + if opt1 = None && o.opt_case_cst then + factor_branches check_constant_branch br + else opt1 + in + match opt2 with + | Some (f,ints) when List.length ints = Array.length br -> + (* if all branches have been factorized, we remove the match *) + simpl o (MLletin (Tmp anonymous_name, e, f)) + | Some (f,ints) -> + let ci = if ast_occurs 1 f then BranchFun ints else BranchCst ints + in MLcase ((fst i,ci), e, br) + | None -> MLcase (i, e, br) + +(*S Local prop elimination. *) +(* We try to eliminate as many [prop] as possible inside an [ml_ast]. *) + +(*s In a list, it selects only the elements corresponding to a [Keep] + in the boolean list [l]. *) + +let rec select_via_bl l args = match l,args with + | [],_ -> args + | Keep::l,a::args -> a :: (select_via_bl l args) + | Kill _::l,a::args -> select_via_bl l args + | _ -> assert false + +(*s [kill_some_lams] removes some head lambdas according to the signature [bl]. + This list is build on the identifier list model: outermost lambda + is on the right. + [Rels] corresponding to removed lambdas are supposed not to occur, and + the other [Rels] are made correct via a [gen_subst]. + Output is not directly a [ml_ast], compose with [named_lams] if needed. *) + +let kill_some_lams bl (ids,c) = + let n = List.length bl in + let n' = List.fold_left (fun n b -> if b=Keep then (n+1) else n) 0 bl in + if n = n' then ids,c + else if n' = 0 then [],ast_lift (-n) c + else begin + let v = Array.make n None in + let rec parse_ids i j = function + | [] -> () + | Keep :: l -> v.(i) <- Some (MLrel j); parse_ids (i+1) (j+1) l + | Kill _ :: l -> parse_ids (i+1) j l + in parse_ids 0 1 bl; + select_via_bl bl ids, gen_subst v (n'-n) c + end + +(*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding + to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or + if there is no lambda left at all. *) + +let kill_dummy_lams c = + let ids,c = collect_lams c in + let bl = List.map sign_of_id ids in + if (List.mem Keep bl) && (List.exists isKill bl) then + let ids',c = kill_some_lams bl (ids,c) in + ids, named_lams ids' c + else raise Impossible + +(*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] + and a signature [s] and builds a eta-long version. *) + +(* For example, if [s = [Keep;Keep;Kill Prop;Keep]] then the output is : + [fun idn ... id1 x x _ x -> (c' 4 3 __ 1)] with [c' = lift 4 c] *) + +let eta_expansion_sign s (ids,c) = + let rec abs ids rels i = function + | [] -> + let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels + in ids, MLapp (ast_lift (i-1) c, a) + | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l + | Kill _ :: l -> abs (Dummy :: ids) (MLdummy :: rels) (i+1) l + in abs ids [] 1 s + +(*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] + in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas + corresponding to [Del] in [s]. *) + +let case_expunge s e = + let m = List.length s in + let n = nb_lams e in + let p = if m <= n then collect_n_lams m e + else eta_expansion_sign (list_skipn n s) (collect_lams e) in + kill_some_lams (List.rev s) p + +(*s [term_expunge] takes a function [fun idn ... id1 -> c] + and a signature [s] and remove dummy lams. The difference + with [case_expunge] is that we here leave one dummy lambda + if all lambdas are logical dummy and the target language is strict. *) + +let term_expunge s (ids,c) = + if s = [] then c + else + let ids,c = kill_some_lams (List.rev s) (ids,c) in + if ids = [] && lang () <> Haskell && List.mem (Kill Kother) s then + MLlam (Dummy, ast_lift 1 c) + else named_lams ids c + +(*s [kill_dummy_args ids t0 t] looks for occurences of [t0] in [t] and + purge the args of [t0] corresponding to a [dummy_name]. + It makes eta-expansion if needed. *) + +let kill_dummy_args ids t0 t = + let m = List.length ids in + let bl = List.rev_map sign_of_id ids in + let rec killrec n = function + | MLapp(e, a) when e = ast_lift n t0 -> + let k = max 0 (m - (List.length a)) in + let a = List.map (killrec n) a in + let a = List.map (ast_lift k) a in + let a = select_via_bl bl (a @ (eta_args k)) in + named_lams (list_firstn k ids) (MLapp (ast_lift k e, a)) + | e when e = ast_lift n t0 -> + let a = select_via_bl bl (eta_args m) in + named_lams ids (MLapp (ast_lift m e, a)) + | e -> ast_map_lift killrec n e + in killrec 0 t + +(*s The main function for local [dummy] elimination. *) + +let rec kill_dummy = function + | MLfix(i,fi,c) -> + (try + let ids,c = kill_dummy_fix i c in + ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids (MLrel 1) (MLrel 1)) + with Impossible -> MLfix (i,fi,Array.map kill_dummy c)) + | MLapp (MLfix (i,fi,c),a) -> + let a = List.map kill_dummy a in + (try + let ids,c = kill_dummy_fix i c in + let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in + let fake' = kill_dummy_args ids (MLrel 1) fake in + ast_subst (MLfix (i,fi,c)) fake' + with Impossible -> MLapp(MLfix(i,fi,Array.map kill_dummy c),a)) + | MLletin(id, MLfix (i,fi,c),e) -> + (try + let ids,c = kill_dummy_fix i c in + let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in + MLletin(id, MLfix(i,fi,c),e) + with Impossible -> + MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e)) + | MLletin(id,c,e) -> + (try + let ids,c = kill_dummy_lams (kill_dummy_hd c) in + let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in + let c = eta_red (kill_dummy c) in + if is_atomic c then ast_subst c e else MLletin (id, c, e) + with Impossible -> MLletin(id,kill_dummy c,kill_dummy e)) + | a -> ast_map kill_dummy a + +(* Similar function, but acting only on head lambdas and let-ins *) + +and kill_dummy_hd = function + | MLlam(id,e) -> MLlam(id, kill_dummy_hd e) + | MLletin(id,c,e) -> + (try + let ids,c = kill_dummy_lams (kill_dummy_hd c) in + let e = kill_dummy_hd (kill_dummy_args ids (MLrel 1) e) in + let c = eta_red (kill_dummy c) in + if is_atomic c then ast_subst c e else MLletin (id, c, e) + with Impossible -> MLletin(id,kill_dummy c,kill_dummy_hd e)) + | a -> a + +and kill_dummy_fix i c = + let n = Array.length c in + let ids,ci = kill_dummy_lams (kill_dummy_hd c.(i)) in + let c = Array.copy c in c.(i) <- ci; + for j = 0 to (n-1) do + c.(j) <- kill_dummy (kill_dummy_args ids (MLrel (n-i)) c.(j)) + done; + ids,c + +(*s Putting things together. *) + +let normalize a = + let o = optims () in + let rec norm a = + let a' = if o.opt_kill_dum then kill_dummy (simpl o a) else simpl o a in + if a = a' then a else norm a' + in norm a + +(*S Special treatment of fixpoint for pretty-printing purpose. *) + +let general_optimize_fix f ids n args m c = + let v = Array.make n 0 in + for i=0 to (n-1) do v.(i)<-i done; + let aux i = function + | MLrel j when v.(j-1)>=0 -> + if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1) + | _ -> raise Impossible + in list_iter_i aux args; + let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in + let new_f = anonym_tmp_lams (MLapp (MLrel (n+m+1),args_f)) m in + let new_c = named_lams ids (normalize (MLapp ((ast_subst new_f c),args))) in + MLfix(0,[|f|],[|new_c|]) + +let optimize_fix a = + if not (optims()).opt_fix_fun then a + else + let ids,a' = collect_lams a in + let n = List.length ids in + if n = 0 then a + else match a' with + | MLfix(_,[|f|],[|c|]) -> + let new_f = MLapp (MLrel (n+1),eta_args n) in + let new_c = named_lams ids (normalize (ast_subst new_f c)) + in MLfix(0,[|f|],[|new_c|]) + | MLapp(a',args) -> + let m = List.length args in + (match a' with + | MLfix(_,_,_) when + (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m a') + -> a' + | MLfix(_,[|f|],[|c|]) -> + (try general_optimize_fix f ids n args m c + with Impossible -> a) + | _ -> a) + | _ -> a + +(*S Inlining. *) + +(* Utility functions used in the decision of inlining. *) + +let rec ml_size = function + | MLapp(t,l) -> List.length l + ml_size t + ml_size_list l + | MLlam(_,t) -> 1 + ml_size t + | MLcons(_,_,l) -> ml_size_list l + | MLcase(_,t,pv) -> + 1 + ml_size t + (Array.fold_right (fun (_,_,t) a -> a + ml_size t) pv 0) + | MLfix(_,_,f) -> ml_size_array f + | MLletin (_,_,t) -> ml_size t + | MLmagic t -> ml_size t + | _ -> 0 + +and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l + +and ml_size_array l = Array.fold_left (fun a t -> a + ml_size t) 0 l + +let is_fix = function MLfix _ -> true | _ -> false + +let rec is_constr = function + | MLcons _ -> true + | MLlam(_,t) -> is_constr t + | _ -> false + +(*s Strictness *) + +(* A variable is strict if the evaluation of the whole term implies + the evaluation of this variable. Non-strict variables can be found + behind Match, for example. Expanding a term [t] is a good idea when + it begins by at least one non-strict lambda, since the corresponding + argument to [t] might be unevaluated in the expanded code. *) + +exception Toplevel + +let lift n l = List.map ((+) n) l + +let pop n l = List.map (fun x -> if x<=n then raise Toplevel else x-n) l + +(* This function returns a list of de Bruijn indices of non-strict variables, + or raises [Toplevel] if it has an internal non-strict variable. + In fact, not all variables are checked for strictness, only the ones which + de Bruijn index is in the candidates list [cand]. The flag [add] controls + the behaviour when going through a lambda: should we add the corresponding + variable to the candidates? We use this flag to check only the external + lambdas, those that will correspond to arguments. *) + +let rec non_stricts add cand = function + | MLlam (id,t) -> + let cand = lift 1 cand in + let cand = if add then 1::cand else cand in + pop 1 (non_stricts add cand t) + | MLrel n -> + List.filter ((<>) n) cand + | MLapp (t,l)-> + let cand = non_stricts false cand t in + List.fold_left (non_stricts false) cand l + | MLcons (_,_,l) -> + List.fold_left (non_stricts false) cand l + | MLletin (_,t1,t2) -> + let cand = non_stricts false cand t1 in + pop 1 (non_stricts add (lift 1 cand) t2) + | MLfix (_,i,f)-> + let n = Array.length i in + let cand = lift n cand in + let cand = Array.fold_left (non_stricts false) cand f in + pop n cand + | MLcase (_,t,v) -> + (* The only interesting case: for a variable to be non-strict, *) + (* it is sufficient that it appears non-strict in at least one branch, *) + (* so we make an union (in fact a merge). *) + let cand = non_stricts false cand t in + Array.fold_left + (fun c (_,i,t)-> + let n = List.length i in + let cand = lift n cand in + let cand = pop n (non_stricts add cand t) in + Sort.merge (<=) cand c) [] v + (* [merge] may duplicates some indices, but I don't mind. *) + | MLmagic t -> + non_stricts add cand t + | _ -> + cand + +(* The real test: we are looking for internal non-strict variables, so we start + with no candidates, and the only positive answer is via the [Toplevel] + exception. *) + +let is_not_strict t = + try let _ = non_stricts true [] t in false + with Toplevel -> true + +(*s Inlining decision *) + +(* [inline_test] answers the following question: + If we could inline [t] (the user said nothing special), + should we inline ? + + We expand small terms with at least one non-strict + variable (i.e. a variable that may not be evaluated). + + Futhermore we don't expand fixpoints. + + Moreover, as mentionned by X. Leroy (bug #2241), + inling a constant from inside an opaque module might + break types. To avoid that, we require below that + both [r] and its body are globally visible. This isn't + fully satisfactory, since [r] might not be visible (functor), + and anyway it might be interesting to inline [r] at least + inside its own structure. But to be safe, we adopt this + restriction for the moment. +*) + +open Declarations + +let inline_test r t = + if not (auto_inline ()) then false + else + let c = match r with ConstRef c -> c | _ -> assert false in + let body = try (Global.lookup_constant c).const_body with _ -> None in + if body = None then false + else + let t1 = eta_red t in + let t2 = snd (collect_lams t1) in + not (is_fix t2) && ml_size t < 12 && is_not_strict t + +let con_of_string s = + let null = empty_dirpath in + match repr_dirpath (dirpath_of_string s) with + | id :: d -> make_con (MPfile (make_dirpath d)) null (label_of_id id) + | [] -> assert false + +let manual_inline_set = + List.fold_right (fun x -> Cset.add (con_of_string x)) + [ "Coq.Init.Wf.well_founded_induction_type"; + "Coq.Init.Wf.well_founded_induction"; + "Coq.Init.Wf.Acc_iter"; + "Coq.Init.Wf.Fix_F"; + "Coq.Init.Wf.Fix"; + "Coq.Init.Datatypes.andb"; + "Coq.Init.Datatypes.orb"; + "Coq.Init.Logic.eq_rec_r"; + "Coq.Init.Logic.eq_rect_r"; + "Coq.Init.Specif.proj1_sig"; + ] + Cset.empty + +let manual_inline = function + | ConstRef c -> Cset.mem c manual_inline_set + | _ -> false + +(* If the user doesn't say he wants to keep [t], we inline in two cases: + \begin{itemize} + \item the user explicitly requests it + \item [expansion_test] answers that the inlining is a good idea, and + we are free to act (AutoInline is set) + \end{itemize} *) + +let inline r t = + not (to_keep r) (* The user DOES want to keep it *) + && not (is_inline_custom r) + && (to_inline r (* The user DOES want to inline it *) + || (lang () <> Haskell && not (is_projection r) && + (is_recursor r || manual_inline r || inline_test r t))) + diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli new file mode 100644 index 00000000..deaacc3f --- /dev/null +++ b/plugins/extraction/mlutil.mli @@ -0,0 +1,131 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit +val new_meta : 'a -> ml_type + +val type_subst : int -> ml_type -> ml_type -> ml_type +val type_subst_list : ml_type list -> ml_type -> ml_type +val type_subst_vect : ml_type array -> ml_type -> ml_type + +val instantiation : ml_schema -> ml_type + +val needs_magic : ml_type * ml_type -> bool +val put_magic_if : bool -> ml_ast -> ml_ast +val put_magic : ml_type * ml_type -> ml_ast -> ml_ast + +(*s ML type environment. *) + +module Mlenv : sig + type t + val empty : t + + (* get the n-th more recently entered schema and instantiate it. *) + val get : t -> int -> ml_type + + (* Adding a type in an environment, after generalizing free meta *) + val push_gen : t -> ml_type -> t + + (* Adding a type with no [Tvar] *) + val push_type : t -> ml_type -> t + + (* Adding a type with no [Tvar] nor [Tmeta] *) + val push_std_type : t -> ml_type -> t +end + +(*s Utility functions over ML types without meta *) + +val type_mem_kn : mutual_inductive -> ml_type -> bool + +val type_maxvar : ml_type -> int + +val type_decomp : ml_type -> ml_type list * ml_type +val type_recomp : ml_type list * ml_type -> ml_type + +val var2var' : ml_type -> ml_type + +type abbrev_map = global_reference -> ml_type option + +val type_expand : abbrev_map -> ml_type -> ml_type +val type_to_sign : abbrev_map -> ml_type -> sign +val type_to_signature : abbrev_map -> ml_type -> signature +val type_expunge : abbrev_map -> ml_type -> ml_type +val type_expunge_from_sign : abbrev_map -> signature -> ml_type -> ml_type + +val isDummy : ml_type -> bool +val isKill : sign -> bool + +val case_expunge : signature -> ml_ast -> ml_ident list * ml_ast +val term_expunge : signature -> ml_ident list * ml_ast -> ml_ast + + +(*s Special identifiers. [dummy_name] is to be used for dead code + and will be printed as [_] in concrete (Caml) code. *) + +val anonymous_name : identifier +val dummy_name : identifier +val id_of_name : name -> identifier +val id_of_mlid : ml_ident -> identifier +val tmp_id : ml_ident -> ml_ident + +(*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns + the list [idn;...;id1] and the term [t]. *) + +val collect_lams : ml_ast -> ml_ident list * ml_ast +val collect_n_lams : int -> ml_ast -> ml_ident list * ml_ast +val remove_n_lams : int -> ml_ast -> ml_ast +val nb_lams : ml_ast -> int +val named_lams : ml_ident list -> ml_ast -> ml_ast +val dummy_lams : ml_ast -> int -> ml_ast +val anonym_or_dummy_lams : ml_ast -> signature -> ml_ast + +val eta_args_sign : int -> signature -> ml_ast list + +(*s Utility functions over ML terms. *) + +val mlapp : ml_ast -> ml_ast list -> ml_ast +val ast_map : (ml_ast -> ml_ast) -> ml_ast -> ml_ast +val ast_map_lift : (int -> ml_ast -> ml_ast) -> int -> ml_ast -> ml_ast +val ast_iter : (ml_ast -> unit) -> ml_ast -> unit +val ast_occurs : int -> ml_ast -> bool +val ast_occurs_itvl : int -> int -> ml_ast -> bool +val ast_lift : int -> ml_ast -> ml_ast +val ast_pop : ml_ast -> ml_ast +val ast_subst : ml_ast -> ml_ast -> ml_ast + +val ast_glob_subst : ml_ast Refmap.t -> ml_ast -> ml_ast + +val normalize : ml_ast -> ml_ast +val optimize_fix : ml_ast -> ml_ast +val inline : global_reference -> ml_ast -> bool + +exception Impossible +val check_function_branch : ml_branch -> ml_ast +val check_constant_branch : ml_branch -> ml_ast + +(* Classification of signatures *) + +type sign_kind = + | EmptySig + | NonLogicalSig (* at least a [Keep] *) + | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *) + | SafeLogicalSig (* only [Kill Ktype] *) + +val sign_kind : signature -> sign_kind + +val sign_no_final_keeps : signature -> signature diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml new file mode 100644 index 00000000..a7f0c017 --- /dev/null +++ b/plugins/extraction/modutil.ml @@ -0,0 +1,375 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mp + | MTwith(mt,_)-> msid_of_mt mt + | _ -> anomaly "Extraction:the With operator isn't applied to a name" + +(*s Apply some functions upon all [ml_decl] and [ml_spec] found in a + [ml_structure]. *) + +let struct_iter do_decl do_spec s = + let rec mt_iter = function + | MTident _ -> () + | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' + | MTwith (mt,ML_With_type(idl,l,t))-> + let mp_mt = msid_of_mt mt in + let l',idl' = list_sep_last idl in + let mp_w = + List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl' + in + let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in + mt_iter mt; do_decl (Dtype(r,l,t)) + | MTwith (mt,_)->mt_iter mt + | MTsig (_, sign) -> List.iter spec_iter sign + and spec_iter = function + | (_,Spec s) -> do_spec s + | (_,Smodule mt) -> mt_iter mt + | (_,Smodtype mt) -> mt_iter mt + in + let rec se_iter = function + | (_,SEdecl d) -> do_decl d + | (_,SEmodule m) -> + me_iter m.ml_mod_expr; mt_iter m.ml_mod_type + | (_,SEmodtype m) -> mt_iter m + and me_iter = function + | MEident _ -> () + | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt + | MEapply (me,me') -> me_iter me; me_iter me' + | MEstruct (msid, sel) -> List.iter se_iter sel + in + List.iter (function (_,sel) -> List.iter se_iter sel) s + +(*s Apply some fonctions upon all references in [ml_type], [ml_ast], + [ml_decl], [ml_spec] and [ml_structure]. *) + +type do_ref = global_reference -> unit + +let record_iter_references do_term = function + | Record l -> List.iter do_term l + | _ -> () + +let type_iter_references do_type t = + let rec iter = function + | Tglob (r,l) -> do_type r; List.iter iter l + | Tarr (a,b) -> iter a; iter b + | _ -> () + in iter t + +let ast_iter_references do_term do_cons do_type a = + let rec iter a = + ast_iter iter a; + match a with + | MLglob r -> do_term r + | MLcons (i,r,_) -> + if lang () = Ocaml then record_iter_references do_term i; + do_cons r + | MLcase (i,_,v) -> + if lang () = Ocaml then record_iter_references do_term (fst i); + Array.iter (fun (r,_,_) -> do_cons r) v + | _ -> () + in iter a + +let ind_iter_references do_term do_cons do_type kn ind = + let type_iter = type_iter_references do_type in + let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in + let packet_iter ip p = + do_type (IndRef ip); + if lang () = Ocaml then + (match ind.ind_equiv with + | Miniml.Equiv kne -> do_type (IndRef (mind_of_kn kne, snd ip)); + | _ -> ()); + Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types + in + if lang () = Ocaml then record_iter_references do_term ind.ind_info; + Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets + +let decl_iter_references do_term do_cons do_type = + let type_iter = type_iter_references do_type + and ast_iter = ast_iter_references do_term do_cons do_type in + function + | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type + (mind_of_kn kn) ind + | Dtype (r,_,t) -> do_type r; type_iter t + | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t + | Dfix(rv,c,t) -> + Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t + +let spec_iter_references do_term do_cons do_type = function + | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type (mind_of_kn kn) ind + | Stype (r,_,ot) -> do_type r; Option.iter (type_iter_references do_type) ot + | Sval (r,t) -> do_term r; type_iter_references do_type t + +(*s Searching occurrences of a particular term (no lifting done). *) + +exception Found + +let rec ast_search f a = + if f a then raise Found else ast_iter (ast_search f) a + +let decl_ast_search f = function + | Dterm (_,a,_) -> ast_search f a + | Dfix (_,c,_) -> Array.iter (ast_search f) c + | _ -> () + +let struct_ast_search f s = + try struct_iter (decl_ast_search f) (fun _ -> ()) s; false + with Found -> true + +let rec type_search f = function + | Tarr (a,b) -> type_search f a; type_search f b + | Tglob (r,l) -> List.iter (type_search f) l + | u -> if f u then raise Found + +let decl_type_search f = function + | Dind (_,{ind_packets=p}) -> + Array.iter + (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p + | Dterm (_,_,u) -> type_search f u + | Dfix (_,_,v) -> Array.iter (type_search f) v + | Dtype (_,_,u) -> type_search f u + +let spec_type_search f = function + | Sind (_,{ind_packets=p}) -> + Array.iter + (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p + | Stype (_,_,ot) -> Option.iter (type_search f) ot + | Sval (_,u) -> type_search f u + +let struct_type_search f s = + try struct_iter (decl_type_search f) (spec_type_search f) s; false + with Found -> true + + +(*s Generating the signature. *) + +let rec msig_of_ms = function + | [] -> [] + | (l,SEdecl (Dind (kn,i))) :: ms -> + (l,Spec (Sind (kn,i))) :: (msig_of_ms ms) + | (l,SEdecl (Dterm (r,_,t))) :: ms -> + (l,Spec (Sval (r,t))) :: (msig_of_ms ms) + | (l,SEdecl (Dtype (r,v,t))) :: ms -> + (l,Spec (Stype (r,v,Some t))) :: (msig_of_ms ms) + | (l,SEdecl (Dfix (rv,_,tv))) :: ms -> + let msig = ref (msig_of_ms ms) in + for i = Array.length rv - 1 downto 0 do + msig := (l,Spec (Sval (rv.(i),tv.(i))))::!msig + done; + !msig + | (l,SEmodule m) :: ms -> (l,Smodule m.ml_mod_type) :: (msig_of_ms ms) + | (l,SEmodtype m) :: ms -> (l,Smodtype m) :: (msig_of_ms ms) + +let signature_of_structure s = + List.map (fun (mp,ms) -> mp,msig_of_ms ms) s + + +(*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *) + +let get_decl_in_structure r struc = + try + let base_mp,ll = labels_of_ref r in + if not (at_toplevel base_mp) then error_not_visible r; + let sel = List.assoc base_mp struc in + let rec go ll sel = match ll with + | [] -> assert false + | l :: ll -> + match List.assoc l sel with + | SEdecl d -> d + | SEmodtype m -> assert false + | SEmodule m -> + match m.ml_mod_expr with + | MEstruct (_,sel) -> go ll sel + | _ -> error_not_visible r + in go ll sel + with Not_found -> + anomaly "reference not found in extracted structure" + + +(*s Optimization of a [ml_structure]. *) + +(* Some transformations of ML terms. [optimize_struct] simplify + all beta redexes (when the argument does not occur, it is just + thrown away; when it occurs exactly once it is substituted; otherwise + a let-in redex is created for clarity) and iota redexes, plus some other + optimizations. *) + +let dfix_to_mlfix rv av i = + let rec make_subst n s = + if n < 0 then s + else make_subst (n-1) (Refmap.add rv.(n) (n+1) s) + in + let s = make_subst (Array.length rv - 1) Refmap.empty + in + let rec subst n t = match t with + | MLglob ((ConstRef kn) as refe) -> + (try MLrel (n + (Refmap.find refe s)) with Not_found -> t) + | _ -> ast_map_lift subst n t + in + let ids = Array.map (fun r -> id_of_label (label_of_r r)) rv in + let c = Array.map (subst 0) av + in MLfix(i, ids, c) + +let rec optim to_appear s = function + | [] -> [] + | (Dtype (r,_,Tdummy _) | Dterm(r,MLdummy,_)) as d :: l -> + if List.mem r to_appear + then d :: (optim to_appear s l) + else optim to_appear s l + | Dterm (r,t,typ) :: l -> + let t = normalize (ast_glob_subst !s t) in + let i = inline r t in + if i then s := Refmap.add r t !s; + if not i || modular () || List.mem r to_appear + then + let d = match optimize_fix t with + | MLfix (0, _, [|c|]) -> + Dfix ([|r|], [|ast_subst (MLglob r) c|], [|typ|]) + | t -> Dterm (r, t, typ) + in d :: (optim to_appear s l) + else optim to_appear s l + | d :: l -> d :: (optim to_appear s l) + +let rec optim_se top to_appear s = function + | [] -> [] + | (l,SEdecl (Dterm (r,a,t))) :: lse -> + let a = normalize (ast_glob_subst !s a) in + let i = inline r a in + if i then s := Refmap.add r a !s; + if top && i && not (modular ()) && not (List.mem r to_appear) + then optim_se top to_appear s lse + else + let d = match optimize_fix a with + | MLfix (0, _, [|c|]) -> + Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) + | a -> Dterm (r, a, t) + in (l,SEdecl d) :: (optim_se top to_appear s lse) + | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> + let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in + let all = ref true in + (* This fake body ensures that no fixpoint will be auto-inlined. *) + let fake_body = MLfix (0,[||],[||]) in + for i = 0 to Array.length rv - 1 do + if inline rv.(i) fake_body + then s := Refmap.add rv.(i) (dfix_to_mlfix rv av i) !s + else all := false + done; + if !all && top && not (modular ()) + && (array_for_all (fun r -> not (List.mem r to_appear)) rv) + then optim_se top to_appear s lse + else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) + | (l,SEmodule m) :: lse -> + let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr} + in (l,SEmodule m) :: (optim_se top to_appear s lse) + | se :: lse -> se :: (optim_se top to_appear s lse) + +and optim_me to_appear s = function + | MEstruct (msid, lse) -> MEstruct (msid, optim_se false to_appear s lse) + | MEident mp as me -> me + | MEapply (me, me') -> + MEapply (optim_me to_appear s me, optim_me to_appear s me') + | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me to_appear s me) + +(* After these optimisations, some dependencies may not be needed anymore. + For monolithic extraction, we recompute a minimal set of dependencies. *) + +exception NoDepCheck + +let base_r = function + | ConstRef c as r -> r + | IndRef (kn,_) -> IndRef (kn,0) + | ConstructRef ((kn,_),_) -> IndRef (kn,0) + | _ -> assert false + +let reset_needed, add_needed, found_needed, is_needed = + let needed = ref Refset.empty in + ((fun l -> needed := Refset.empty), + (fun r -> needed := Refset.add (base_r r) !needed), + (fun r -> needed := Refset.remove (base_r r) !needed), + (fun r -> Refset.mem (base_r r) !needed)) + +let declared_refs = function + | Dind (kn,_) -> [|IndRef (mind_of_kn kn,0)|] + | Dtype (r,_,_) -> [|r|] + | Dterm (r,_,_) -> [|r|] + | Dfix (rv,_,_) -> rv + +(* Computes the dependencies of a declaration, except in case + of custom extraction. *) + +let compute_deps_decl = function + | Dind (kn,ind) -> + (* Todo Later : avoid dependencies when Extract Inductive *) + ind_iter_references add_needed add_needed add_needed (mind_of_kn kn) ind + | Dtype (r,ids,t) -> + if not (is_custom r) then type_iter_references add_needed t + | Dterm (r,u,t) -> + type_iter_references add_needed t; + if not (is_custom r) then + ast_iter_references add_needed add_needed add_needed u + | Dfix _ as d -> + (* Todo Later : avoid dependencies when Extract Constant *) + decl_iter_references add_needed add_needed add_needed d + +let rec depcheck_se = function + | [] -> [] + | ((l,SEdecl d) as t)::se -> + let se' = depcheck_se se in + let rv = declared_refs d in + if not (array_exists is_needed rv) then + (Array.iter remove_info_axiom rv; se') + else + (Array.iter found_needed rv; compute_deps_decl d; t::se') + | _ -> raise NoDepCheck + +let rec depcheck_struct = function + | [] -> [] + | (mp,lse)::struc -> + let struc' = depcheck_struct struc in + let lse' = depcheck_se lse in + (mp,lse')::struc' + +let check_implicits = function + | MLexn s -> + if String.length s > 8 && (s.[0] = 'U' || s.[0] = 'I') then + begin + if String.sub s 0 7 = "UNBOUND" then assert false; + if String.sub s 0 8 = "IMPLICIT" then + error_non_implicit (String.sub s 9 (String.length s - 9)); + end; + false + | _ -> false + +let optimize_struct to_appear struc = + let subst = ref (Refmap.empty : ml_ast Refmap.t) in + let opt_struc = + List.map (fun (mp,lse) -> (mp, optim_se true to_appear subst lse)) struc + in + let opt_struc = List.filter (fun (_,lse) -> lse<>[]) opt_struc in + ignore (struct_ast_search check_implicits opt_struc); + try + if modular () then raise NoDepCheck; + reset_needed (); + List.iter add_needed to_appear; + depcheck_struct opt_struc + with NoDepCheck -> opt_struc diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli new file mode 100644 index 00000000..8e04a368 --- /dev/null +++ b/plugins/extraction/modutil.mli @@ -0,0 +1,41 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool) -> ml_structure -> bool +val struct_type_search : (ml_type -> bool) -> ml_structure -> bool + +type do_ref = global_reference -> unit + +val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit +val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit + +val signature_of_structure : ml_structure -> ml_signature + +val msid_of_mt : ml_module_type -> module_path + +val get_decl_in_structure : global_reference -> ml_structure -> ml_decl + +(* Some transformations of ML terms. [optimize_struct] simplify + all beta redexes (when the argument does not occur, it is just + thrown away; when it occurs exactly once it is substituted; otherwise + a let-in redex is created for clarity) and iota redexes, plus some other + optimizations. The first argument is the list of objects we want to appear. +*) + +val optimize_struct : global_reference list -> ml_structure -> ml_structure diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml new file mode 100644 index 00000000..30004677 --- /dev/null +++ b/plugins/extraction/ocaml.ml @@ -0,0 +1,759 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* '\'' + then str ("'"^s) + else str ("' "^s) + +let pp_tuple_light f = function + | [] -> mt () + | [x] -> f true x + | l -> + pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l) + +let pp_tuple f = function + | [] -> mt () + | [x] -> f x + | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l) + +let pp_boxed_tuple f = function + | [] -> mt () + | [x] -> f x + | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l)) + +let pp_abst = function + | [] -> mt () + | l -> + str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++ + str " ->" ++ spc () + +let pp_parameters l = + (pp_boxed_tuple pp_tvar l ++ space_if (l<>[])) + +let pp_string_parameters l = + (pp_boxed_tuple str l ++ space_if (l<>[])) + +(*s Ocaml renaming issues. *) + +let keywords = + List.fold_right (fun s -> Idset.add (id_of_string s)) + [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; + "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; + "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; + "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; + "module"; "mutable"; "new"; "object"; "of"; "open"; "or"; + "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true"; + "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod"; + "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] + Idset.empty + +let pp_open mp = str ("open "^ string_of_modfile mp ^"\n") + +let preamble _ used_modules usf = + prlist pp_open used_modules ++ + (if used_modules = [] then mt () else fnl ()) ++ + (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n" else mt()) ++ + (if usf.mldummy then + str "let __ = let rec f _ = Obj.repr f in Obj.repr f\n" + else mt ()) ++ + (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ()) + +let sig_preamble _ used_modules usf = + prlist pp_open used_modules ++ + (if used_modules = [] then mt () else fnl ()) ++ + (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n\n" else mt()) + +(*s The pretty-printer for Ocaml syntax*) + +(* Beware of the side-effects of [pp_global] and [pp_modname]. + They are used to update table of content for modules. Many [let] + below should not be altered since they force evaluation order. +*) + +let str_global k r = + if is_inline_custom r then find_custom r else Common.pp_global k r + +let pp_global k r = str (str_global k r) + +let pp_modname mp = str (Common.pp_module mp) + +let is_infix r = + is_inline_custom r && + (let s = find_custom r in + let l = String.length s in + l >= 2 && s.[0] = '(' && s.[l-1] = ')') + +let get_infix r = + let s = find_custom r in + String.sub s 1 (String.length s - 2) + +exception NoRecord + +let find_projections = function Record l -> l | _ -> raise NoRecord + +(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses + are needed or not. *) + +let mk_ind path s = + make_mind (MPfile (dirpath_of_string path)) empty_dirpath (mk_label s) + +let rec pp_type par vl t = + let rec pp_rec par = function + | Tmeta _ | Tvar' _ | Taxiom -> assert false + | Tvar i -> (try pp_tvar (List.nth vl (pred i)) + with _ -> (str "'a" ++ int i)) + | Tglob (r,[a1;a2]) when is_infix r -> + pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2) + | Tglob (r,[]) -> pp_global Type r + | Tglob (IndRef(kn,0),l) when kn = mk_ind "Coq.Init.Specif" "sig" -> + pp_tuple_light pp_rec l + | Tglob (r,l) -> + pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r + | Tarr (t1,t2) -> + pp_par par + (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) + | Tdummy _ -> str "__" + | Tunknown -> str "__" + in + hov 0 (pp_rec par t) + +(*s Pretty-printing of expressions. [par] indicates whether + parentheses are needed or not. [env] is the list of names for the + de Bruijn variables. [args] is the list of collected arguments + (already pretty-printed). *) + +let is_ifthenelse = function + | [|(r1,[],_);(r2,[],_)|] -> + (try (find_custom r1 = "true") && (find_custom r2 = "false") + with Not_found -> false) + | _ -> false + +let expr_needs_par = function + | MLlam _ -> true + | MLcase (_,_,[|_|]) -> false + | MLcase (_,_,pv) -> not (is_ifthenelse pv) + | _ -> false + + +(** Special hack for constants of type Ascii.ascii : if an + [Extract Inductive ascii => char] has been declared, then + the constants are directly turned into chars *) + +let ind_ascii = mk_ind "Coq.Strings.Ascii" "ascii" + +let check_extract_ascii () = + try find_custom (IndRef (ind_ascii,0)) = "char" with Not_found -> false + +let is_list_cons l = + List.for_all (function MLcons (_,ConstructRef(_,_),[]) -> true | _ -> false) l + +let pp_char l = + let rec cumul = function + | [] -> 0 + | MLcons(_,ConstructRef(_,j),[])::l -> (2-j) + 2 * (cumul l) + | _ -> assert false + in str ("'"^Char.escaped (Char.chr (cumul l))^"'") + +let rec pp_expr par env args = + let par' = args <> [] || par + and apply st = pp_apply st par args in + function + | MLrel n -> + let id = get_db_name n env in apply (pr_id id) + | MLapp (f,args') -> + let stl = List.map (pp_expr true env []) args' in + pp_expr par env (stl @ args) f + | MLlam _ as a -> + let fl,a' = collect_lams a in + let fl = List.map id_of_mlid fl in + let fl,env' = push_vars fl env in + let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in + apply (pp_par par' st) + | MLletin (id,a1,a2) -> + let i,env' = push_vars [id_of_mlid id] env in + let pp_id = pr_id (List.hd i) + and pp_a1 = pp_expr false env [] a1 + and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in + hv 0 + (apply + (pp_par par' + (hv 0 + (hov 2 + (str "let " ++ pp_id ++ str " =" ++ spc () ++ pp_a1) ++ + spc () ++ str "in") ++ + spc () ++ hov 0 pp_a2))) + | MLglob r -> + (try + let args = list_skipn (projection_arity r) args in + let record = List.hd args in + pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args) + with _ -> apply (pp_global Term r)) + | MLcons(_,ConstructRef ((kn,0),1),l) + when kn = ind_ascii && check_extract_ascii () & is_list_cons l -> + assert (args=[]); + pp_char l + | MLcons (Coinductive,r,[]) -> + assert (args=[]); + pp_par par (str "lazy " ++ pp_global Cons r) + | MLcons (Coinductive,r,args') -> + assert (args=[]); + let tuple = pp_tuple (pp_expr true env []) args' in + pp_par par (str "lazy (" ++ pp_global Cons r ++ spc() ++ tuple ++str ")") + | MLcons (_,r,[]) -> + assert (args=[]); + pp_global Cons r + | MLcons (Record projs, r, args') -> + assert (args=[]); + pp_record_pat (projs, List.map (pp_expr true env []) args') + | MLcons (_,r,[arg1;arg2]) when is_infix r -> + assert (args=[]); + pp_par par + ((pp_expr true env [] arg1) ++ str (get_infix r) ++ + (pp_expr true env [] arg2)) + | MLcons (_,r,args') -> + assert (args=[]); + let tuple = pp_tuple (pp_expr true env []) args' in + if str_global Cons r = "" (* hack Extract Inductive prod *) + then tuple + else pp_par par (pp_global Cons r ++ spc () ++ tuple) + | MLcase (_, t, pv) when is_custom_match pv -> + let mkfun (_,ids,e) = + if ids <> [] then named_lams (List.rev ids) e + else dummy_lams (ast_lift 1 e) 1 + in + hov 2 (str (find_custom_match pv) ++ fnl () ++ + prvect (fun tr -> pp_expr true env [] (mkfun tr) ++ fnl ()) pv + ++ pp_expr true env [] t) + | MLcase ((i,factors), t, pv) -> + let expr = if i = Coinductive then + (str "Lazy.force" ++ spc () ++ pp_expr true env [] t) + else + (pp_expr false env [] t) + in + (try + let projs = find_projections i in + let (_, ids, c) = pv.(0) in + let n = List.length ids in + match c with + | MLrel i when i <= n -> + apply (pp_par par' (pp_expr true env [] t ++ str "." ++ + pp_global Term (List.nth projs (n-i)))) + | MLapp (MLrel i, a) when i <= n -> + if List.exists (ast_occurs_itvl 1 n) a + then raise NoRecord + else + let ids,env' = push_vars (List.rev_map id_of_mlid ids) env + in + (pp_apply + (pp_expr true env [] t ++ str "." ++ + pp_global Term (List.nth projs (n-i))) + par ((List.map (pp_expr true env' []) a) @ args)) + | _ -> raise NoRecord + with NoRecord -> + if Array.length pv = 1 then + let s1,s2 = pp_one_pat env i pv.(0) in + apply + (hv 0 + (pp_par par' + (hv 0 + (hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr) + ++ spc () ++ str "in") ++ + spc () ++ hov 0 s2))) + else + apply + (pp_par par' + (try pp_ifthenelse par' env expr pv + with Not_found -> + v 0 (str "match " ++ expr ++ str " with" ++ fnl () ++ + str " | " ++ pp_pat env (i,factors) pv)))) + | MLfix (i,ids,defs) -> + let ids',env' = push_vars (List.rev (Array.to_list ids)) env in + pp_fix par env' i (Array.of_list (List.rev ids'),defs) args + | MLexn s -> + (* An [MLexn] may be applied, but I don't really care. *) + pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)")) + | MLdummy -> + str "__" (* An [MLdummy] may be applied, but I don't really care. *) + | MLmagic a -> + pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args) + | MLaxiom -> + pp_par par (str "failwith \"AXIOM TO BE REALIZED\"") + + +and pp_record_pat (projs, args) = + str "{ " ++ + prlist_with_sep (fun () -> str ";" ++ spc ()) + (fun (r,a) -> pp_global Term r ++ str " =" ++ spc () ++ a) + (List.combine projs args) ++ + str " }" + +and pp_ifthenelse par env expr pv = match pv with + | [|(tru,[],the);(fal,[],els)|] when + (find_custom tru = "true") && (find_custom fal = "false") + -> + hv 0 (hov 2 (str "if " ++ expr) ++ spc () ++ + hov 2 (str "then " ++ + hov 2 (pp_expr (expr_needs_par the) env [] the)) ++ spc () ++ + hov 2 (str "else " ++ + hov 2 (pp_expr (expr_needs_par els) env [] els))) + | _ -> raise Not_found + +and pp_one_pat env i (r,ids,t) = + let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in + let expr = pp_expr (expr_needs_par t) env' [] t in + try + let projs = find_projections i in + pp_record_pat (projs, List.rev_map pr_id ids), expr + with NoRecord -> + (match List.rev ids with + | [i1;i2] when is_infix r -> pr_id i1 ++ str (get_infix r) ++ pr_id i2 + | [] -> pp_global Cons r + | ids -> + (* hack Extract Inductive prod *) + (if str_global Cons r = "" then mt () else pp_global Cons r ++ spc ()) + ++ pp_boxed_tuple pr_id ids), + expr + +and pp_pat env (info,factors) pv = + let factor_br, factor_l = try match factors with + | BranchFun (i::_ as l) -> check_function_branch pv.(i), l + | BranchCst (i::_ as l) -> ast_pop (check_constant_branch pv.(i)), l + | _ -> MLdummy, [] + with Impossible -> MLdummy, [] + in + let par = expr_needs_par factor_br in + let last = Array.length pv - 1 in + prvecti + (fun i x -> if List.mem i factor_l then mt () else + let s1,s2 = pp_one_pat env info x in + hov 2 (s1 ++ str " ->" ++ spc () ++ s2) ++ + if i = last && factor_l = [] then mt () else + fnl () ++ str " | ") pv + ++ + if factor_l = [] then mt () else match factors with + | BranchFun _ -> + let ids, env' = push_vars [anonymous_name] env in + hov 2 (pr_id (List.hd ids) ++ str " ->" ++ spc () ++ + pp_expr par env' [] factor_br) + | BranchCst _ -> + hov 2 (str "_ ->" ++ spc () ++ pp_expr par env [] factor_br) + | BranchNone -> mt () + +and pp_function env t = + let bl,t' = collect_lams t in + let bl,env' = push_vars (List.map id_of_mlid bl) env in + match t' with + | MLcase(i,MLrel 1,pv) when fst i=Standard && not (is_custom_match pv) -> + if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then + pr_binding (List.rev (List.tl bl)) ++ + str " = function" ++ fnl () ++ + v 0 (str " | " ++ pp_pat env' i pv) + else + pr_binding (List.rev bl) ++ + str " = match " ++ pr_id (List.hd bl) ++ str " with" ++ fnl () ++ + v 0 (str " | " ++ pp_pat env' i pv) + | _ -> + pr_binding (List.rev bl) ++ + str " =" ++ fnl () ++ str " " ++ + hov 2 (pp_expr false env' [] t') + +(*s names of the functions ([ids]) are already pushed in [env], + and passed here just for convenience. *) + +and pp_fix par env i (ids,bl) args = + pp_par par + (v 0 (str "let rec " ++ + prvect_with_sep + (fun () -> fnl () ++ str "and ") + (fun (fi,ti) -> pr_id fi ++ pp_function env ti) + (array_map2 (fun id b -> (id,b)) ids bl) ++ + fnl () ++ + hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) + +let pp_val e typ = + hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++ + str " **)") ++ fnl2 () + +(*s Pretty-printing of [Dfix] *) + +let pp_Dfix (rv,c,t) = + let names = Array.map + (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv + in + let rec pp sep letand i = + if i >= Array.length rv then mt () + else if is_inline_custom rv.(i) then pp sep letand (i+1) + else + let def = + if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i)) + else pp_function (empty_env ()) c.(i) + in + sep () ++ pp_val names.(i) t.(i) ++ + str letand ++ names.(i) ++ def ++ pp fnl2 "and " (i+1) + in pp mt "let rec " 0 + +(*s Pretty-printing of inductive types declaration. *) + +let pp_equiv param_list name = function + | NoEquiv, _ -> mt () + | Equiv kn, i -> + str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (mind_of_kn kn,i)) + | RenEquiv ren, _ -> + str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name + +let pp_comment s = str "(* " ++ s ++ str " *)" + +let pp_one_ind prefix ip_equiv pl name cnames ctyps = + let pl = rename_tvars keywords pl in + let pp_constructor i typs = + (if i=0 then mt () else fnl ()) ++ + hov 5 (str " | " ++ cnames.(i) ++ + (if typs = [] then mt () else str " of ") ++ + prlist_with_sep + (fun () -> spc () ++ str "* ") (pp_type true pl) typs) + in + pp_parameters pl ++ str prefix ++ name ++ + pp_equiv pl name ip_equiv ++ str " =" ++ + if Array.length ctyps = 0 then str " unit (* empty inductive *)" + else fnl () ++ v 0 (prvecti pp_constructor ctyps) + +let pp_logical_ind packet = + pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ + fnl () ++ + pp_comment (str "with constructors : " ++ + prvect_with_sep spc pr_id packet.ip_consnames) ++ + fnl () + +let pp_singleton kn packet = + let name = pp_global Type (IndRef (mind_of_kn kn,0)) in + let l = rename_tvars keywords packet.ip_vars in + hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++ + pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ + pp_comment (str "singleton inductive, whose constructor was " ++ + pr_id packet.ip_consnames.(0))) + +let pp_record kn projs ip_equiv packet = + let name = pp_global Type (IndRef (mind_of_kn kn,0)) in + let projnames = List.map (pp_global Term) projs in + let l = List.combine projnames packet.ip_types.(0) in + let pl = rename_tvars keywords packet.ip_vars in + str "type " ++ pp_parameters pl ++ name ++ + pp_equiv pl name ip_equiv ++ str " = { "++ + hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) + (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l) + ++ str " }" + +let pp_coind pl name = + let pl = rename_tvars keywords pl in + pp_parameters pl ++ name ++ str " = " ++ + pp_parameters pl ++ str "__" ++ name ++ str " Lazy.t" ++ + fnl() ++ str "and " + +let pp_ind co kn ind = + let prefix = if co then "__" else "" in + let some = ref false in + let init= ref (str "type ") in + let names = + Array.mapi (fun i p -> if p.ip_logical then mt () else + pp_global Type (IndRef (mind_of_kn kn,i))) + ind.ind_packets + in + let cnames = + Array.mapi + (fun i p -> if p.ip_logical then [||] else + Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((mind_of_kn kn,i),j+1))) + p.ip_types) + ind.ind_packets + in + let rec pp i = + if i >= Array.length ind.ind_packets then mt () + else + let ip = (mind_of_kn kn,i) in + let ip_equiv = ind.ind_equiv, i in + let p = ind.ind_packets.(i) in + if is_custom (IndRef ip) then pp (i+1) + else begin + some := true; + if p.ip_logical then pp_logical_ind p ++ pp (i+1) + else + let s = !init in + begin + init := (fnl () ++ str "and "); + s ++ + (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ + pp_one_ind + prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ + pp (i+1) + end + end + in + let st = pp 0 in if !some then st else failwith "empty phrase" + + +(*s Pretty-printing of a declaration. *) + +let pp_mind kn i = + match i.ind_info with + | Singleton -> pp_singleton kn i.ind_packets.(0) + | Coinductive -> pp_ind true kn i + | Record projs -> + pp_record kn projs (i.ind_equiv,0) i.ind_packets.(0) + | Standard -> pp_ind false kn i + +let pp_decl = function + | Dtype (r,_,_) when is_inline_custom r -> failwith "empty phrase" + | Dterm (r,_,_) when is_inline_custom r -> failwith "empty phrase" + | Dind (kn,i) -> pp_mind kn i + | Dtype (r, l, t) -> + let name = pp_global Type r in + let l = rename_tvars keywords l in + let ids, def = + try + let ids,s = find_type_custom r in + pp_string_parameters ids, str "=" ++ spc () ++ str s + with Not_found -> + pp_parameters l, + if t = Taxiom then str "(* AXIOM TO BE REALIZED *)" + else str "=" ++ spc () ++ pp_type false l t + in + hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) + | Dterm (r, a, t) -> + let def = + if is_custom r then str (" = " ^ find_custom r) + else if is_projection r then + (prvect str (Array.make (projection_arity r) " _")) ++ + str " x = x." + else pp_function (empty_env ()) a + in + let name = pp_global Term r in + let postdef = if is_projection r then name else mt () in + pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ postdef) + | Dfix (rv,defs,typs) -> + pp_Dfix (rv,defs,typs) + +let pp_alias_decl ren = function + | Dind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } + | Dtype (r, l, _) -> + let name = pp_global Type r in + let l = rename_tvars keywords l in + let ids = pp_parameters l in + hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ + str (ren^".") ++ name) + | Dterm (r, a, t) -> + let name = pp_global Term r in + hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) + | Dfix (rv, _, _) -> + prvecti (fun i r -> if is_inline_custom r then mt () else + let name = pp_global Term r in + hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) ++ + fnl ()) + rv + +let pp_spec = function + | Sval (r,_) when is_inline_custom r -> failwith "empty phrase" + | Stype (r,_,_) when is_inline_custom r -> failwith "empty phrase" + | Sind (kn,i) -> pp_mind kn i + | Sval (r,t) -> + let def = pp_type false [] t in + let name = pp_global Term r in + hov 2 (str "val " ++ name ++ str " :" ++ spc () ++ def) + | Stype (r,vl,ot) -> + let name = pp_global Type r in + let l = rename_tvars keywords vl in + let ids, def = + try + let ids, s = find_type_custom r in + pp_string_parameters ids, str "= " ++ str s + with Not_found -> + let ids = pp_parameters l in + match ot with + | None -> ids, mt () + | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" + | Some t -> ids, str "=" ++ spc () ++ pp_type false l t + in + hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) + +let pp_alias_spec ren = function + | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } + | Stype (r,l,_) -> + let name = pp_global Type r in + let l = rename_tvars keywords l in + let ids = pp_parameters l in + hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ + str (ren^".") ++ name) + | Sval _ -> assert false + +let rec pp_specif = function + | (_,Spec (Sval _ as s)) -> pp_spec s + | (l,Spec s) -> + (try + let ren = Common.check_duplicate (top_visible_mp ()) l in + hov 1 (str ("module "^ren^" : sig ") ++ fnl () ++ pp_spec s) ++ + fnl () ++ str "end" ++ fnl () ++ + pp_alias_spec ren s + with Not_found -> pp_spec s) + | (l,Smodule mt) -> + let def = pp_module_type [] mt in + let def' = pp_module_type [] mt in + let name = pp_modname (MPdot (top_visible_mp (), l)) in + hov 1 (str "module " ++ name ++ str " : " ++ fnl () ++ def) ++ + (try + let ren = Common.check_duplicate (top_visible_mp ()) l in + fnl () ++ hov 1 (str ("module "^ren^" : ") ++ fnl () ++ def') + with Not_found -> Pp.mt ()) + | (l,Smodtype mt) -> + let def = pp_module_type [] mt in + let name = pp_modname (MPdot (top_visible_mp (), l)) in + hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ + (try + let ren = Common.check_duplicate (top_visible_mp ()) l in + fnl () ++ str ("module type "^ren^" = ") ++ name + with Not_found -> Pp.mt ()) + +and pp_module_type params = function + | MTident kn -> + pp_modname kn + | MTfunsig (mbid, mt, mt') -> + let typ = pp_module_type [] mt in + let name = pp_modname (MPbound mbid) in + let def = pp_module_type (MPbound mbid :: params) mt' in + str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def + | MTsig (mp, sign) -> + push_visible mp params; + let l = map_succeed pp_specif sign in + pop_visible (); + str "sig " ++ fnl () ++ + v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ + fnl () ++ str "end" + | MTwith(mt,ML_With_type(idl,vl,typ)) -> + let ids = pp_parameters (rename_tvars keywords vl) in + let mp_mt = msid_of_mt mt in + let l,idl' = list_sep_last idl in + let mp_w = + List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl' + in + let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l)) in + push_visible mp_mt []; + let pp_w = str " with type " ++ ids ++ pp_global Type r in + pop_visible(); + pp_module_type [] mt ++ pp_w ++ str " = " ++ pp_type false vl typ + | MTwith(mt,ML_With_module(idl,mp)) -> + let mp_mt = msid_of_mt mt in + let mp_w = + List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) mp_mt idl + in + push_visible mp_mt []; + let pp_w = str " with module " ++ pp_modname mp_w in + pop_visible (); + pp_module_type [] mt ++ pp_w ++ str " = " ++ pp_modname mp + +let is_short = function MEident _ | MEapply _ -> true | _ -> false + +let rec pp_structure_elem = function + | (l,SEdecl d) -> + (try + let ren = Common.check_duplicate (top_visible_mp ()) l in + hov 1 (str ("module "^ren^" = struct ") ++ fnl () ++ pp_decl d) ++ + fnl () ++ str "end" ++ fnl () ++ + pp_alias_decl ren d + with Not_found -> pp_decl d) + | (l,SEmodule m) -> + let typ = + (* virtual printing of the type, in order to have a correct mli later*) + if Common.get_phase () = Pre then + str ": " ++ pp_module_type [] m.ml_mod_type + else mt () + in + let def = pp_module_expr [] m.ml_mod_expr in + let name = pp_modname (MPdot (top_visible_mp (), l)) in + hov 1 + (str "module " ++ name ++ typ ++ str " = " ++ + (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++ + (try + let ren = Common.check_duplicate (top_visible_mp ()) l in + fnl () ++ str ("module "^ren^" = ") ++ name + with Not_found -> mt ()) + | (l,SEmodtype m) -> + let def = pp_module_type [] m in + let name = pp_modname (MPdot (top_visible_mp (), l)) in + hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ + (try + let ren = Common.check_duplicate (top_visible_mp ()) l in + fnl () ++ str ("module type "^ren^" = ") ++ name + with Not_found -> mt ()) + +and pp_module_expr params = function + | MEident mp -> pp_modname mp + | MEapply (me, me') -> + pp_module_expr [] me ++ str "(" ++ pp_module_expr [] me' ++ str ")" + | MEfunctor (mbid, mt, me) -> + let name = pp_modname (MPbound mbid) in + let typ = pp_module_type [] mt in + let def = pp_module_expr (MPbound mbid :: params) me in + str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def + | MEstruct (mp, sel) -> + push_visible mp params; + let l = map_succeed pp_structure_elem sel in + pop_visible (); + str "struct " ++ fnl () ++ + v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ + fnl () ++ str "end" + +let do_struct f s = + let pp s = try f s ++ fnl2 () with Failure "empty phrase" -> mt () + in + let ppl (mp,sel) = + push_visible mp []; + let p = prlist_strict pp sel in + (* for monolithic extraction, we try to simulate the unavailability + of [MPfile] in names by artificially nesting these [MPfile] *) + (if modular () then pop_visible ()); p + in + let p = prlist_strict ppl s in + (if not (modular ()) then repeat (List.length s) pop_visible ()); + p + +let pp_struct s = do_struct pp_structure_elem s + +let pp_signature s = do_struct pp_specif s + +let pp_decl d = try pp_decl d with Failure "empty phrase" -> mt () + +let ocaml_descr = { + keywords = keywords; + file_suffix = ".ml"; + preamble = preamble; + pp_struct = pp_struct; + sig_suffix = Some ".mli"; + sig_preamble = sig_preamble; + pp_sig = pp_signature; + pp_decl = pp_decl; +} + + diff --git a/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli new file mode 100644 index 00000000..4a1c1778 --- /dev/null +++ b/plugins/extraction/ocaml.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Idset.add (id_of_string s)) + [ "define"; "let"; "lambda"; "lambdas"; "match"; + "apply"; "car"; "cdr"; + "error"; "delay"; "force"; "_"; "__"] + Idset.empty + +let preamble _ _ usf = + str ";; This extracted scheme code relies on some additional macros\n" ++ + str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme\n" ++ + str "(load \"macros_extr.scm\")\n\n" ++ + (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ()) + +let pr_id id = + let s = string_of_id id in + for i = 0 to String.length s - 1 do + if s.[i] = '\'' then s.[i] <- '~' + done; + str s + +let paren = pp_par true + +let pp_abst st = function + | [] -> assert false + | [id] -> paren (str "lambda " ++ paren (pr_id id) ++ spc () ++ st) + | l -> paren + (str "lambdas " ++ paren (prlist_with_sep spc pr_id l) ++ spc () ++ st) + +let pp_apply st _ = function + | [] -> st + | [a] -> hov 2 (paren (st ++ spc () ++ a)) + | args -> hov 2 (paren (str "@ " ++ st ++ + (prlist_strict (fun x -> spc () ++ x) args))) + +(*s The pretty-printer for Scheme syntax *) + +let pp_global k r = str (Common.pp_global k r) + +(*s Pretty-printing of expressions. *) + +let rec pp_expr env args = + let apply st = pp_apply st true args in + function + | MLrel n -> + let id = get_db_name n env in apply (pr_id id) + | MLapp (f,args') -> + let stl = List.map (pp_expr env []) args' in + pp_expr env (stl @ args) f + | MLlam _ as a -> + let fl,a' = collect_lams a in + let fl,env' = push_vars (List.map id_of_mlid fl) env in + apply (pp_abst (pp_expr env' [] a') (List.rev fl)) + | MLletin (id,a1,a2) -> + let i,env' = push_vars [id_of_mlid id] env in + apply + (hv 0 + (hov 2 + (paren + (str "let " ++ + paren + (paren + (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) + ++ spc () ++ hov 0 (pp_expr env' [] a2))))) + | MLglob r -> + apply (pp_global Term r) + | MLcons (i,r,args') -> + assert (args=[]); + let st = + str "`" ++ + paren (pp_global Cons r ++ + (if args' = [] then mt () else spc ()) ++ + prlist_with_sep spc (pp_cons_args env) args') + in + if i = Coinductive then paren (str "delay " ++ st) else st + | MLcase (_,t,pv) when is_custom_match pv -> + let mkfun (_,ids,e) = + if ids <> [] then named_lams (List.rev ids) e + else dummy_lams (ast_lift 1 e) 1 + in + hov 2 (str (find_custom_match pv) ++ fnl () ++ + prvect (fun tr -> pp_expr env [] (mkfun tr) ++ fnl ()) pv + ++ pp_expr env [] t) + | MLcase ((i,_),t, pv) -> + let e = + if i <> Coinductive then pp_expr env [] t + else paren (str "force" ++ spc () ++ pp_expr env [] t) + in + apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv))) + | MLfix (i,ids,defs) -> + let ids',env' = push_vars (List.rev (Array.to_list ids)) env in + pp_fix env' i (Array.of_list (List.rev ids'),defs) args + | MLexn s -> + (* An [MLexn] may be applied, but I don't really care. *) + paren (str "error" ++ spc () ++ qs s) + | MLdummy -> + str "__" (* An [MLdummy] may be applied, but I don't really care. *) + | MLmagic a -> + pp_expr env args a + | MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"") + +and pp_cons_args env = function + | MLcons (i,r,args) when i<>Coinductive -> + paren (pp_global Cons r ++ + (if args = [] then mt () else spc ()) ++ + prlist_with_sep spc (pp_cons_args env) args) + | e -> str "," ++ pp_expr env [] e + + +and pp_one_pat env (r,ids,t) = + let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in + let args = + if ids = [] then mt () + else (str " " ++ prlist_with_sep spc pr_id (List.rev ids)) + in + (pp_global Cons r ++ args), (pp_expr env' [] t) + +and pp_pat env pv = + prvect_with_sep fnl + (fun x -> let s1,s2 = pp_one_pat env x in + hov 2 (str "((" ++ s1 ++ str ")" ++ spc () ++ s2 ++ str ")")) pv + +(*s names of the functions ([ids]) are already pushed in [env], + and passed here just for convenience. *) + +and pp_fix env j (ids,bl) args = + paren + (str "letrec " ++ + (v 0 (paren + (prvect_with_sep fnl + (fun (fi,ti) -> + paren ((pr_id fi) ++ spc () ++ (pp_expr env [] ti))) + (array_map2 (fun id b -> (id,b)) ids bl)) ++ + fnl () ++ + hov 2 (pp_apply (pr_id (ids.(j))) true args)))) + +(*s Pretty-printing of a declaration. *) + +let pp_decl = function + | Dind _ -> mt () + | Dtype _ -> mt () + | Dfix (rv, defs,_) -> + let ppv = Array.map (pp_global Term) rv in + prvect_with_sep fnl + (fun (pi,ti) -> + hov 2 + (paren (str "define " ++ pi ++ spc () ++ + (pp_expr (empty_env ()) [] ti)) + ++ fnl ())) + (array_map2 (fun p b -> (p,b)) ppv defs) ++ + fnl () + | Dterm (r, a, _) -> + if is_inline_custom r then mt () + else + if is_custom r then + hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ + str (find_custom r))) ++ fnl () ++ fnl () + else + hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ + pp_expr (empty_env ()) [] a)) ++ fnl () ++ fnl () + +let rec pp_structure_elem = function + | (l,SEdecl d) -> pp_decl d + | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr + | (l,SEmodtype m) -> mt () + (* for the moment we simply discard module type *) + +and pp_module_expr = function + | MEstruct (mp,sel) -> prlist_strict pp_structure_elem sel + | MEfunctor _ -> mt () + (* for the moment we simply discard unapplied functors *) + | MEident _ | MEapply _ -> assert false + (* should be expansed in extract_env *) + +let pp_struct = + let pp_sel (mp,sel) = + push_visible mp []; + let p = prlist_strict pp_structure_elem sel in + pop_visible (); p + in + prlist_strict pp_sel + +let scheme_descr = { + keywords = keywords; + file_suffix = ".scm"; + preamble = preamble; + pp_struct = pp_struct; + sig_suffix = None; + sig_preamble = (fun _ _ _ -> mt ()); + pp_sig = (fun _ -> mt ()); + pp_decl = pp_decl; +} diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli new file mode 100644 index 00000000..b0fa395c --- /dev/null +++ b/plugins/extraction/scheme.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* kn = kn' + | ConstRef _ -> false + | VarRef _ -> assert false + +let repr_of_r = function + | ConstRef kn -> repr_con kn + | IndRef (kn,_) + | ConstructRef ((kn,_),_) -> repr_mind kn + | VarRef _ -> assert false + +let modpath_of_r r = + let mp,_,_ = repr_of_r r in mp + +let label_of_r r = + let _,_,l = repr_of_r r in l + +let rec base_mp = function + | MPdot (mp,l) -> base_mp mp + | mp -> mp + +let is_modfile = function + | MPfile _ -> true + | _ -> false + +let raw_string_of_modfile = function + | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f))) + | _ -> assert false + +let rec modfile_of_mp = function + | (MPfile _) as mp -> mp + | MPdot (mp,_) -> modfile_of_mp mp + | _ -> raise Not_found + +let current_toplevel () = fst (Lib.current_prefix ()) + +let is_toplevel mp = + mp = initial_path || mp = current_toplevel () + +let at_toplevel mp = + is_modfile mp || is_toplevel mp + +let rec mp_length mp = + let mp0 = current_toplevel () in + let rec len = function + | mp when mp = mp0 -> 1 + | MPdot (mp,_) -> 1 + len mp + | _ -> 1 + in len mp + +let visible_con kn = at_toplevel (base_mp (con_modpath kn)) + +let rec prefixes_mp mp = match mp with + | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp') + | _ -> MPset.singleton mp + +let rec get_nth_label_mp n = function + | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp + | _ -> failwith "get_nth_label: not enough MPdot" + +let common_prefix_from_list mp0 mpl = + let prefixes = prefixes_mp mp0 in + let rec f = function + | [] -> None + | mp :: l -> if MPset.mem mp prefixes then Some mp else f l + in f mpl + +let rec parse_labels ll = function + | MPdot (mp,l) -> parse_labels (l::ll) mp + | mp -> mp,ll + +let labels_of_mp mp = parse_labels [] mp + +let rec parse_labels2 ll mp1 = function + | mp when mp1=mp -> mp,ll + | MPdot (mp,l) -> parse_labels2 (l::ll) mp1 mp + | mp -> mp,ll + +let labels_of_ref r = + let mp_top = current_toplevel () in + let mp,_,l = repr_of_r r in + parse_labels2 [l] mp_top mp + +let rec add_labels_mp mp = function + | [] -> mp + | l :: ll -> add_labels_mp (MPdot (mp,l)) ll + + +(*S The main tables: constants, inductives, records, ... *) + +(* Theses tables are not registered within coq save/undo mechanism + since we reset their contents at each run of Extraction *) + +(*s Constants tables. *) + +let terms = ref (Cmap.empty : ml_decl Cmap.t) +let init_terms () = terms := Cmap.empty +let add_term kn d = terms := Cmap.add kn d !terms +let lookup_term kn = Cmap.find kn !terms + +let types = ref (Cmap.empty : ml_schema Cmap.t) +let init_types () = types := Cmap.empty +let add_type kn s = types := Cmap.add kn s !types +let lookup_type kn = Cmap.find kn !types + +(*s Inductives table. *) + +let inductives = ref (Mindmap.empty : (mutual_inductive_body * ml_ind) Mindmap.t) +let init_inductives () = inductives := Mindmap.empty +let add_ind kn mib ml_ind = inductives := Mindmap.add kn (mib,ml_ind) !inductives +let lookup_ind kn = Mindmap.find kn !inductives + +(*s Recursors table. *) + +let recursors = ref Cset.empty +let init_recursors () = recursors := Cset.empty + +let add_recursors env kn = + let make_kn id = make_con (mind_modpath kn) empty_dirpath (label_of_id id) in + let mib = Environ.lookup_mind kn env in + Array.iter + (fun mip -> + let id = mip.mind_typename in + let kn_rec = make_kn (Nameops.add_suffix id "_rec") + and kn_rect = make_kn (Nameops.add_suffix id "_rect") in + recursors := Cset.add kn_rec (Cset.add kn_rect !recursors)) + mib.mind_packets + +let is_recursor = function + | ConstRef kn -> Cset.mem kn !recursors + | _ -> false + +(*s Record tables. *) + +let projs = ref (Refmap.empty : int Refmap.t) +let init_projs () = projs := Refmap.empty +let add_projection n kn = projs := Refmap.add (ConstRef kn) n !projs +let is_projection r = Refmap.mem r !projs +let projection_arity r = Refmap.find r !projs + +(*s Table of used axioms *) + +let info_axioms = ref Refset.empty +let log_axioms = ref Refset.empty +let init_axioms () = info_axioms := Refset.empty; log_axioms := Refset.empty +let add_info_axiom r = info_axioms := Refset.add r !info_axioms +let remove_info_axiom r = info_axioms := Refset.remove r !info_axioms +let add_log_axiom r = log_axioms := Refset.add r !log_axioms + +(*s Extraction mode: modular or monolithic *) + +let modular_ref = ref false + +let set_modular b = modular_ref := b +let modular () = !modular_ref + +(*s Printing. *) + +(* The following functions work even on objects not in [Global.env ()]. + WARNING: for inductive objects, an extract_inductive must have been + done before. *) + +let safe_basename_of_global = function + | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l + | IndRef (kn,i) -> (snd (lookup_ind kn)).ind_packets.(i).ip_typename + | ConstructRef ((kn,i),j) -> + (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1) + | _ -> assert false + +let string_of_global r = + try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r) + with _ -> string_of_id (safe_basename_of_global r) + +let safe_pr_global r = str (string_of_global r) + +(* idem, but with qualification, and only for constants. *) + +let safe_pr_long_global r = + try Printer.pr_global r + with _ -> match r with + | ConstRef kn -> + let mp,_,l = repr_con kn in + str ((string_of_mp mp)^"."^(string_of_label l)) + | _ -> assert false + +let pr_long_mp mp = + let lid = repr_dirpath (Nametab.dirpath_of_module mp) in + str (String.concat "." (List.map string_of_id (List.rev lid))) + +let pr_long_global ref = pr_path (Nametab.path_of_global ref) + +(*S Warning and Error messages. *) + +let err s = errorlabstrm "Extraction" s + +let warning_axioms () = + let info_axioms = Refset.elements !info_axioms in + if info_axioms = [] then () + else begin + let s = if List.length info_axioms = 1 then "axiom" else "axioms" in + msg_warning + (str ("The following "^s^" must be realized in the extracted code:") + ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global info_axioms) + ++ str "." ++ fnl ()) + end; + let log_axioms = Refset.elements !log_axioms in + if log_axioms = [] then () + else begin + let s = if List.length log_axioms = 1 then "axiom was" else "axioms were" + in + msg_warning + (str ("The following logical "^s^" encountered:") ++ + hov 1 + (spc () ++ prlist_with_sep spc safe_pr_global log_axioms ++ str ".\n") + ++ + str "Having invalid logical axiom in the environment when extracting" ++ + spc () ++ str "may lead to incorrect or non-terminating ML terms." ++ + fnl ()) + end + +let warning_both_mod_and_cst q mp r = + msg_warning + (str "The name " ++ pr_qualid q ++ str " is ambiguous, " ++ + str "do you mean module " ++ + pr_long_mp mp ++ + str " or object " ++ + pr_long_global r ++ str " ?" ++ fnl () ++ + str "First choice is assumed, for the second one please use " ++ + str "fully qualified name." ++ fnl ()) + +let error_axiom_scheme r i = + err (str "The type scheme axiom " ++ spc () ++ + safe_pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ + str " type variable(s).") + +let check_inside_module () = + if Lib.is_modtype () then + err (str "You can't do that within a Module Type." ++ fnl () ++ + str "Close it and try again.") + else if Lib.is_module () then + msg_warning + (str "Extraction inside an opened module is experimental.\n" ++ + str "In case of problem, close it first.\n") + +let check_inside_section () = + if Lib.sections_are_opened () then + err (str "You can't do that within a section." ++ fnl () ++ + str "Close it and try again.") + +let warning_id s = + msg_warning (str ("The identifier "^s^ + " contains __ which is reserved for the extraction")) + +let error_constant r = + err (safe_pr_global r ++ str " is not a constant.") + +let error_inductive r = + err (safe_pr_global r ++ spc () ++ str "is not an inductive type.") + +let error_nb_cons () = + err (str "Not the right number of constructors.") + +let error_module_clash mp1 mp2 = + err (str "The Coq modules " ++ pr_long_mp mp1 ++ str " and " ++ + pr_long_mp mp2 ++ str " have the same ML name.\n" ++ + str "This is not supported yet. Please do some renaming first.") + +let error_unknown_module m = + err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.") + +let error_scheme () = + err (str "No Scheme modular extraction available yet.") + +let error_not_visible r = + err (safe_pr_global r ++ str " is not directly visible.\n" ++ + str "For example, it may be inside an applied functor.\n" ++ + str "Use Recursive Extraction to get the whole environment.") + +let error_MPfile_as_mod mp b = + let s1 = if b then "asked" else "required" in + let s2 = if b then "extract some objects of this module or\n" else "" in + err (str ("Extraction of file "^(raw_string_of_modfile mp)^ + ".v as a module is "^s1^".\n"^ + "Monolithic Extraction cannot deal with this situation.\n"^ + "Please "^s2^"use (Recursive) Extraction Library instead.\n")) + +let error_record r = + err (str "Record " ++ safe_pr_global r ++ str " has an anonymous field." ++ + fnl () ++ str "To help extraction, please use an explicit name.") + +let msg_non_implicit r n id = + let name = match id with + | Anonymous -> "" + | Name id -> "(" ^ string_of_id id ^ ") " + in + "The " ^ (ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r) + +let error_non_implicit msg = + err (str (msg ^ " still occurs after extraction.") ++ + fnl () ++ str "Please check the Extraction Implicit declarations.") + +let check_loaded_modfile mp = match base_mp mp with + | MPfile dp -> + if not (Library.library_is_loaded dp) then begin + match base_mp (current_toplevel ()) with + | MPfile dp' when dp<>dp' -> + err (str ("Please load library "^(string_of_dirpath dp^" first."))) + | _ -> () + end + | _ -> () + +let info_file f = + Flags.if_verbose message + ("The file "^f^" has been created by extraction.") + + +(*S The Extraction auxiliary commands *) + +(* The objects defined below should survive an arbitrary time, + so we register them to coq save/undo mechanism. *) + +(*s Extraction AutoInline *) + +let auto_inline_ref = ref false + +let auto_inline () = !auto_inline_ref + +let _ = declare_bool_option + {optsync = true; + optname = "Extraction AutoInline"; + optkey = ["Extraction"; "AutoInline"]; + optread = auto_inline; + optwrite = (:=) auto_inline_ref} + +(*s Extraction TypeExpand *) + +let type_expand_ref = ref true + +let type_expand () = !type_expand_ref + +let _ = declare_bool_option + {optsync = true; + optname = "Extraction TypeExpand"; + optkey = ["Extraction"; "TypeExpand"]; + optread = type_expand; + optwrite = (:=) type_expand_ref} + +(*s Extraction Optimize *) + +type opt_flag = + { opt_kill_dum : bool; (* 1 *) + opt_fix_fun : bool; (* 2 *) + opt_case_iot : bool; (* 4 *) + opt_case_idr : bool; (* 8 *) + opt_case_idg : bool; (* 16 *) + opt_case_cst : bool; (* 32 *) + opt_case_fun : bool; (* 64 *) + opt_case_app : bool; (* 128 *) + opt_let_app : bool; (* 256 *) + opt_lin_let : bool; (* 512 *) + opt_lin_beta : bool } (* 1024 *) + +let kth_digit n k = (n land (1 lsl k) <> 0) + +let flag_of_int n = + { opt_kill_dum = kth_digit n 0; + opt_fix_fun = kth_digit n 1; + opt_case_iot = kth_digit n 2; + opt_case_idr = kth_digit n 3; + opt_case_idg = kth_digit n 4; + opt_case_cst = kth_digit n 5; + opt_case_fun = kth_digit n 6; + opt_case_app = kth_digit n 7; + opt_let_app = kth_digit n 8; + opt_lin_let = kth_digit n 9; + opt_lin_beta = kth_digit n 10 } + +(* For the moment, we allow by default everything except : + - the type-unsafe optimization [opt_case_idg] + - the linear let and beta reduction [opt_lin_let] and [opt_lin_beta] + (may lead to complexity blow-up, subsumed by finer reductions + when inlining recursors). +*) + +let int_flag_init = 1 + 2 + 4 + 8 (*+ 16*) + 32 + 64 + 128 + 256 (*+ 512 + 1024*) + +let int_flag_ref = ref int_flag_init +let opt_flag_ref = ref (flag_of_int int_flag_init) + +let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n + +let optims () = !opt_flag_ref + +let _ = declare_bool_option + {optsync = true; + optname = "Extraction Optimize"; + optkey = ["Extraction"; "Optimize"]; + optread = (fun () -> !int_flag_ref <> 0); + optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))} + +let _ = declare_int_option + { optsync = true; + optname = "Extraction Flag"; + optkey = ["Extraction";"Flag"]; + optread = (fun _ -> Some !int_flag_ref); + optwrite = (function + | None -> chg_flag 0 + | Some i -> chg_flag (max i 0))} + + +(*s Extraction Lang *) + +type lang = Ocaml | Haskell | Scheme + +let lang_ref = ref Ocaml + +let lang () = !lang_ref + +let (extr_lang,_) = + declare_object + {(default_object "Extraction Lang") with + cache_function = (fun (_,l) -> lang_ref := l); + load_function = (fun _ (_,l) -> lang_ref := l)} + +let _ = declare_summary "Extraction Lang" + { freeze_function = (fun () -> !lang_ref); + unfreeze_function = ((:=) lang_ref); + init_function = (fun () -> lang_ref := Ocaml) } + +let extraction_language x = Lib.add_anonymous_leaf (extr_lang x) + +(*s Extraction Inline/NoInline *) + +let empty_inline_table = (Refset.empty,Refset.empty) + +let inline_table = ref empty_inline_table + +let to_inline r = Refset.mem r (fst !inline_table) + +let to_keep r = Refset.mem r (snd !inline_table) + +let add_inline_entries b l = + let f b = if b then Refset.add else Refset.remove in + let i,k = !inline_table in + inline_table := + (List.fold_right (f b) l i), + (List.fold_right (f (not b)) l k) + +(* Registration of operations for rollback. *) + +let (inline_extraction,_) = + declare_object + {(default_object "Extraction Inline") with + cache_function = (fun (_,(b,l)) -> add_inline_entries b l); + load_function = (fun _ (_,(b,l)) -> add_inline_entries b l); + classify_function = (fun o -> Substitute o); + subst_function = + (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l))) + } + +let _ = declare_summary "Extraction Inline" + { freeze_function = (fun () -> !inline_table); + unfreeze_function = ((:=) inline_table); + init_function = (fun () -> inline_table := empty_inline_table) } + +(* Grammar entries. *) + +let extraction_inline b l = + check_inside_section (); + let refs = List.map Nametab.global l in + List.iter + (fun r -> match r with + | ConstRef _ -> () + | _ -> error_constant r) refs; + Lib.add_anonymous_leaf (inline_extraction (b,refs)) + +(* Printing part *) + +let print_extraction_inline () = + let (i,n)= !inline_table in + let i'= Refset.filter (function ConstRef _ -> true | _ -> false) i in + msg + (str "Extraction Inline:" ++ fnl () ++ + Refset.fold + (fun r p -> + (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) i' (mt ()) ++ + str "Extraction NoInline:" ++ fnl () ++ + Refset.fold + (fun r p -> + (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) n (mt ())) + +(* Reset part *) + +let (reset_inline,_) = + declare_object + {(default_object "Reset Extraction Inline") with + cache_function = (fun (_,_)-> inline_table := empty_inline_table); + load_function = (fun _ (_,_)-> inline_table := empty_inline_table)} + +let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) + +(*s Extraction Implicit *) + +type int_or_id = ArgInt of int | ArgId of identifier + +let implicits_table = ref Refmap.empty + +let implicits_of_global r = + try Refmap.find r !implicits_table with Not_found -> [] + +let add_implicits r l = + let typ = Global.type_of_global r in + let rels,_ = + decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in + let names = List.rev_map fst rels in + let n = List.length names in + let check = function + | ArgInt i -> + if 1 <= i && i <= n then i + else err (int i ++ str " is not a valid argument number for " ++ + safe_pr_global r) + | ArgId id -> + (try list_index (Name id) names + with Not_found -> + err (str "No argument " ++ pr_id id ++ str " for " ++ + safe_pr_global r)) + in + let l' = List.map check l in + implicits_table := Refmap.add r l' !implicits_table + +(* Registration of operations for rollback. *) + +let (implicit_extraction,_) = + declare_object + {(default_object "Extraction Implicit") with + cache_function = (fun (_,(r,l)) -> add_implicits r l); + load_function = (fun _ (_,(r,l)) -> add_implicits r l); + classify_function = (fun o -> Substitute o); + subst_function = (fun (s,(r,l)) -> (fst (subst_global s r), l)) + } + +let _ = declare_summary "Extraction Implicit" + { freeze_function = (fun () -> !implicits_table); + unfreeze_function = ((:=) implicits_table); + init_function = (fun () -> implicits_table := Refmap.empty) } + +(* Grammar entries. *) + +let extraction_implicit r l = + check_inside_section (); + Lib.add_anonymous_leaf (implicit_extraction (Nametab.global r,l)) + + +(*s Extraction Blacklist of filenames not to use while extracting *) + +let blacklist_table = ref Idset.empty + +let modfile_ids = ref [] +let modfile_mps = ref MPmap.empty + +let reset_modfile () = + modfile_ids := Idset.elements !blacklist_table; + modfile_mps := MPmap.empty + +let string_of_modfile mp = + try MPmap.find mp !modfile_mps + with Not_found -> + let id = id_of_string (raw_string_of_modfile mp) in + let id' = next_ident_away id !modfile_ids in + let s' = string_of_id id' in + modfile_ids := id' :: !modfile_ids; + modfile_mps := MPmap.add mp s' !modfile_mps; + s' + +(* same as [string_of_modfile], but preserves the capital/uncapital 1st char *) + +let file_of_modfile mp = + let s0 = match mp with + | MPfile f -> string_of_id (List.hd (repr_dirpath f)) + | _ -> assert false + in + let s = String.copy (string_of_modfile mp) in + if s.[0] <> s0.[0] then s.[0] <- s0.[0]; + s + +let add_blacklist_entries l = + blacklist_table := + List.fold_right (fun s -> Idset.add (id_of_string (String.capitalize s))) + l !blacklist_table + +(* Registration of operations for rollback. *) + +let (blacklist_extraction,_) = + declare_object + {(default_object "Extraction Blacklist") with + cache_function = (fun (_,l) -> add_blacklist_entries l); + load_function = (fun _ (_,l) -> add_blacklist_entries l); + classify_function = (fun o -> Libobject.Keep o); + subst_function = (fun (_,x) -> x) + } + +let _ = declare_summary "Extraction Blacklist" + { freeze_function = (fun () -> !blacklist_table); + unfreeze_function = ((:=) blacklist_table); + init_function = (fun () -> blacklist_table := Idset.empty) } + +(* Grammar entries. *) + +let extraction_blacklist l = + let l = List.rev_map string_of_id l in + Lib.add_anonymous_leaf (blacklist_extraction l) + +(* Printing part *) + +let print_extraction_blacklist () = + msgnl + (prlist_with_sep fnl pr_id (Idset.elements !blacklist_table)) + +(* Reset part *) + +let (reset_blacklist,_) = + declare_object + {(default_object "Reset Extraction Blacklist") with + cache_function = (fun (_,_)-> blacklist_table := Idset.empty); + load_function = (fun _ (_,_)-> blacklist_table := Idset.empty)} + +let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ()) + +(*s Extract Constant/Inductive. *) + +(* UGLY HACK: to be defined in [extraction.ml] *) +let use_type_scheme_nb_args, register_type_scheme_nb_args = + let r = ref (fun _ _ -> 0) in (fun x y -> !r x y), (:=) r + +let customs = ref Refmap.empty + +let add_custom r ids s = customs := Refmap.add r (ids,s) !customs + +let is_custom r = Refmap.mem r !customs + +let is_inline_custom r = (is_custom r) && (to_inline r) + +let find_custom r = snd (Refmap.find r !customs) + +let find_type_custom r = Refmap.find r !customs + +let custom_matchs = ref Refmap.empty + +let add_custom_match r s = + custom_matchs := Refmap.add r s !custom_matchs + +let indref_of_match pv = + if Array.length pv = 0 then raise Not_found; + match pv.(0) with + | (ConstructRef (ip,_), _, _) -> IndRef ip + | _ -> raise Not_found + +let is_custom_match pv = + try Refmap.mem (indref_of_match pv) !custom_matchs + with Not_found -> false + +let find_custom_match pv = + Refmap.find (indref_of_match pv) !custom_matchs + +(* Registration of operations for rollback. *) + +let (in_customs,_) = + declare_object + {(default_object "ML extractions") with + cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s); + load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s); + classify_function = (fun o -> Substitute o); + subst_function = + (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str)) + } + +let _ = declare_summary "ML extractions" + { freeze_function = (fun () -> !customs); + unfreeze_function = ((:=) customs); + init_function = (fun () -> customs := Refmap.empty) } + +let (in_custom_matchs,_) = + declare_object + {(default_object "ML extractions custom matchs") with + cache_function = (fun (_,(r,s)) -> add_custom_match r s); + load_function = (fun _ (_,(r,s)) -> add_custom_match r s); + classify_function = (fun o -> Substitute o); + subst_function = (fun (subs,(r,s)) -> (fst (subst_global subs r), s)) + } + +let _ = declare_summary "ML extractions custom match" + { freeze_function = (fun () -> !custom_matchs); + unfreeze_function = ((:=) custom_matchs); + init_function = (fun () -> custom_matchs := Refmap.empty) } + +(* Grammar entries. *) + +let extract_constant_inline inline r ids s = + check_inside_section (); + let g = Nametab.global r in + match g with + | ConstRef kn -> + let env = Global.env () in + let typ = Typeops.type_of_constant env kn in + let typ = Reduction.whd_betadeltaiota env typ in + if Reduction.is_arity env typ + then begin + let nargs = use_type_scheme_nb_args env typ in + if List.length ids <> nargs then error_axiom_scheme g nargs + end; + Lib.add_anonymous_leaf (inline_extraction (inline,[g])); + Lib.add_anonymous_leaf (in_customs (g,ids,s)) + | _ -> error_constant g + + +let extract_inductive r s l optstr = + check_inside_section (); + let g = Nametab.global r in + match g with + | IndRef ((kn,i) as ip) -> + let mib = Global.lookup_mind kn in + let n = Array.length mib.mind_packets.(i).mind_consnames in + if n <> List.length l then error_nb_cons (); + Lib.add_anonymous_leaf (inline_extraction (true,[g])); + Lib.add_anonymous_leaf (in_customs (g,[],s)); + Option.iter (fun s -> Lib.add_anonymous_leaf (in_custom_matchs (g,s))) + optstr; + list_iter_i + (fun j s -> + let g = ConstructRef (ip,succ j) in + Lib.add_anonymous_leaf (inline_extraction (true,[g])); + Lib.add_anonymous_leaf (in_customs (g,[],s))) l + | _ -> error_inductive g + + + +(*s Tables synchronization. *) + +let reset_tables () = + init_terms (); init_types (); init_inductives (); init_recursors (); + init_projs (); init_axioms (); reset_modfile () diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli new file mode 100644 index 00000000..ae46233d --- /dev/null +++ b/plugins/extraction/table.mli @@ -0,0 +1,167 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* identifier + +(*s Warning and Error messages. *) + +val warning_axioms : unit -> unit +val warning_both_mod_and_cst : + qualid -> module_path -> global_reference -> unit +val warning_id : string -> unit +val error_axiom_scheme : global_reference -> int -> 'a +val error_constant : global_reference -> 'a +val error_inductive : global_reference -> 'a +val error_nb_cons : unit -> 'a +val error_module_clash : module_path -> module_path -> 'a +val error_unknown_module : qualid -> 'a +val error_scheme : unit -> 'a +val error_not_visible : global_reference -> 'a +val error_MPfile_as_mod : module_path -> bool -> 'a +val error_record : global_reference -> 'a +val check_inside_module : unit -> unit +val check_inside_section : unit -> unit +val check_loaded_modfile : module_path -> unit +val msg_non_implicit : global_reference -> int -> name -> string +val error_non_implicit : string -> 'a + +val info_file : string -> unit + +(*s utilities about [module_path] and [kernel_names] and [global_reference] *) + +val occur_kn_in_ref : mutual_inductive -> global_reference -> bool +val repr_of_r : global_reference -> module_path * dir_path * label +val modpath_of_r : global_reference -> module_path +val label_of_r : global_reference -> label +val current_toplevel : unit -> module_path +val base_mp : module_path -> module_path +val is_modfile : module_path -> bool +val string_of_modfile : module_path -> string +val file_of_modfile : module_path -> string +val is_toplevel : module_path -> bool +val at_toplevel : module_path -> bool +val visible_con : constant -> bool +val mp_length : module_path -> int +val prefixes_mp : module_path -> MPset.t +val modfile_of_mp : module_path -> module_path +val common_prefix_from_list : + module_path -> module_path list -> module_path option +val add_labels_mp : module_path -> label list -> module_path +val get_nth_label_mp : int -> module_path -> label +val labels_of_ref : global_reference -> module_path * label list + +(*s Some table-related operations *) + +val add_term : constant -> ml_decl -> unit +val lookup_term : constant -> ml_decl + +val add_type : constant -> ml_schema -> unit +val lookup_type : constant -> ml_schema + +val add_ind : mutual_inductive -> mutual_inductive_body -> ml_ind -> unit +val lookup_ind : mutual_inductive -> mutual_inductive_body * ml_ind + +val add_recursors : Environ.env -> mutual_inductive -> unit +val is_recursor : global_reference -> bool + +val add_projection : int -> constant -> unit +val is_projection : global_reference -> bool +val projection_arity : global_reference -> int + +val add_info_axiom : global_reference -> unit +val remove_info_axiom : global_reference -> unit +val add_log_axiom : global_reference -> unit + +val reset_tables : unit -> unit + +(*s AutoInline parameter *) + +val auto_inline : unit -> bool + +(*s TypeExpand parameter *) + +val type_expand : unit -> bool + +(*s Optimize parameter *) + +type opt_flag = + { opt_kill_dum : bool; (* 1 *) + opt_fix_fun : bool; (* 2 *) + opt_case_iot : bool; (* 4 *) + opt_case_idr : bool; (* 8 *) + opt_case_idg : bool; (* 16 *) + opt_case_cst : bool; (* 32 *) + opt_case_fun : bool; (* 64 *) + opt_case_app : bool; (* 128 *) + opt_let_app : bool; (* 256 *) + opt_lin_let : bool; (* 512 *) + opt_lin_beta : bool } (* 1024 *) + +val optims : unit -> opt_flag + +(*s Target language. *) + +type lang = Ocaml | Haskell | Scheme +val lang : unit -> lang + +(*s Extraction mode: modular or monolithic *) + +val set_modular : bool -> unit +val modular : unit -> bool + +(*s Table for custom inlining *) + +val to_inline : global_reference -> bool +val to_keep : global_reference -> bool + +(*s Table for implicits arguments *) + +val implicits_of_global : global_reference -> int list + +(*s Table for user-given custom ML extractions. *) + +(* UGLY HACK: registration of a function defined in [extraction.ml] *) +val register_type_scheme_nb_args : (Environ.env -> Term.constr -> int) -> unit + +val is_custom : global_reference -> bool +val is_inline_custom : global_reference -> bool +val find_custom : global_reference -> string +val find_type_custom : global_reference -> string list * string + +val is_custom_match : ml_branch array -> bool +val find_custom_match : ml_branch array -> string + +(*s Extraction commands. *) + +val extraction_language : lang -> unit +val extraction_inline : bool -> reference list -> unit +val print_extraction_inline : unit -> unit +val reset_extraction_inline : unit -> unit +val extract_constant_inline : + bool -> reference -> string list -> string -> unit +val extract_inductive : + reference -> string -> string list -> string option -> unit + +type int_or_id = ArgInt of int | ArgId of identifier +val extraction_implicit : reference -> int_or_id list -> unit + +(*s Table of blacklisted filenames *) + +val extraction_blacklist : identifier list -> unit +val reset_extraction_blacklist : unit -> unit +val print_extraction_blacklist : unit -> unit + + + diff --git a/plugins/extraction/vo.itarget b/plugins/extraction/vo.itarget new file mode 100644 index 00000000..1fe09f6f --- /dev/null +++ b/plugins/extraction/vo.itarget @@ -0,0 +1,8 @@ +ExtrOcamlBasic.vo +ExtrOcamlIntConv.vo +ExtrOcamlBigIntConv.vo +ExtrOcamlNatInt.vo +ExtrOcamlNatBigInt.vo +ExtrOcamlZInt.vo +ExtrOcamlZBigInt.vo +ExtrOcamlString.vo \ No newline at end of file diff --git a/plugins/field/LegacyField.v b/plugins/field/LegacyField.v new file mode 100644 index 00000000..efa53b4e --- /dev/null +++ b/plugins/field/LegacyField.v @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* e2}) + (lst:list (prod A B)) {struct lst} : + B -> A -> A := + fun (key:B) (default:A) => + match lst with + | nil => default + | (v,e) :: l => + match eq_dec e key with + | left _ => v + | right _ => assoc_2nd_rec A B eq_dec l key default + end + end). + +Definition mem := + (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) + (a:A) (l:list A) {struct l} : bool := + match l with + | nil => false + | a1 :: l1 => + match eq_dec a a1 with + | left _ => true + | right _ => mem A eq_dec a l1 + end + end). diff --git a/plugins/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v new file mode 100644 index 00000000..5c1f228a --- /dev/null +++ b/plugins/field/LegacyField_Tactic.v @@ -0,0 +1,433 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ExprA ****) + +Ltac get_component a s := eval cbv beta iota delta [a] in (a s). + +Ltac body_of s := eval cbv beta iota delta [s] in s. + +Ltac mem_assoc var lvar := + match constr:lvar with + | nil => constr:false + | ?X1 :: ?X2 => + match constr:(X1 = var) with + | (?X1 = ?X1) => constr:true + | _ => mem_assoc var X2 + end + end. + +Ltac number lvar := + let rec number_aux lvar cpt := + match constr:lvar with + | (@nil ?X1) => constr:(@nil (prod X1 nat)) + | ?X2 :: ?X3 => + let l2 := number_aux X3 (S cpt) in + constr:((X2,cpt) :: l2) + end + in number_aux lvar 0. + +Ltac build_varlist FT trm := + let rec seek_var lvar trm := + let AT := get_component A FT + with AzeroT := get_component Azero FT + with AoneT := get_component Aone FT + with AplusT := get_component Aplus FT + with AmultT := get_component Amult FT + with AoppT := get_component Aopp FT + with AinvT := get_component Ainv FT in + match constr:trm with + | AzeroT => lvar + | AoneT => lvar + | (AplusT ?X1 ?X2) => + let l1 := seek_var lvar X1 in + seek_var l1 X2 + | (AmultT ?X1 ?X2) => + let l1 := seek_var lvar X1 in + seek_var l1 X2 + | (AoppT ?X1) => seek_var lvar X1 + | (AinvT ?X1) => seek_var lvar X1 + | ?X1 => + let res := mem_assoc X1 lvar in + match constr:res with + | true => lvar + | false => constr:(X1 :: lvar) + end + end in + let AT := get_component A FT in + let lvar := seek_var (@nil AT) trm in + number lvar. + +Ltac assoc elt lst := + match constr:lst with + | nil => fail + | (?X1,?X2) :: ?X3 => + match constr:(elt = X1) with + | (?X1 = ?X1) => constr:X2 + | _ => assoc elt X3 + end + end. + +Ltac interp_A FT lvar trm := + let AT := get_component A FT + with AzeroT := get_component Azero FT + with AoneT := get_component Aone FT + with AplusT := get_component Aplus FT + with AmultT := get_component Amult FT + with AoppT := get_component Aopp FT + with AinvT := get_component Ainv FT in + match constr:trm with + | AzeroT => constr:EAzero + | AoneT => constr:EAone + | (AplusT ?X1 ?X2) => + let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in + constr:(EAplus e1 e2) + | (AmultT ?X1 ?X2) => + let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in + constr:(EAmult e1 e2) + | (AoppT ?X1) => + let e := interp_A FT lvar X1 in + constr:(EAopp e) + | (AinvT ?X1) => let e := interp_A FT lvar X1 in + constr:(EAinv e) + | ?X1 => let idx := assoc X1 lvar in + constr:(EAvar idx) + end. + +(************************) +(* Simplification *) +(************************) + +(**** Generation of the multiplier ****) + +Ltac remove e l := + match constr:l with + | nil => l + | e :: ?X2 => constr:X2 + | ?X2 :: ?X3 => let nl := remove e X3 in constr:(X2 :: nl) + end. + +Ltac union l1 l2 := + match constr:l1 with + | nil => l2 + | ?X2 :: ?X3 => + let nl2 := remove X2 l2 in + let nl := union X3 nl2 in + constr:(X2 :: nl) + end. + +Ltac raw_give_mult trm := + match constr:trm with + | (EAinv ?X1) => constr:(X1 :: nil) + | (EAopp ?X1) => raw_give_mult X1 + | (EAplus ?X1 ?X2) => + let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in + union l1 l2 + | (EAmult ?X1 ?X2) => + let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in + eval compute in (app l1 l2) + | _ => constr:(@nil ExprA) + end. + +Ltac give_mult trm := + let ltrm := raw_give_mult trm in + constr:(mult_of_list ltrm). + +(**** Associativity ****) + +Ltac apply_assoc FT lvar trm := + let t := eval compute in (assoc trm) in + match constr:(t = trm) with + | (?X1 = ?X1) => idtac + | _ => + rewrite <- (assoc_correct FT trm); change (assoc trm) with t in |- * + end. + +(**** Distribution *****) + +Ltac apply_distrib FT lvar trm := + let t := eval compute in (distrib trm) in + match constr:(t = trm) with + | (?X1 = ?X1) => idtac + | _ => + rewrite <- (distrib_correct FT trm); + change (distrib trm) with t in |- * + end. + +(**** Multiplication by the inverse product ****) + +Ltac grep_mult := match goal with + | id:(interp_ExprA _ _ _ <> _) |- _ => id + end. + +Ltac weak_reduce := + match goal with + | |- context [(interp_ExprA ?X1 ?X2 _)] => + cbv beta iota zeta + delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list X1 X2 A Azero + Aone Aplus Amult Aopp Ainv] in |- * + end. + +Ltac multiply mul := + match goal with + | |- (interp_ExprA ?FT ?X2 ?X3 = interp_ExprA ?FT ?X2 ?X4) => + let AzeroT := get_component Azero FT in + cut (interp_ExprA FT X2 mul <> AzeroT); + [ intro; (let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id)) + | weak_reduce; + (let AoneT := get_component Aone ltac:(body_of FT) + with AmultT := get_component Amult ltac:(body_of FT) in + try + match goal with + | |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r FT) + end; clear FT X2) ] + end. + +Ltac apply_multiply FT lvar trm := + let t := eval compute in (multiply trm) in + match constr:(t = trm) with + | (?X1 = ?X1) => idtac + | _ => + rewrite <- (multiply_correct FT trm); + change (multiply trm) with t in |- * + end. + +(**** Permutations and simplification ****) + +Ltac apply_inverse mul FT lvar trm := + let t := eval compute in (inverse_simplif mul trm) in + match constr:(t = trm) with + | (?X1 = ?X1) => idtac + | _ => + rewrite <- (inverse_correct FT trm mul); + [ change (inverse_simplif mul trm) with t in |- * | assumption ] + end. +(**** Inverse test ****) + +Ltac strong_fail tac := first [ tac | fail 2 ]. + +Ltac inverse_test_aux FT trm := + let AplusT := get_component Aplus FT + with AmultT := get_component Amult FT + with AoppT := get_component Aopp FT + with AinvT := get_component Ainv FT in + match constr:trm with + | (AinvT _) => fail 1 + | (AoppT ?X1) => + strong_fail ltac:(inverse_test_aux FT X1; idtac) + | (AplusT ?X1 ?X2) => + strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2) + | (AmultT ?X1 ?X2) => + strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2) + | _ => idtac + end. + +Ltac inverse_test FT := + let AplusT := get_component Aplus FT in + match goal with + | |- (?X1 = ?X2) => inverse_test_aux FT (AplusT X1 X2) + end. + +(**** Field itself ****) + +Ltac apply_simplif sfun := + match goal with + | |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) => + sfun X1 X2 X3 + end; + match goal with + | |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) => + sfun X1 X2 X3 + end. + +Ltac unfolds FT := + match get_component Aminus FT with + | Some ?X1 => unfold X1 in |- * + | _ => idtac + end; + match get_component Adiv FT with + | Some ?X1 => unfold X1 in |- * + | _ => idtac + end. + +Ltac reduce FT := + let AzeroT := get_component Azero FT + with AoneT := get_component Aone FT + with AplusT := get_component Aplus FT + with AmultT := get_component Amult FT + with AoppT := get_component Aopp FT + with AinvT := get_component Ainv FT in + (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] in |- * || + compute in |- *). + +Ltac field_gen_aux FT := + let AplusT := get_component Aplus FT in + match goal with + | |- (?X1 = ?X2) => + let lvar := build_varlist FT (AplusT X1 X2) in + let trm1 := interp_A FT lvar X1 with trm2 := interp_A FT lvar X2 in + let mul := give_mult (EAplus trm1 trm2) in + cut + (let ft := FT in + let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2); + [ compute in |- *; auto + | intros ft vm; apply_simplif apply_distrib; + apply_simplif apply_assoc; multiply mul; + [ apply_simplif apply_multiply; + apply_simplif ltac:(apply_inverse mul); + (let id := grep_mult in + clear id; weak_reduce; clear ft vm; first + [ inverse_test FT; legacy ring | field_gen_aux FT ]) + | idtac ] ] + end. + +Ltac field_gen FT := + unfolds FT; (inverse_test FT; legacy ring) || field_gen_aux FT. + +(*****************************) +(* Term Simplification *) +(*****************************) + +(**** Minus and division expansions ****) + +Ltac init_exp FT trm := + let e := + (match get_component Aminus FT with + | Some ?X1 => eval cbv beta delta [X1] in trm + | _ => trm + end) in + match get_component Adiv FT with + | Some ?X1 => eval cbv beta delta [X1] in e + | _ => e + end. + +(**** Inverses simplification ****) + +Ltac simpl_inv trm := + match constr:trm with + | (EAplus ?X1 ?X2) => + let e1 := simpl_inv X1 with e2 := simpl_inv X2 in + constr:(EAplus e1 e2) + | (EAmult ?X1 ?X2) => + let e1 := simpl_inv X1 with e2 := simpl_inv X2 in + constr:(EAmult e1 e2) + | (EAopp ?X1) => let e := simpl_inv X1 in + constr:(EAopp e) + | (EAinv ?X1) => SimplInvAux X1 + | ?X1 => constr:X1 + end + with SimplInvAux trm := + match constr:trm with + | (EAinv ?X1) => simpl_inv X1 + | (EAmult ?X1 ?X2) => + let e1 := simpl_inv (EAinv X1) with e2 := simpl_inv (EAinv X2) in + constr:(EAmult e1 e2) + | ?X1 => let e := simpl_inv X1 in + constr:(EAinv e) + end. + +(**** Monom simplification ****) + +Ltac map_tactic fcn lst := + match constr:lst with + | nil => lst + | ?X2 :: ?X3 => + let r := fcn X2 with t := map_tactic fcn X3 in + constr:(r :: t) + end. + +Ltac build_monom_aux lst trm := + match constr:lst with + | nil => eval compute in (assoc trm) + | ?X1 :: ?X2 => build_monom_aux X2 (EAmult trm X1) + end. + +Ltac build_monom lnum lden := + let ildn := map_tactic ltac:(fun e => constr:(EAinv e)) lden in + let ltot := eval compute in (app lnum ildn) in + let trm := build_monom_aux ltot EAone in + match constr:trm with + | (EAmult _ ?X1) => constr:X1 + | ?X1 => constr:X1 + end. + +Ltac simpl_monom_aux lnum lden trm := + match constr:trm with + | (EAmult (EAinv ?X1) ?X2) => + let mma := mem_assoc X1 lnum in + match constr:mma with + | true => + let newlnum := remove X1 lnum in + simpl_monom_aux newlnum lden X2 + | false => simpl_monom_aux lnum (X1 :: lden) X2 + end + | (EAmult ?X1 ?X2) => + let mma := mem_assoc X1 lden in + match constr:mma with + | true => + let newlden := remove X1 lden in + simpl_monom_aux lnum newlden X2 + | false => simpl_monom_aux (X1 :: lnum) lden X2 + end + | (EAinv ?X1) => + let mma := mem_assoc X1 lnum in + match constr:mma with + | true => + let newlnum := remove X1 lnum in + build_monom newlnum lden + | false => build_monom lnum (X1 :: lden) + end + | ?X1 => + let mma := mem_assoc X1 lden in + match constr:mma with + | true => + let newlden := remove X1 lden in + build_monom lnum newlden + | false => build_monom (X1 :: lnum) lden + end + end. + +Ltac simpl_monom trm := simpl_monom_aux (@nil ExprA) (@nil ExprA) trm. + +Ltac simpl_all_monomials trm := + match constr:trm with + | (EAplus ?X1 ?X2) => + let e1 := simpl_monom X1 with e2 := simpl_all_monomials X2 in + constr:(EAplus e1 e2) + | ?X1 => simpl_monom X1 + end. + +(**** Associativity and distribution ****) + +Ltac assoc_distrib trm := eval compute in (assoc (distrib trm)). + +(**** The tactic Field_Term ****) + +Ltac eval_weak_reduce trm := + eval + cbv beta iota zeta + delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list A Azero Aone Aplus + Amult Aopp Ainv] in trm. + +Ltac field_term FT exp := + let newexp := init_exp FT exp in + let lvar := build_varlist FT newexp in + let trm := interp_A FT lvar newexp in + let tma := eval compute in (assoc trm) in + let tsmp := + simpl_all_monomials + ltac:(assoc_distrib ltac:(simpl_all_monomials ltac:(simpl_inv tma))) in + let trep := eval_weak_reduce (interp_ExprA FT lvar tsmp) in + (replace exp with trep; [ legacy ring trep | field_gen FT ]). diff --git a/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v new file mode 100644 index 00000000..cc8b043f --- /dev/null +++ b/plugins/field/LegacyField_Theory.v @@ -0,0 +1,650 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A -> A; + Amult : A -> A -> A; + Aone : A; + Azero : A; + Aopp : A -> A; + Aeq : A -> A -> bool; + Ainv : A -> A; + Aminus : option (A -> A -> A); + Adiv : option (A -> A -> A); + RT : Ring_Theory Aplus Amult Aone Azero Aopp Aeq; + Th_inv_def : forall n:A, n <> Azero -> Amult (Ainv n) n = Aone}. + +(* The reflexion structure *) +Inductive ExprA : Set := + | EAzero : ExprA + | EAone : ExprA + | EAplus : ExprA -> ExprA -> ExprA + | EAmult : ExprA -> ExprA -> ExprA + | EAopp : ExprA -> ExprA + | EAinv : ExprA -> ExprA + | EAvar : nat -> ExprA. + +(**** Decidability of equality ****) + +Lemma eqExprA_O : forall e1 e2:ExprA, {e1 = e2} + {e1 <> e2}. +Proof. + double induction e1 e2; try intros; + try (left; reflexivity) || (try (right; discriminate)). + elim (H1 e0); intro y; elim (H2 e); intro y0; + try + (left; rewrite y; rewrite y0; auto) || + (right; red in |- *; intro; inversion H3; auto). + elim (H1 e0); intro y; elim (H2 e); intro y0; + try + (left; rewrite y; rewrite y0; auto) || + (right; red in |- *; intro; inversion H3; auto). + elim (H0 e); intro y. + left; rewrite y; auto. + right; red in |- *; intro; inversion H1; auto. + elim (H0 e); intro y. + left; rewrite y; auto. + right; red in |- *; intro; inversion H1; auto. + elim (eq_nat_dec n n0); intro y. + left; rewrite y; auto. + right; red in |- *; intro; inversion H; auto. +Defined. + +Definition eq_nat_dec := Eval compute in eq_nat_dec. +Definition eqExprA := Eval compute in eqExprA_O. + +(**** Generation of the multiplier ****) + +Fixpoint mult_of_list (e:list ExprA) : ExprA := + match e with + | nil => EAone + | e1 :: l1 => EAmult e1 (mult_of_list l1) + end. + +Section Theory_of_fields. + +Variable T : Field_Theory. + +Let AT := A T. +Let AplusT := Aplus T. +Let AmultT := Amult T. +Let AoneT := Aone T. +Let AzeroT := Azero T. +Let AoppT := Aopp T. +Let AeqT := Aeq T. +Let AinvT := Ainv T. +Let RTT := RT T. +Let Th_inv_defT := Th_inv_def T. + +Add Legacy Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) ( + Azero T) (Aopp T) (Aeq T) (RT T). + +Add Legacy Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT. + +(***************************) +(* Lemmas to be used *) +(***************************) + +Lemma AplusT_comm : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1. +Proof. + intros; legacy ring. +Qed. + +Lemma AplusT_assoc : + forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3). +Proof. + intros; legacy ring. +Qed. + +Lemma AmultT_comm : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1. +Proof. + intros; legacy ring. +Qed. + +Lemma AmultT_assoc : + forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3). +Proof. + intros; legacy ring. +Qed. + +Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r. +Proof. + intros; legacy ring. +Qed. + +Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r. +Proof. + intros; legacy ring. +Qed. + +Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT. +Proof. + intros; legacy ring. +Qed. + +Lemma AmultT_AplusT_distr : + forall r1 r2 r3:AT, + AmultT r1 (AplusT r2 r3) = AplusT (AmultT r1 r2) (AmultT r1 r3). +Proof. + intros; legacy ring. +Qed. + +Lemma r_AplusT_plus : forall r r1 r2:AT, AplusT r r1 = AplusT r r2 -> r1 = r2. +Proof. + intros; transitivity (AplusT (AplusT (AoppT r) r) r1). + legacy ring. + transitivity (AplusT (AplusT (AoppT r) r) r2). + repeat rewrite AplusT_assoc; rewrite <- H; reflexivity. + legacy ring. +Qed. + +Lemma r_AmultT_mult : + forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2. +Proof. + intros; transitivity (AmultT (AmultT (AinvT r) r) r1). + rewrite Th_inv_defT; [ symmetry in |- *; apply AmultT_1l; auto | auto ]. + transitivity (AmultT (AmultT (AinvT r) r) r2). + repeat rewrite AmultT_assoc; rewrite H; trivial. + rewrite Th_inv_defT; [ apply AmultT_1l; auto | auto ]. +Qed. + +Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT. +Proof. + intro; legacy ring. +Qed. + +Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT. +Proof. + intro; legacy ring. +Qed. + +Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r. +Proof. + intro; legacy ring. +Qed. + +Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT. +Proof. + intros; rewrite AmultT_comm; apply Th_inv_defT; auto. +Qed. + +Lemma Rmult_neq_0_reg : + forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT. +Proof. + intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; legacy ring. +Qed. + +(************************) +(* Interpretation *) +(************************) + +(**** ExprA --> A ****) + +Fixpoint interp_ExprA (lvar:list (AT * nat)) (e:ExprA) {struct e} : + AT := + match e with + | EAzero => AzeroT + | EAone => AoneT + | EAplus e1 e2 => AplusT (interp_ExprA lvar e1) (interp_ExprA lvar e2) + | EAmult e1 e2 => AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2) + | EAopp e => Aopp T (interp_ExprA lvar e) + | EAinv e => Ainv T (interp_ExprA lvar e) + | EAvar n => assoc_2nd AT nat eq_nat_dec lvar n AzeroT + end. + +(************************) +(* Simplification *) +(************************) + +(**** Associativity ****) + +Definition merge_mult := + (fix merge_mult (e1:ExprA) : ExprA -> ExprA := + fun e2:ExprA => + match e1 with + | EAmult t1 t2 => + match t2 with + | EAmult t2 t3 => EAmult t1 (EAmult t2 (merge_mult t3 e2)) + | _ => EAmult t1 (EAmult t2 e2) + end + | _ => EAmult e1 e2 + end). + +Fixpoint assoc_mult (e:ExprA) : ExprA := + match e with + | EAmult e1 e3 => + match e1 with + | EAmult e1 e2 => + merge_mult (merge_mult (assoc_mult e1) (assoc_mult e2)) + (assoc_mult e3) + | _ => EAmult e1 (assoc_mult e3) + end + | _ => e + end. + +Definition merge_plus := + (fix merge_plus (e1:ExprA) : ExprA -> ExprA := + fun e2:ExprA => + match e1 with + | EAplus t1 t2 => + match t2 with + | EAplus t2 t3 => EAplus t1 (EAplus t2 (merge_plus t3 e2)) + | _ => EAplus t1 (EAplus t2 e2) + end + | _ => EAplus e1 e2 + end). + +Fixpoint assoc (e:ExprA) : ExprA := + match e with + | EAplus e1 e3 => + match e1 with + | EAplus e1 e2 => + merge_plus (merge_plus (assoc e1) (assoc e2)) (assoc e3) + | _ => EAplus (assoc_mult e1) (assoc e3) + end + | _ => assoc_mult e + end. + +Lemma merge_mult_correct1 : + forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar (merge_mult (EAmult e1 e2) e3) = + interp_ExprA lvar (EAmult e1 (merge_mult e2 e3)). +Proof. +intros e1 e2; generalize e1; generalize e2; clear e1 e2. +simple induction e2; auto; intros. +unfold merge_mult at 1 in |- *; fold merge_mult in |- *; + unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *; + rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *; + fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *; + fold interp_ExprA in |- *; auto. +Qed. + +Lemma merge_mult_correct : + forall (e1 e2:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2). +Proof. +simple induction e1; auto; intros. +elim e0; try (intros; simpl in |- *; legacy ring). +unfold interp_ExprA in H2; fold interp_ExprA in H2; + cut + (AmultT (interp_ExprA lvar e2) + (AmultT (interp_ExprA lvar e4) + (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e3))) = + AmultT + (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4)) + (interp_ExprA lvar e2)) (interp_ExprA lvar e3)). +intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1; + simpl in |- *; legacy ring. +legacy ring. +Qed. + +Lemma assoc_mult_correct1 : + forall (e1 e2:ExprA) (lvar:list (AT * nat)), + AmultT (interp_ExprA lvar (assoc_mult e1)) + (interp_ExprA lvar (assoc_mult e2)) = + interp_ExprA lvar (assoc_mult (EAmult e1 e2)). +Proof. +simple induction e1; auto; intros. +rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct; + simpl in |- *; rewrite merge_mult_correct; simpl in |- *; + auto. +Qed. + +Lemma assoc_mult_correct : + forall (e:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar (assoc_mult e) = interp_ExprA lvar e. +Proof. +simple induction e; auto; intros. +elim e0; intros. +intros; simpl in |- *; legacy ring. +simpl in |- *; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1))); + rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite merge_mult_correct; simpl in |- *; + rewrite merge_mult_correct; simpl in |- *; rewrite AmultT_assoc; + rewrite assoc_mult_correct1; rewrite H2; simpl in |- *; + rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1; + fold interp_ExprA in H1; rewrite (H0 lvar) in H1; + rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1)); + rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; + legacy ring. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite (H0 lvar); auto. +Qed. + +Lemma merge_plus_correct1 : + forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar (merge_plus (EAplus e1 e2) e3) = + interp_ExprA lvar (EAplus e1 (merge_plus e2 e3)). +Proof. +intros e1 e2; generalize e1; generalize e2; clear e1 e2. +simple induction e2; auto; intros. +unfold merge_plus at 1 in |- *; fold merge_plus in |- *; + unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *; + rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *; + fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *; + fold interp_ExprA in |- *; auto. +Qed. + +Lemma merge_plus_correct : + forall (e1 e2:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2). +Proof. +simple induction e1; auto; intros. +elim e0; try intros; try (simpl in |- *; legacy ring). +unfold interp_ExprA in H2; fold interp_ExprA in H2; + cut + (AplusT (interp_ExprA lvar e2) + (AplusT (interp_ExprA lvar e4) + (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e3))) = + AplusT + (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4)) + (interp_ExprA lvar e2)) (interp_ExprA lvar e3)). +intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1; + simpl in |- *; legacy ring. +legacy ring. +Qed. + +Lemma assoc_plus_correct : + forall (e1 e2:ExprA) (lvar:list (AT * nat)), + AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)) = + interp_ExprA lvar (assoc (EAplus e1 e2)). +Proof. +simple induction e1; auto; intros. +rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct; + simpl in |- *; rewrite merge_plus_correct; simpl in |- *; + auto. +Qed. + +Lemma assoc_correct : + forall (e:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar (assoc e) = interp_ExprA lvar e. +Proof. +simple induction e; auto; intros. +elim e0; intros. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite merge_plus_correct; simpl in |- *; + rewrite merge_plus_correct; simpl in |- *; rewrite AplusT_assoc; + rewrite assoc_plus_correct; rewrite H2; simpl in |- *; + apply + (r_AplusT_plus (interp_ExprA lvar (assoc e1)) + (AplusT (interp_ExprA lvar (assoc e2)) + (AplusT (interp_ExprA lvar e3) (interp_ExprA lvar e1))) + (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3)) + (interp_ExprA lvar e1))); rewrite <- AplusT_assoc; + rewrite + (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2))) + ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; + rewrite (H0 lvar); + rewrite <- + (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1)) + (interp_ExprA lvar e3) (interp_ExprA lvar e1)) + ; + rewrite + (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1) + (interp_ExprA lvar e3)); + rewrite (AplusT_comm (interp_ExprA lvar e1) (interp_ExprA lvar e3)); + rewrite <- + (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3) + (interp_ExprA lvar e1)); apply AplusT_comm. +unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; + fold interp_ExprA in |- *; rewrite assoc_mult_correct; + rewrite (H0 lvar); simpl in |- *; auto. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite (H0 lvar); auto. +unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; + fold interp_ExprA in |- *; rewrite assoc_mult_correct; + simpl in |- *; auto. +Qed. + +(**** Distribution *****) + +Fixpoint distrib_EAopp (e:ExprA) : ExprA := + match e with + | EAplus e1 e2 => EAplus (distrib_EAopp e1) (distrib_EAopp e2) + | EAmult e1 e2 => EAmult (distrib_EAopp e1) (distrib_EAopp e2) + | EAopp e => EAmult (EAopp EAone) (distrib_EAopp e) + | e => e + end. + +Definition distrib_mult_right := + (fix distrib_mult_right (e1:ExprA) : ExprA -> ExprA := + fun e2:ExprA => + match e1 with + | EAplus t1 t2 => + EAplus (distrib_mult_right t1 e2) (distrib_mult_right t2 e2) + | _ => EAmult e1 e2 + end). + +Fixpoint distrib_mult_left (e1 e2:ExprA) {struct e1} : ExprA := + match e1 with + | EAplus t1 t2 => + EAplus (distrib_mult_left t1 e2) (distrib_mult_left t2 e2) + | _ => distrib_mult_right e2 e1 + end. + +Fixpoint distrib_main (e:ExprA) : ExprA := + match e with + | EAmult e1 e2 => distrib_mult_left (distrib_main e1) (distrib_main e2) + | EAplus e1 e2 => EAplus (distrib_main e1) (distrib_main e2) + | EAopp e => EAopp (distrib_main e) + | _ => e + end. + +Definition distrib (e:ExprA) : ExprA := distrib_main (distrib_EAopp e). + +Lemma distrib_mult_right_correct : + forall (e1 e2:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar (distrib_mult_right e1 e2) = + AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). +Proof. +simple induction e1; try intros; simpl in |- *; auto. +rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar); + rewrite (H0 e2 lvar); legacy ring. +Qed. + +Lemma distrib_mult_left_correct : + forall (e1 e2:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar (distrib_mult_left e1 e2) = + AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). +Proof. +simple induction e1; try intros; simpl in |- *. +rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *; + apply AmultT_Or. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +rewrite AmultT_comm; + rewrite + (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e) + (interp_ExprA lvar e0)); + rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e)); + rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0)); + rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +Qed. + +Lemma distrib_correct : + forall (e:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar (distrib e) = interp_ExprA lvar e. +Proof. +simple induction e; intros; auto. +simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar); + unfold distrib in |- *; simpl in |- *; auto. +simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar); + unfold distrib in |- *; simpl in |- *; apply distrib_mult_left_correct. +simpl in |- *; fold AoppT in |- *; rewrite <- (H lvar); + unfold distrib in |- *; simpl in |- *; rewrite distrib_mult_right_correct; + simpl in |- *; fold AoppT in |- *; legacy ring. +Qed. + +(**** Multiplication by the inverse product ****) + +Lemma mult_eq : + forall (e1 e2 a:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar a <> AzeroT -> + interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) -> + interp_ExprA lvar e1 = interp_ExprA lvar e2. +Proof. + simpl in |- *; intros; + apply + (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1) + (interp_ExprA lvar e2)); assumption. +Qed. + +Fixpoint multiply_aux (a e:ExprA) {struct e} : ExprA := + match e with + | EAplus e1 e2 => EAplus (EAmult a e1) (multiply_aux a e2) + | _ => EAmult a e + end. + +Definition multiply (e:ExprA) : ExprA := + match e with + | EAmult a e1 => multiply_aux a e1 + | _ => e + end. + +Lemma multiply_aux_correct : + forall (a e:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar (multiply_aux a e) = + AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). +Proof. +simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct; + auto. + simpl in |- *; rewrite (H0 lvar); legacy ring. +Qed. + +Lemma multiply_correct : + forall (e:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar (multiply e) = interp_ExprA lvar e. +Proof. + simple induction e; simpl in |- *; auto. + intros; apply multiply_aux_correct. +Qed. + +(**** Permutations and simplification ****) + +Fixpoint monom_remove (a m:ExprA) {struct m} : ExprA := + match m with + | EAmult m0 m1 => + match eqExprA m0 (EAinv a) with + | left _ => m1 + | right _ => EAmult m0 (monom_remove a m1) + end + | _ => + match eqExprA m (EAinv a) with + | left _ => EAone + | right _ => EAmult a m + end + end. + +Definition monom_simplif_rem := + (fix monom_simplif_rem (a:ExprA) : ExprA -> ExprA := + fun m:ExprA => + match a with + | EAmult a0 a1 => monom_simplif_rem a1 (monom_remove a0 m) + | _ => monom_remove a m + end). + +Definition monom_simplif (a m:ExprA) : ExprA := + match m with + | EAmult a' m' => + match eqExprA a a' with + | left _ => monom_simplif_rem a m' + | right _ => m + end + | _ => m + end. + +Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA := + match e with + | EAplus e1 e2 => EAplus (monom_simplif a e1) (inverse_simplif a e2) + | _ => monom_simplif a e + end. + +Lemma monom_remove_correct : + forall (e a:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar a <> AzeroT -> + interp_ExprA lvar (monom_remove a e) = + AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). +Proof. +simple induction e; intros. +simpl in |- *; case (eqExprA EAzero (EAinv a)); intros; + [ inversion e0 | simpl in |- *; trivial ]. +simpl in |- *; case (eqExprA EAone (EAinv a)); intros; + [ inversion e0 | simpl in |- *; trivial ]. +simpl in |- *; case (eqExprA (EAplus e0 e1) (EAinv a)); intros; + [ inversion e2 | simpl in |- *; trivial ]. +simpl in |- *; case (eqExprA e0 (EAinv a)); intros. +rewrite e2; simpl in |- *; fold AinvT in |- *. +rewrite <- + (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a)) + (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ]. +simpl in |- *; rewrite H0; auto; legacy ring. +simpl in |- *; fold AoppT in |- *; case (eqExprA (EAopp e0) (EAinv a)); + intros; [ inversion e1 | simpl in |- *; trivial ]. +unfold monom_remove in |- *; case (eqExprA (EAinv e0) (EAinv a)); intros. +case (eqExprA e0 a); intros. +rewrite e2; simpl in |- *; fold AinvT in |- *; rewrite AinvT_r; auto. +inversion e1; simpl in |- *; exfalso; auto. +simpl in |- *; trivial. +unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros; + [ inversion e0 | simpl in |- *; trivial ]. +Qed. + +Lemma monom_simplif_rem_correct : + forall (a e:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar a <> AzeroT -> + interp_ExprA lvar (monom_simplif_rem a e) = + AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). +Proof. +simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct; + auto. +elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1); + intros. +rewrite (H0 (monom_remove e e1) lvar H3); rewrite monom_remove_correct; auto. +legacy ring. +Qed. + +Lemma monom_simplif_correct : + forall (e a:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar a <> AzeroT -> + interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e. +Proof. +simple induction e; intros; auto. +simpl in |- *; case (eqExprA a e0); intros. +rewrite <- e2; apply monom_simplif_rem_correct; auto. +simpl in |- *; trivial. +Qed. + +Lemma inverse_correct : + forall (e a:ExprA) (lvar:list (AT * nat)), + interp_ExprA lvar a <> AzeroT -> + interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e. +Proof. +simple induction e; intros; auto. +simpl in |- *; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto. +unfold inverse_simplif in |- *; rewrite monom_simplif_correct; auto. +Qed. + +End Theory_of_fields. + +(* Compatibility *) +Notation AplusT_sym := AplusT_comm (only parsing). +Notation AmultT_sym := AmultT_comm (only parsing). diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4 new file mode 100644 index 00000000..238b4c1e --- /dev/null +++ b/plugins/field/field.ml4 @@ -0,0 +1,191 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mkApp (init_constant "None",[|ac3|]) + | Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|]) + +(* Table of theories *) +let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t) + +let lookup env typ = + try Gmap.find typ !th_tab + with Not_found -> + errorlabstrm "field" + (str "No field is declared for type" ++ spc() ++ + Printer.pr_lconstr_env env typ) + +let _ = + let init () = th_tab := Gmap.empty in + let freeze () = !th_tab in + let unfreeze fs = th_tab := fs in + Summary.declare_summary "field" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init } + +let load_addfield _ = () +let cache_addfield (_,(typ,th)) = th_tab := Gmap.add typ th !th_tab +let subst_addfield (subst,(typ,th as obj)) = + let typ' = subst_mps subst typ in + let th' = subst_mps subst th in + if typ' == typ && th' == th then obj else + (typ',th') + +(* Declaration of the Add Field library object *) +let (in_addfield,out_addfield)= + Libobject.declare_object {(Libobject.default_object "ADD_FIELD") with + Libobject.open_function = (fun i o -> if i=1 then cache_addfield o); + Libobject.cache_function = cache_addfield; + Libobject.subst_function = subst_addfield; + Libobject.classify_function = (fun a -> Libobject.Substitute a)} + +(* Adds a theory to the table *) +let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth + ainv_l = + begin + (try + Ring.add_theory true true false a None None None aplus amult aone azero + (Some aopp) aeq rth Quote.ConstrSet.empty + with | UserError("Add Semi Ring",_) -> ()); + let th = mkApp ((constant ["LegacyField_Theory"] "Build_Field_Theory"), + [|a;aplus;amult;aone;azero;aopp;aeq;ainv;aminus_o;adiv_o;rth;ainv_l|]) in + begin + let _ = type_of (Global.env ()) Evd.empty th in (); + Lib.add_anonymous_leaf (in_addfield (a,th)) + end + end + +(* Vernac command declaration *) +open Extend +open Pcoq +open Genarg + +VERNAC ARGUMENT EXTEND divarg +| [ "div" ":=" constr(adiv) ] -> [ adiv ] +END + +VERNAC ARGUMENT EXTEND minusarg +| [ "minus" ":=" constr(aminus) ] -> [ aminus ] +END + +(* +(* The v7->v8 translator needs printers, then temporary use ARGUMENT EXTEND...*) +VERNAC ARGUMENT EXTEND minus_div_arg +| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ] +| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ] +| [ ] -> [ None, None ] +END +*) + +(* For the translator, otherwise the code above is OK *) +open Ppconstr +let pp_minus_div_arg _prc _prlc _prt (omin,odiv) = + if omin=None && odiv=None then mt() else + spc() ++ str "with" ++ + pr_opt (fun c -> str "minus := " ++ _prc c) omin ++ + pr_opt (fun c -> str "div := " ++ _prc c) odiv +(* +let () = + Pptactic.declare_extra_genarg_pprule true + (rawwit_minus_div_arg,pp_minus_div_arg) + (globwit_minus_div_arg,pp_minus_div_arg) + (wit_minus_div_arg,pp_minus_div_arg) +*) +ARGUMENT EXTEND minus_div_arg + TYPED AS constr_opt * constr_opt + PRINTED BY pp_minus_div_arg +| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ] +| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ] +| [ ] -> [ None, None ] +END + +VERNAC COMMAND EXTEND Field + [ "Add" "Legacy" "Field" + constr(a) constr(aplus) constr(amult) constr(aone) + constr(azero) constr(aopp) constr(aeq) + constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ] + -> [ let (aminus_o, adiv_o) = md in + add_field + (constr_of a) (constr_of aplus) (constr_of amult) + (constr_of aone) (constr_of azero) (constr_of aopp) + (constr_of aeq) (constr_of ainv) (constr_of_opt a aminus_o) + (constr_of_opt a adiv_o) (constr_of rth) (constr_of ainv_l) ] +END + +(* Guesses the type and calls field_gen with the right theory *) +let field g = + Coqlib.check_required_library ["Coq";"field";"LegacyField"]; + let typ = + try match Hipattern.match_with_equation (pf_concl g) with + | _,_,Hipattern.PolymorphicLeibnizEq (t,_,_) -> t + | _ -> raise Exit + with Hipattern.NoEquationFound | Exit -> + error "The statement is not built from Leibniz' equality" in + let th = VConstr ([],lookup (pf_env g) typ) in + (interp_tac_gen [(id_of_string "FT",th)] [] (get_debug ()) + <:tactic< match goal with |- (@eq _ _ _) => field_gen FT end >>) g + +(* Verifies that all the terms have the same type and gives the right theory *) +let guess_theory env evc = function + | c::tl -> + let t = type_of env evc c in + if List.exists (fun c1 -> + not (Reductionops.is_conv env evc t (type_of env evc c1))) tl then + errorlabstrm "Field:" (str" All the terms must have the same type") + else + lookup env t + | [] -> anomaly "Field: must have a non-empty constr list here" + +(* Guesses the type and calls Field_Term with the right theory *) +let field_term l g = + Coqlib.check_required_library ["Coq";"field";"LegacyField"]; + let env = (pf_env g) + and evc = (project g) in + let th = valueIn (VConstr ([],guess_theory env evc l)) + and nl = List.map (fun x -> valueIn (VConstr ([],x))) (Quote.sort_subterm g l) in + (List.fold_right + (fun c a -> + let tac = (Tacinterp.interp <:tactic<(Field_Term $th $c)>>) in + Tacticals.tclTHENFIRSTn tac [|a|]) nl Tacticals.tclIDTAC) g + +(* Declaration of Field *) + +TACTIC EXTEND legacy_field +| [ "legacy" "field" ] -> [ field ] +| [ "legacy" "field" ne_constr_list(l) ] -> [ field_term l ] +END diff --git a/plugins/field/field_plugin.mllib b/plugins/field/field_plugin.mllib new file mode 100644 index 00000000..3c3e87af --- /dev/null +++ b/plugins/field/field_plugin.mllib @@ -0,0 +1,2 @@ +Field +Field_plugin_mod diff --git a/plugins/field/vo.itarget b/plugins/field/vo.itarget new file mode 100644 index 00000000..22b56f33 --- /dev/null +++ b/plugins/field/vo.itarget @@ -0,0 +1,4 @@ +LegacyField_Compl.vo +LegacyField_Tactic.vo +LegacyField_Theory.vo +LegacyField.vo diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml new file mode 100644 index 00000000..45365cb2 --- /dev/null +++ b/plugins/firstorder/formula.ml @@ -0,0 +1,270 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* metavariable + +exception Is_atom of constr + +let meta_succ m = m+1 + +let rec nb_prod_after n c= + match kind_of_term c with + | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else + 1+(nb_prod_after 0 b) + | _ -> 0 + +let construct_nhyps ind gls = + let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in + let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in + let hyp = nb_prod_after nparams in + Array.map hyp constr_types + +(* indhyps builds the array of arrays of constructor hyps for (ind largs)*) +let ind_hyps nevar ind largs gls= + let types= Inductiveops.arities_of_constructors (pf_env gls) ind in + let lp=Array.length types in + let myhyps i= + let t1=Term.prod_applist types.(i) largs in + let t2=snd (decompose_prod_n_assum nevar t1) in + fst (decompose_prod_assum t2) in + Array.init lp myhyps + +let special_nf gl= + let infos=Closure.create_clos_infos !red_flags (pf_env gl) in + (fun t -> Closure.norm_val infos (Closure.inject t)) + +let special_whd gl= + let infos=Closure.create_clos_infos !red_flags (pf_env gl) in + (fun t -> Closure.whd_val infos (Closure.inject t)) + +type kind_of_formula= + Arrow of constr*constr + | False of inductive*constr list + | And of inductive*constr list*bool + | Or of inductive*constr list*bool + | Exists of inductive*constr list + | Forall of constr*constr + | Atom of constr + +let rec kind_of_formula gl term = + let normalize=special_nf gl in + let cciterm=special_whd gl term in + match match_with_imp_term cciterm with + Some (a,b)-> Arrow(a,(pop b)) + |_-> + match match_with_forall_term cciterm with + Some (_,a,b)-> Forall(a,b) + |_-> + match match_with_nodep_ind cciterm with + Some (i,l,n)-> + let ind=destInd i in + let (mib,mip) = Global.lookup_inductive ind in + let nconstr=Array.length mip.mind_consnames in + if nconstr=0 then + False(ind,l) + else + let has_realargs=(n>0) in + let is_trivial= + let is_constant c = + nb_prod c = mib.mind_nparams in + array_exists is_constant mip.mind_nf_lc in + if Inductiveops.mis_is_recursive (ind,mib,mip) || + (has_realargs && not is_trivial) + then + Atom cciterm + else + if nconstr=1 then + And(ind,l,is_trivial) + else + Or(ind,l,is_trivial) + | _ -> + match match_with_sigma_type cciterm with + Some (i,l)-> Exists((destInd i),l) + |_-> Atom (normalize cciterm) + +type atoms = {positive:constr list;negative:constr list} + +type side = Hyp | Concl | Hint + +let no_atoms = (false,{positive=[];negative=[]}) + +let dummy_id=VarRef (id_of_string "_") (* "_" cannot be parsed *) + +let build_atoms gl metagen side cciterm = + let trivial =ref false + and positive=ref [] + and negative=ref [] in + let normalize=special_nf gl in + let rec build_rec env polarity cciterm= + match kind_of_formula gl cciterm with + False(_,_)->if not polarity then trivial:=true + | Arrow (a,b)-> + build_rec env (not polarity) a; + build_rec env polarity b + | And(i,l,b) | Or(i,l,b)-> + if b then + begin + let unsigned=normalize (substnl env 0 cciterm) in + if polarity then + positive:= unsigned :: !positive + else + negative:= unsigned :: !negative + end; + let v = ind_hyps 0 i l gl in + let g i _ (_,_,t) = + build_rec env polarity (lift i t) in + let f l = + list_fold_left_i g (1-(List.length l)) () l in + if polarity && (* we have a constant constructor *) + array_exists (function []->true|_->false) v + then trivial:=true; + Array.iter f v + | Exists(i,l)-> + let var=mkMeta (metagen true) in + let v =(ind_hyps 1 i l gl).(0) in + let g i _ (_,_,t) = + build_rec (var::env) polarity (lift i t) in + list_fold_left_i g (2-(List.length l)) () v + | Forall(_,b)-> + let var=mkMeta (metagen true) in + build_rec (var::env) polarity b + | Atom t-> + let unsigned=substnl env 0 t in + if not (isMeta unsigned) then (* discarding wildcard atoms *) + if polarity then + positive:= unsigned :: !positive + else + negative:= unsigned :: !negative in + begin + match side with + Concl -> build_rec [] true cciterm + | Hyp -> build_rec [] false cciterm + | Hint -> + let rels,head=decompose_prod cciterm in + let env=List.rev (List.map (fun _->mkMeta (metagen true)) rels) in + build_rec env false head;trivial:=false (* special for hints *) + end; + (!trivial, + {positive= !positive; + negative= !negative}) + +type right_pattern = + Rarrow + | Rand + | Ror + | Rfalse + | Rforall + | Rexists of metavariable*constr*bool + +type left_arrow_pattern= + LLatom + | LLfalse of inductive*constr list + | LLand of inductive*constr list + | LLor of inductive*constr list + | LLforall of constr + | LLexists of inductive*constr list + | LLarrow of constr*constr*constr + +type left_pattern= + Lfalse + | Land of inductive + | Lor of inductive + | Lforall of metavariable*constr*bool + | Lexists of inductive + | LA of constr*left_arrow_pattern + +type t={id:global_reference; + constr:constr; + pat:(left_pattern,right_pattern) sum; + atoms:atoms} + +let build_formula side nam typ gl metagen= + let normalize = special_nf gl in + try + let m=meta_succ(metagen false) in + let trivial,atoms= + if !qflag then + build_atoms gl metagen side typ + else no_atoms in + let pattern= + match side with + Concl -> + let pat= + match kind_of_formula gl typ with + False(_,_) -> Rfalse + | Atom a -> raise (Is_atom a) + | And(_,_,_) -> Rand + | Or(_,_,_) -> Ror + | Exists (i,l) -> + let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in + Rexists(m,d,trivial) + | Forall (_,a) -> Rforall + | Arrow (a,b) -> Rarrow in + Right pat + | _ -> + let pat= + match kind_of_formula gl typ with + False(i,_) -> Lfalse + | Atom a -> raise (Is_atom a) + | And(i,_,b) -> + if b then + let nftyp=normalize typ in raise (Is_atom nftyp) + else Land i + | Or(i,_,b) -> + if b then + let nftyp=normalize typ in raise (Is_atom nftyp) + else Lor i + | Exists (ind,_) -> Lexists ind + | Forall (d,_) -> + Lforall(m,d,trivial) + | Arrow (a,b) -> + let nfa=normalize a in + LA (nfa, + match kind_of_formula gl a with + False(i,l)-> LLfalse(i,l) + | Atom t-> LLatom + | And(i,l,_)-> LLand(i,l) + | Or(i,l,_)-> LLor(i,l) + | Arrow(a,c)-> LLarrow(a,c,b) + | Exists(i,l)->LLexists(i,l) + | Forall(_,_)->LLforall a) in + Left pat + in + Left {id=nam; + constr=normalize typ; + pat=pattern; + atoms=atoms} + with Is_atom a-> Right a (* already in nf *) + diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli new file mode 100644 index 00000000..2e89ddb0 --- /dev/null +++ b/plugins/firstorder/formula.mli @@ -0,0 +1,77 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a -> int) -> ('b -> 'b -> int) -> + 'a -> 'a -> 'b -> 'b -> int + +val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) -> + 'a -> 'a -> 'b -> 'b -> 'c ->'c -> int + +type ('a,'b) sum = Left of 'a | Right of 'b + +type counter = bool -> metavariable + +val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array + +val ind_hyps : int -> inductive -> constr list -> + Proof_type.goal Tacmach.sigma -> rel_context array + +type atoms = {positive:constr list;negative:constr list} + +type side = Hyp | Concl | Hint + +val dummy_id: global_reference + +val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> + side -> constr -> bool * atoms + +type right_pattern = + Rarrow + | Rand + | Ror + | Rfalse + | Rforall + | Rexists of metavariable*constr*bool + +type left_arrow_pattern= + LLatom + | LLfalse of inductive*constr list + | LLand of inductive*constr list + | LLor of inductive*constr list + | LLforall of constr + | LLexists of inductive*constr list + | LLarrow of constr*constr*constr + +type left_pattern= + Lfalse + | Land of inductive + | Lor of inductive + | Lforall of metavariable*constr*bool + | Lexists of inductive + | LA of constr*left_arrow_pattern + +type t={id: global_reference; + constr: constr; + pat: (left_pattern,right_pattern) sum; + atoms: atoms} + +(*exception Is_atom of constr*) + +val build_formula : side -> global_reference -> types -> + Proof_type.goal Tacmach.sigma -> counter -> (t,types) sum + diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 new file mode 100644 index 00000000..9080e7db --- /dev/null +++ b/plugins/firstorder/g_ground.ml4 @@ -0,0 +1,148 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Some !ground_depth); + optwrite= + (function + None->ground_depth:=3 + | Some i->ground_depth:=(max i 0))} + in + declare_int_option gdopt + +let congruence_depth=ref 100 + +let _= + let gdopt= + { optsync=true; + optname="Congruence Depth"; + optkey=["Congruence";"Depth"]; + optread=(fun ()->Some !congruence_depth); + optwrite= + (function + None->congruence_depth:=0 + | Some i->congruence_depth:=(max i 0))} + in + declare_int_option gdopt + +let default_solver=(Tacinterp.interp <:tactic>) + +let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") + +let gen_ground_tac flag taco ids bases gl= + let backup= !qflag in + try + qflag:=flag; + let solver= + match taco with + Some tac-> tac + | None-> default_solver in + let startseq gl= + let seq=empty_seq !ground_depth in + extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in + let result=ground_tac solver startseq gl in + qflag:=backup;result + with e ->qflag:=backup;raise e + +(* special for compatibility with Intuition + +let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str + +let defined_connectives=lazy + [[],EvalConstRef (destConst (constant "not")); + [],EvalConstRef (destConst (constant "iff"))] + +let normalize_evaluables= + onAllHypsAndConcl + (function + None->unfold_in_concl (Lazy.force defined_connectives) + | Some id-> + unfold_in_hyp (Lazy.force defined_connectives) + (Tacexpr.InHypType id)) *) + +open Genarg +open Ppconstr +open Printer +let pr_firstorder_using_raw _ _ _ = prlist_with_sep pr_comma pr_reference +let pr_firstorder_using_glob _ _ _ = prlist_with_sep pr_comma (pr_or_var (pr_located pr_global)) +let pr_firstorder_using_typed _ _ _ = prlist_with_sep pr_comma pr_global + +ARGUMENT EXTEND firstorder_using + TYPED AS reference_list + PRINTED BY pr_firstorder_using_typed + RAW_TYPED AS reference_list + RAW_PRINTED BY pr_firstorder_using_raw + GLOB_TYPED AS reference_list + GLOB_PRINTED BY pr_firstorder_using_glob +| [ "using" reference(a) ] -> [ [a] ] +| [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> [ a::l ] +| [ "using" reference(a) reference(b) reference_list(l) ] -> [ + Flags.if_verbose + Pp.msg_warning (Pp.str "Deprecated syntax; use \",\" as separator"); + a::b::l + ] +| [ ] -> [ [] ] +END + +TACTIC EXTEND firstorder + [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> + [ gen_ground_tac true (Option.map eval_tactic t) l [] ] +| [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> + [ gen_ground_tac true (Option.map eval_tactic t) [] l ] +| [ "firstorder" tactic_opt(t) firstorder_using(l) + "with" ne_preident_list(l') ] -> + [ gen_ground_tac true (Option.map eval_tactic t) l l' ] +| [ "firstorder" tactic_opt(t) ] -> + [ gen_ground_tac true (Option.map eval_tactic t) [] [] ] +END + +TACTIC EXTEND gintuition + [ "gintuition" tactic_opt(t) ] -> + [ gen_ground_tac false (Option.map eval_tactic t) [] [] ] +END + + +let default_declarative_automation gls = + tclORELSE + (tclORELSE (Auto.h_trivial [] None) + (Cctac.congruence_tac !congruence_depth [])) + (gen_ground_tac true + (Some (tclTHEN + default_solver + (Cctac.congruence_tac !congruence_depth []))) + [] []) gls + + + +let () = + Decl_proof_instr.register_automation_tac default_declarative_automation + diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml new file mode 100644 index 00000000..8a0f02d2 --- /dev/null +++ b/plugins/firstorder/ground.ml @@ -0,0 +1,152 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + predref:=Names.KNpred.add kn !predref + | _ ->() in + let g _ l=List.iter f l in + let h _ hdb=Auto.Hint_db.iter g hdb in + Util.Stringmap.iter h !Auto.searchtable; + red_flags:= + Closure.RedFlags.red_add_transparent + Closure.betaiotazeta (Names.Idpred.full,!predref) + end +*) + +let update_flags ()= + let predref=ref Names.Cpred.empty in + let f coe= + try + let kn=destConst (Classops.get_coercion_value coe) in + predref:=Names.Cpred.add kn !predref + with Invalid_argument "destConst"-> () in + List.iter f (Classops.coercions ()); + red_flags:= + Closure.RedFlags.red_add_transparent + Closure.betaiotazeta + (Names.Idpred.full,Names.Cpred.complement !predref) + +let ground_tac solver startseq gl= + update_flags (); + let rec toptac skipped seq gl= + if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 + then Pp.msgnl (Printer.pr_goal (sig_it gl)); + tclORELSE (axiom_tac seq.gl seq) + begin + try + let (hd,seq1)=take_formula seq + and re_add s=re_add_formula_list skipped s in + let continue=toptac [] + and backtrack gl=toptac (hd::skipped) seq1 gl in + match hd.pat with + Right rpat-> + begin + match rpat with + Rand-> + and_tac backtrack continue (re_add seq1) + | Rforall-> + let backtrack1= + if !qflag then + tclFAIL 0 (Pp.str "reversible in 1st order mode") + else + backtrack in + forall_tac backtrack1 continue (re_add seq1) + | Rarrow-> + arrow_tac backtrack continue (re_add seq1) + | Ror-> + or_tac backtrack continue (re_add seq1) + | Rfalse->backtrack + | Rexists(i,dom,triv)-> + let (lfp,seq2)=collect_quantified seq in + let backtrack2=toptac (lfp@skipped) seq2 in + if !qflag && seq.depth>0 then + quantified_tac lfp backtrack2 + continue (re_add seq) + else + backtrack2 (* need special backtracking *) + end + | Left lpat-> + begin + match lpat with + Lfalse-> + left_false_tac hd.id + | Land ind-> + left_and_tac ind backtrack + hd.id continue (re_add seq1) + | Lor ind-> + left_or_tac ind backtrack + hd.id continue (re_add seq1) + | Lforall (_,_,_)-> + let (lfp,seq2)=collect_quantified seq in + let backtrack2=toptac (lfp@skipped) seq2 in + if !qflag && seq.depth>0 then + quantified_tac lfp backtrack2 + continue (re_add seq) + else + backtrack2 (* need special backtracking *) + | Lexists ind -> + if !qflag then + left_exists_tac ind backtrack hd.id + continue (re_add seq1) + else backtrack + | LA (typ,lap)-> + let la_tac= + begin + match lap with + LLatom -> backtrack + | LLand (ind,largs) | LLor(ind,largs) + | LLfalse (ind,largs)-> + (ll_ind_tac ind largs backtrack + hd.id continue (re_add seq1)) + | LLforall p -> + if seq.depth>0 && !qflag then + (ll_forall_tac p backtrack + hd.id continue (re_add seq1)) + else backtrack + | LLexists (ind,l) -> + if !qflag then + ll_ind_tac ind l backtrack + hd.id continue (re_add seq1) + else + backtrack + | LLarrow (a,b,c) -> + (ll_arrow_tac a b c backtrack + hd.id continue (re_add seq1)) + end in + ll_atom_tac typ la_tac hd.id continue (re_add seq1) + end + with Heap.EmptyHeap->solver + end gl in + wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl + diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli new file mode 100644 index 00000000..3c0e903f --- /dev/null +++ b/plugins/firstorder/ground.mli @@ -0,0 +1,13 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic + diff --git a/plugins/firstorder/ground_plugin.mllib b/plugins/firstorder/ground_plugin.mllib new file mode 100644 index 00000000..447a1fb5 --- /dev/null +++ b/plugins/firstorder/ground_plugin.mllib @@ -0,0 +1,8 @@ +Formula +Unify +Sequent +Rules +Instances +Ground +G_ground +Ground_plugin_mod diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml new file mode 100644 index 00000000..810262a6 --- /dev/null +++ b/plugins/firstorder/instances.ml @@ -0,0 +1,206 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + (OrderedConstr.compare d1 d2) + | Real((m1,c1),n1),Real((m2,c2),n2)-> + ((-) =? (-) ==? OrderedConstr.compare) m2 m1 n1 n2 c1 c2 + | Phantom(_),Real((m,_),_)-> if m=0 then -1 else 1 + | Real((m,_),_),Phantom(_)-> if m=0 then 1 else -1 + +let compare_gr id1 id2= + if id1==id2 then 0 else + if id1==dummy_id then 1 + else if id2==dummy_id then -1 + else Pervasives.compare id1 id2 + +module OrderedInstance= +struct + type t=instance * Libnames.global_reference + let compare (inst1,id1) (inst2,id2)= + (compare_instance =? compare_gr) inst2 inst1 id2 id1 + (* we want a __decreasing__ total order *) +end + +module IS=Set.Make(OrderedInstance) + +let make_simple_atoms seq= + let ratoms= + match seq.glatom with + Some t->[t] + | None->[] + in {negative=seq.latoms;positive=ratoms} + +let do_sequent setref triv id seq i dom atoms= + let flag=ref true in + let phref=ref triv in + let do_atoms a1 a2 = + let do_pair t1 t2 = + match unif_atoms i dom t1 t2 with + None->() + | Some (Phantom _) ->phref:=true + | Some c ->flag:=false;setref:=IS.add (c,id) !setref in + List.iter (fun t->List.iter (do_pair t) a2.negative) a1.positive; + List.iter (fun t->List.iter (do_pair t) a2.positive) a1.negative in + HP.iter (fun lf->do_atoms atoms lf.atoms) seq.redexes; + do_atoms atoms (make_simple_atoms seq); + !flag && !phref + +let match_one_quantified_hyp setref seq lf= + match lf.pat with + Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))-> + if do_sequent setref triv lf.id seq i dom lf.atoms then + setref:=IS.add ((Phantom dom),lf.id) !setref + | _ ->anomaly "can't happen" + +let give_instances lf seq= + let setref=ref IS.empty in + List.iter (match_one_quantified_hyp setref seq) lf; + IS.elements !setref + +(* collector for the engine *) + +let rec collect_quantified seq= + try + let hd,seq1=take_formula seq in + (match hd.pat with + Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> + let (q,seq2)=collect_quantified seq1 in + ((hd::q),seq2) + | _->[],seq) + with Heap.EmptyHeap -> [],seq + +(* open instances processor *) + +let dummy_constr=mkMeta (-1) + +let dummy_bvid=id_of_string "x" + +let mk_open_instance id gl m t= + let env=pf_env gl in + let evmap=Refiner.project gl in + let var_id= + if id==dummy_id then dummy_bvid else + let typ=pf_type_of gl (constr_of_global id) in + (* since we know we will get a product, + reduction is not too expensive *) + let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in + match nam with + Name id -> id + | Anonymous -> dummy_bvid in + let revt=substl (list_tabulate (fun i->mkRel (m-i)) m) t in + let rec aux n avoid= + if n=0 then [] else + let nid=(fresh_id avoid var_id gl) in + (Name nid,None,dummy_constr)::(aux (n-1) (nid::avoid)) in + let nt=it_mkLambda_or_LetIn revt (aux m []) in + let rawt=Detyping.detype false [] [] nt in + let rec raux n t= + if n=0 then t else + match t with + RLambda(loc,name,k,_,t0)-> + let t1=raux (n-1) t0 in + RLambda(loc,name,k,RHole (dummy_loc,Evd.BinderType name),t1) + | _-> anomaly "can't happen" in + let ntt=try + Pretyping.Default.understand evmap env (raux m rawt) + with _ -> + error "Untypable instance, maybe higher-order non-prenex quantification" in + decompose_lam_n_assum m ntt + +(* tactics *) + +let left_instance_tac (inst,id) continue seq= + match inst with + Phantom dom-> + if lookup (id,None) seq then + tclFAIL 0 (Pp.str "already done") + else + tclTHENS (cut dom) + [tclTHENLIST + [introf; + (fun gls->generalize + [mkApp(constr_of_global id, + [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls); + introf; + tclSOLVE [wrap 1 false continue + (deepen (record (id,None) seq))]]; + tclTRY assumption] + | Real((m,t) as c,_)-> + if lookup (id,Some c) seq then + tclFAIL 0 (Pp.str "already done") + else + let special_generalize= + if m>0 then + fun gl-> + let (rc,ot)= mk_open_instance id gl m t in + let gt= + it_mkLambda_or_LetIn + (mkApp(constr_of_global id,[|ot|])) rc in + generalize [gt] gl + else + generalize [mkApp(constr_of_global id,[|t|])] + in + tclTHENLIST + [special_generalize; + introf; + tclSOLVE + [wrap 1 false continue (deepen (record (id,Some c) seq))]] + +let right_instance_tac inst continue seq= + match inst with + Phantom dom -> + tclTHENS (cut dom) + [tclTHENLIST + [introf; + (fun gls-> + split (Rawterm.ImplicitBindings + [mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls); + tclSOLVE [wrap 0 true continue (deepen seq)]]; + tclTRY assumption] + | Real ((0,t),_) -> + (tclTHEN (split (Rawterm.ImplicitBindings [t])) + (tclSOLVE [wrap 0 true continue (deepen seq)])) + | Real ((m,t),_) -> + tclFAIL 0 (Pp.str "not implemented ... yet") + +let instance_tac inst= + if (snd inst)==dummy_id then + right_instance_tac (fst inst) + else + left_instance_tac inst + +let quantified_tac lf backtrack continue seq gl= + let insts=give_instances lf seq in + tclORELSE + (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts)) + backtrack gl + + diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli new file mode 100644 index 00000000..95dd22ea --- /dev/null +++ b/plugins/firstorder/instances.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Formula.t list * Sequent.t + +val give_instances : Formula.t list -> Sequent.t -> + (Unify.instance * global_reference) list + +val quantified_tac : Formula.t list -> seqtac with_backtracking + + + + diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml new file mode 100644 index 00000000..515efea7 --- /dev/null +++ b/plugins/firstorder/rules.ml @@ -0,0 +1,215 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* tactic) -> Sequent.t -> tactic + +type lseqtac= global_reference -> seqtac + +type 'a with_backtracking = tactic -> 'a + +let wrap n b continue seq gls= + check_for_interrupt (); + let nc=pf_hyps gls in + let env=pf_env gls in + let rec aux i nc ctx= + if i<=0 then seq else + match nc with + []->anomaly "Not the expected number of hyps" + | ((id,_,typ) as nd)::q-> + if occur_var env id (pf_concl gls) || + List.exists (occur_var_in_decl env id) ctx then + (aux (i-1) q (nd::ctx)) + else + add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in + let seq1=aux n nc [] in + let seq2=if b then + add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in + continue seq2 gls + +let basename_of_global=function + VarRef id->id + | _->assert false + +let clear_global=function + VarRef id->clear [id] + | _->tclIDTAC + + +(* connection rules *) + +let axiom_tac t seq= + try exact_no_check (constr_of_global (find_left t seq)) + with Not_found->tclFAIL 0 (Pp.str "No axiom link") + +let ll_atom_tac a backtrack id continue seq= + tclIFTHENELSE + (try + tclTHENLIST + [generalize [mkApp(constr_of_global id, + [|constr_of_global (find_left a seq)|])]; + clear_global id; + intro] + with Not_found->tclFAIL 0 (Pp.str "No link")) + (wrap 1 false continue seq) backtrack + +(* right connectives rules *) + +let and_tac backtrack continue seq= + tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack + +let or_tac backtrack continue seq= + tclORELSE + (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq)))) + backtrack + +let arrow_tac backtrack continue seq= + tclIFTHENELSE intro (wrap 1 true continue seq) + (tclORELSE + (tclTHEN introf (tclCOMPLETE (wrap 1 true continue seq))) + backtrack) +(* left connectives rules *) + +let left_and_tac ind backtrack id continue seq gls= + let n=(construct_nhyps ind gls).(0) in + tclIFTHENELSE + (tclTHENLIST + [simplest_elim (constr_of_global id); + clear_global id; + tclDO n intro]) + (wrap n false continue seq) + backtrack gls + +let left_or_tac ind backtrack id continue seq gls= + let v=construct_nhyps ind gls in + let f n= + tclTHENLIST + [clear_global id; + tclDO n intro; + wrap n false continue seq] in + tclIFTHENSVELSE + (simplest_elim (constr_of_global id)) + (Array.map f v) + backtrack gls + +let left_false_tac id= + simplest_elim (constr_of_global id) + +(* left arrow connective rules *) + +(* We use this function for false, and, or, exists *) + +let ll_ind_tac ind largs backtrack id continue seq gl= + let rcs=ind_hyps 0 ind largs gl in + let vargs=Array.of_list largs in + (* construire le terme H->B, le generaliser etc *) + let myterm i= + let rc=rcs.(i) in + let p=List.length rc in + let cstr=mkApp ((mkConstruct (ind,(i+1))),vargs) in + let vars=Array.init p (fun j->mkRel (p-j)) in + let capply=mkApp ((lift p cstr),vars) in + let head=mkApp ((lift p (constr_of_global id)),[|capply|]) in + it_mkLambda_or_LetIn head rc in + let lp=Array.length rcs in + let newhyps=list_tabulate myterm lp in + tclIFTHENELSE + (tclTHENLIST + [generalize newhyps; + clear_global id; + tclDO lp intro]) + (wrap lp false continue seq) backtrack gl + +let ll_arrow_tac a b c backtrack id continue seq= + let cc=mkProd(Anonymous,a,(lift 1 b)) in + let d=mkLambda (Anonymous,b, + mkApp ((constr_of_global id), + [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in + tclORELSE + (tclTHENS (cut c) + [tclTHENLIST + [introf; + clear_global id; + wrap 1 false continue seq]; + tclTHENS (cut cc) + [exact_no_check (constr_of_global id); + tclTHENLIST + [generalize [d]; + clear_global id; + introf; + introf; + tclCOMPLETE (wrap 2 true continue seq)]]]) + backtrack + +(* quantifier rules (easy side) *) + +let forall_tac backtrack continue seq= + tclORELSE + (tclIFTHENELSE intro (wrap 0 true continue seq) + (tclORELSE + (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq))) + backtrack)) + (if !qflag then + tclFAIL 0 (Pp.str "reversible in 1st order mode") + else + backtrack) + +let left_exists_tac ind backtrack id continue seq gls= + let n=(construct_nhyps ind gls).(0) in + tclIFTHENELSE + (simplest_elim (constr_of_global id)) + (tclTHENLIST [clear_global id; + tclDO n intro; + (wrap (n-1) false continue seq)]) + backtrack + gls + +let ll_forall_tac prod backtrack id continue seq= + tclORELSE + (tclTHENS (cut prod) + [tclTHENLIST + [intro; + (fun gls-> + let id0=pf_nth_hyp_id gls 1 in + let term=mkApp((constr_of_global id),[|mkVar(id0)|]) in + tclTHEN (generalize [term]) (clear [id0]) gls); + clear_global id; + intro; + tclCOMPLETE (wrap 1 false continue (deepen seq))]; + tclCOMPLETE (wrap 0 true continue (deepen seq))]) + backtrack + +(* rules for instantiation with unification moved to instances.ml *) + +(* special for compatibility with old Intuition *) + +let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str + +let defined_connectives=lazy + [all_occurrences,EvalConstRef (destConst (constant "not")); + all_occurrences,EvalConstRef (destConst (constant "iff"))] + +let normalize_evaluables= + onAllHypsAndConcl + (function + None->unfold_in_concl (Lazy.force defined_connectives) + | Some id -> + unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)) diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli new file mode 100644 index 00000000..fc32621c --- /dev/null +++ b/plugins/firstorder/rules.mli @@ -0,0 +1,54 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* tactic) -> Sequent.t -> tactic + +type lseqtac= global_reference -> seqtac + +type 'a with_backtracking = tactic -> 'a + +val wrap : int -> bool -> seqtac + +val basename_of_global: global_reference -> identifier + +val clear_global: global_reference -> tactic + +val axiom_tac : constr -> Sequent.t -> tactic + +val ll_atom_tac : constr -> lseqtac with_backtracking + +val and_tac : seqtac with_backtracking + +val or_tac : seqtac with_backtracking + +val arrow_tac : seqtac with_backtracking + +val left_and_tac : inductive -> lseqtac with_backtracking + +val left_or_tac : inductive -> lseqtac with_backtracking + +val left_false_tac : global_reference -> tactic + +val ll_ind_tac : inductive -> constr list -> lseqtac with_backtracking + +val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking + +val forall_tac : seqtac with_backtracking + +val left_exists_tac : inductive -> lseqtac with_backtracking + +val ll_forall_tac : types -> lseqtac with_backtracking + +val normalize_evaluables : tactic diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml new file mode 100644 index 00000000..685d44a8 --- /dev/null +++ b/plugins/firstorder/sequent.ml @@ -0,0 +1,312 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* if b then incr cnt;!cnt + +let priority = (* pure heuristics, <=0 for non reversible *) + function + Right rf-> + begin + match rf with + Rarrow -> 100 + | Rand -> 40 + | Ror -> -15 + | Rfalse -> -50 + | Rforall -> 100 + | Rexists (_,_,_) -> -29 + end + | Left lf -> + match lf with + Lfalse -> 999 + | Land _ -> 90 + | Lor _ -> 40 + | Lforall (_,_,_) -> -30 + | Lexists _ -> 60 + | LA(_,lap) -> + match lap with + LLatom -> 0 + | LLfalse (_,_) -> 100 + | LLand (_,_) -> 80 + | LLor (_,_) -> 70 + | LLforall _ -> -20 + | LLexists (_,_) -> 50 + | LLarrow (_,_,_) -> -10 + +let left_reversible lpat=(priority lpat)>0 + +module OrderedFormula= +struct + type t=Formula.t + let compare e1 e2= + (priority e1.pat) - (priority e2.pat) +end + +(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare + the immediate subterms of [c1] of [c2] if needed; Cast's, + application associativity, binders name and Cases annotations are + not taken into account *) + +let rec compare_list f l1 l2= + match l1,l2 with + [],[]-> 0 + | [],_ -> -1 + | _,[] -> 1 + | (h1::q1),(h2::q2) -> (f =? (compare_list f)) h1 h2 q1 q2 + +let compare_array f v1 v2= + let l=Array.length v1 in + let c=l - Array.length v2 in + if c=0 then + let rec comp_aux i= + if i<0 then 0 + else + let ci=f v1.(i) v2.(i) in + if ci=0 then + comp_aux (i-1) + else ci + in comp_aux (l-1) + else c + +let compare_constr_int f t1 t2 = + match kind_of_term t1, kind_of_term t2 with + | Rel n1, Rel n2 -> n1 - n2 + | Meta m1, Meta m2 -> m1 - m2 + | Var id1, Var id2 -> Pervasives.compare id1 id2 + | Sort s1, Sort s2 -> Pervasives.compare s1 s2 + | Cast (c1,_,_), _ -> f c1 t2 + | _, Cast (c2,_,_) -> f t1 c2 + | Prod (_,t1,c1), Prod (_,t2,c2) + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> + (f =? f) t1 t2 c1 c2 + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> + ((f =? f) ==? f) b1 b2 t1 t2 c1 c2 + | App (_,_), App (_,_) -> + let c1,l1=decompose_app t1 + and c2,l2=decompose_app t2 in + (f =? (compare_list f)) c1 c2 l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> + ((-) =? (compare_array f)) e1 e2 l1 l2 + | Const c1, Const c2 -> Pervasives.compare c1 c2 + | Ind c1, Ind c2 -> Pervasives.compare c1 c2 + | Construct c1, Construct c2 -> Pervasives.compare c1 c2 + | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> + ((f =? f) ==? (compare_array f)) p1 p2 c1 c2 bl1 bl2 + | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> + ((Pervasives.compare =? (compare_array f)) ==? (compare_array f)) + ln1 ln2 tl1 tl2 bl1 bl2 + | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> + ((Pervasives.compare =? (compare_array f)) ==? (compare_array f)) + ln1 ln2 tl1 tl2 bl1 bl2 + | _ -> Pervasives.compare t1 t2 + +let rec compare_constr m n= + compare_constr_int compare_constr m n + +module OrderedConstr= +struct + type t=constr + let compare=compare_constr +end + +type h_item = global_reference * (int*constr) option + +module Hitem= +struct + type t = h_item + let compare (id1,co1) (id2,co2)= + (Pervasives.compare + =? (fun oc1 oc2 -> + match oc1,oc2 with + Some (m1,c1),Some (m2,c2) -> + ((-) =? OrderedConstr.compare) m1 m2 c1 c2 + | _,_->Pervasives.compare oc1 oc2)) id1 id2 co1 co2 +end + +module CM=Map.Make(OrderedConstr) + +module History=Set.Make(Hitem) + +let cm_add typ nam cm= + try + let l=CM.find typ cm in CM.add typ (nam::l) cm + with + Not_found->CM.add typ [nam] cm + +let cm_remove typ nam cm= + try + let l=CM.find typ cm in + let l0=List.filter (fun id->id<>nam) l in + match l0 with + []->CM.remove typ cm + | _ ->CM.add typ l0 cm + with Not_found ->cm + +module HP=Heap.Functional(OrderedFormula) + +type t= + {redexes:HP.t; + context:(global_reference list) CM.t; + latoms:constr list; + gl:types; + glatom:constr option; + cnt:counter; + history:History.t; + depth:int} + +let deepen seq={seq with depth=seq.depth-1} + +let record item seq={seq with history=History.add item seq.history} + +let lookup item seq= + History.mem item seq.history || + match item with + (_,None)->false + | (id,Some ((m,t) as c))-> + let p (id2,o)= + match o with + None -> false + | Some ((m2,t2) as c2)->id=id2 && m2>m && more_general c2 c in + History.exists p seq.history + +let rec add_formula side nam t seq gl= + match build_formula side nam t gl seq.cnt with + Left f-> + begin + match side with + Concl -> + {seq with + redexes=HP.add f seq.redexes; + gl=f.constr; + glatom=None} + | _ -> + {seq with + redexes=HP.add f seq.redexes; + context=cm_add f.constr nam seq.context} + end + | Right t-> + match side with + Concl -> + {seq with gl=t;glatom=Some t} + | _ -> + {seq with + context=cm_add t nam seq.context; + latoms=t::seq.latoms} + +let re_add_formula_list lf seq= + let do_one f cm= + if f.id == dummy_id then cm + else cm_add f.constr f.id cm in + {seq with + redexes=List.fold_right HP.add lf seq.redexes; + context=List.fold_right do_one lf seq.context} + +let find_left t seq=List.hd (CM.find t seq.context) + +(*let rev_left seq= + try + let lpat=(HP.maximum seq.redexes).pat in + left_reversible lpat + with Heap.EmptyHeap -> false +*) +let no_formula seq= + seq.redexes=HP.empty + +let rec take_formula seq= + let hd=HP.maximum seq.redexes + and hp=HP.remove seq.redexes in + if hd.id == dummy_id then + let nseq={seq with redexes=hp} in + if seq.gl==hd.constr then + hd,nseq + else + take_formula nseq (* discarding deprecated goal *) + else + hd,{seq with + redexes=hp; + context=cm_remove hd.constr hd.id seq.context} + +let empty_seq depth= + {redexes=HP.empty; + context=CM.empty; + latoms=[]; + gl=(mkMeta 1); + glatom=None; + cnt=newcnt (); + history=History.empty; + depth=depth} + +let expand_constructor_hints = + list_map_append (function + | IndRef ind -> + list_tabulate (fun i -> ConstructRef (ind,i+1)) + (Inductiveops.nconstructors ind) + | gr -> + [gr]) + +let extend_with_ref_list l seq gl= + let l = expand_constructor_hints l in + let f gr seq= + let c=constr_of_global gr in + let typ=(pf_type_of gl c) in + add_formula Hyp gr typ seq gl in + List.fold_right f l seq + +open Auto + +let extend_with_auto_hints l seq gl= + let seqref=ref seq in + let f p_a_t = + match p_a_t.code with + Res_pf (c,_) | Give_exact c + | Res_pf_THEN_trivial_fail (c,_) -> + (try + let gr=global_of_constr c in + let typ=(pf_type_of gl c) in + seqref:=add_formula Hint gr typ !seqref gl + with Not_found->()) + | _-> () in + let g _ l=List.iter f l in + let h dbname= + let hdb= + try + searchtable_map dbname + with Not_found-> + error ("Firstorder: "^dbname^" : No such Hint database") in + Hint_db.iter g hdb in + List.iter h l; + !seqref + +let print_cmap map= + let print_entry c l s= + let xc=Constrextern.extern_constr false (Global.env ()) c in + str "| " ++ + Util.prlist Printer.pr_global l ++ + str " : " ++ + Ppconstr.pr_constr_expr xc ++ + cut () ++ + s in + msgnl (v 0 + (str "-----" ++ + cut () ++ + CM.fold print_entry map (mt ()) ++ + str "-----")) + + diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli new file mode 100644 index 00000000..ce0eddcc --- /dev/null +++ b/plugins/firstorder/sequent.mli @@ -0,0 +1,66 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* global_reference -> global_reference list CM.t -> + global_reference list CM.t + +val cm_remove : constr -> global_reference -> global_reference list CM.t -> + global_reference list CM.t + +module HP: Heap.S with type elt=Formula.t + +type t = {redexes:HP.t; + context: global_reference list CM.t; + latoms:constr list; + gl:types; + glatom:constr option; + cnt:counter; + history:History.t; + depth:int} + +val deepen: t -> t + +val record: h_item -> t -> t + +val lookup: h_item -> t -> bool + +val add_formula : side -> global_reference -> constr -> t -> + Proof_type.goal sigma -> t + +val re_add_formula_list : Formula.t list -> t -> t + +val find_left : constr -> t -> global_reference + +val take_formula : t -> Formula.t * t + +val empty_seq : int -> t + +val extend_with_ref_list : global_reference list -> + t -> Proof_type.goal sigma -> t + +val extend_with_auto_hints : Auto.hint_db_name list -> + t -> Proof_type.goal sigma -> t + +val print_cmap: global_reference list CM.t -> unit diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml new file mode 100644 index 00000000..e3a4c6a5 --- /dev/null +++ b/plugins/firstorder/unify.ml @@ -0,0 +1,143 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (n,subst_meta [i,t] tn)) !sigma) in + let rec head_reduce t= + (* forbids non-sigma-normal meta in head position*) + match kind_of_term t with + Meta i-> + (try + head_reduce (List.assoc i !sigma) + with Not_found->t) + | _->t in + Queue.add (t1,t2) bige; + try while true do + let t1,t2=Queue.take bige in + let nt1=head_reduce (whd_betaiotazeta Evd.empty t1) + and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in + match (kind_of_term nt1),(kind_of_term nt2) with + Meta i,Meta j-> + if i<>j then + if i + let t=subst_meta !sigma nt2 in + if Intset.is_empty (free_rels t) && + not (occur_term (mkMeta i) t) then + bind i t else raise (UFAIL(nt1,nt2)) + | _,Meta i -> + let t=subst_meta !sigma nt1 in + if Intset.is_empty (free_rels t) && + not (occur_term (mkMeta i) t) then + bind i t else raise (UFAIL(nt1,nt2)) + | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige + | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige + | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> + Queue.add (a,c) bige;Queue.add (pop b,pop d) bige + | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> + Queue.add (pa,pb) bige; + Queue.add (ca,cb) bige; + let l=Array.length va in + if l<>(Array.length vb) then + raise (UFAIL (nt1,nt2)) + else + for i=0 to l-1 do + Queue.add (va.(i),vb.(i)) bige + done + | App(ha,va),App(hb,vb)-> + Queue.add (ha,hb) bige; + let l=Array.length va in + if l<>(Array.length vb) then + raise (UFAIL (nt1,nt2)) + else + for i=0 to l-1 do + Queue.add (va.(i),vb.(i)) bige + done + | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2)) + done; + assert false + (* this place is unreachable but needed for the sake of typing *) + with Queue.Empty-> !sigma + +let value i t= + let add x y= + if x<0 then y else if y<0 then x else x+y in + let tref=mkMeta i in + let rec vaux term= + if term=tref then 0 else + let f v t=add v (vaux t) in + let vr=fold_constr f (-1) term in + if vr<0 then -1 else vr+1 in + vaux t + +type instance= + Real of (int*constr)*int + | Phantom of constr + +let mk_rel_inst t= + let new_rel=ref 1 in + let rel_env=ref [] in + let rec renum_rec d t= + match kind_of_term t with + Meta n-> + (try + mkRel (d+(List.assoc n !rel_env)) + with Not_found-> + let m= !new_rel in + incr new_rel; + rel_env:=(n,m) :: !rel_env; + mkRel (m+d)) + | _ -> map_constr_with_binders succ renum_rec d t + in + let nt=renum_rec 0 t in (!new_rel - 1,nt) + +let unif_atoms i dom t1 t2= + try + let t=List.assoc i (unif t1 t2) in + if isMeta t then Some (Phantom dom) + else Some (Real(mk_rel_inst t,value i t1)) + with + UFAIL(_,_) ->None + | Not_found ->Some (Phantom dom) + +let renum_metas_from k n t= (* requires n = max (free_rels t) *) + let l=list_tabulate (fun i->mkMeta (k+i)) n in + substl l t + +let more_general (m1,t1) (m2,t2)= + let mt1=renum_metas_from 0 m1 t1 + and mt2=renum_metas_from m1 m2 t2 in + try + let sigma=unif mt1 mt2 in + let p (n,t)= nfalse diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli new file mode 100644 index 00000000..d6cb3a08 --- /dev/null +++ b/plugins/firstorder/unify.mli @@ -0,0 +1,23 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr -> (int*constr) list + +type instance= + Real of (int*constr)*int (* nb trous*terme*valeur heuristique *) + | Phantom of constr (* domaine de quantification *) + +val unif_atoms : metavariable -> constr -> constr -> constr -> instance option + +val more_general : (int*constr) -> (int*constr) -> bool diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v new file mode 100644 index 00000000..07b2973a --- /dev/null +++ b/plugins/fourier/Fourier.v @@ -0,0 +1,21 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 0 < a -> a * x1 < a * y1. +intros; apply Rmult_lt_compat_l; assumption. +Qed. + +Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1. +red in |- *. +intros. +case H; auto with real. +Qed. + +Lemma Rfourier_lt_lt : + forall x1 y1 x2 y2 a:R, + x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. +intros x1 y1 x2 y2 a H H0 H1; try assumption. +apply Rplus_lt_compat. +try exact H. +apply Rfourier_lt. +try exact H0. +try exact H1. +Qed. + +Lemma Rfourier_lt_le : + forall x1 y1 x2 y2 a:R, + x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. +intros x1 y1 x2 y2 a H H0 H1; try assumption. +case H0; intros. +apply Rplus_lt_compat. +try exact H. +apply Rfourier_lt; auto with real. +rewrite H2. +rewrite (Rplus_comm y1 (a * y2)). +rewrite (Rplus_comm x1 (a * y2)). +apply Rplus_lt_compat_l. +try exact H. +Qed. + +Lemma Rfourier_le_lt : + forall x1 y1 x2 y2 a:R, + x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. +intros x1 y1 x2 y2 a H H0 H1; try assumption. +case H; intros. +apply Rfourier_lt_le; auto with real. +rewrite H2. +apply Rplus_lt_compat_l. +apply Rfourier_lt; auto with real. +Qed. + +Lemma Rfourier_le_le : + forall x1 y1 x2 y2 a:R, + x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2. +intros x1 y1 x2 y2 a H H0 H1; try assumption. +case H0; intros. +red in |- *. +left; try assumption. +apply Rfourier_le_lt; auto with real. +rewrite H2. +case H; intros. +red in |- *. +left; try assumption. +rewrite (Rplus_comm x1 (a * y2)). +rewrite (Rplus_comm y1 (a * y2)). +apply Rplus_lt_compat_l. +try exact H3. +rewrite H3. +red in |- *. +right; try assumption. +auto with real. +Qed. + +Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. +intros x H; try assumption. +rewrite Rplus_comm. +apply Rle_lt_0_plus_1. +red in |- *; auto with real. +Qed. + +Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. +intros x y H H0; try assumption. +replace 0 with (x * 0). +apply Rmult_lt_compat_l; auto with real. +ring. +Qed. + +Lemma Rlt_zero_1 : 0 < 1. +exact Rlt_0_1. +Qed. + +Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. +intros x H; try assumption. +case H; intros. +red in |- *. +left; try assumption. +apply Rlt_zero_pos_plus1; auto with real. +rewrite <- H0. +replace (1 + 0) with 1. +red in |- *; left. +exact Rlt_zero_1. +ring. +Qed. + +Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. +intros x y H H0; try assumption. +case H; intros. +red in |- *; left. +apply Rlt_mult_inv_pos; auto with real. +rewrite <- H1. +red in |- *; right; ring. +Qed. + +Lemma Rle_zero_1 : 0 <= 1. +red in |- *; left. +exact Rlt_zero_1. +Qed. + +Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d. +intros n d H; red in |- *; intros H0; try exact H0. +generalize (Rgt_not_le 0 (n * / d)). +intros H1; elim H1; try assumption. +replace (n * / d) with (- - (n * / d)). +replace 0 with (- -0). +replace (- (n * / d)) with (- n * / d). +replace (-0) with 0. +red in |- *. +apply Ropp_gt_lt_contravar. +red in |- *. +exact H0. +ring. +ring. +ring. +ring. +Qed. + +Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x. +intros x; try assumption. +replace (0 * x) with 0. +apply Rlt_irrefl. +ring. +Qed. + +Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d. +intros n d H; try assumption. +apply Rgt_not_le. +replace 0 with (-0). +replace (- n * / d) with (- (n * / d)). +apply Ropp_lt_gt_contravar. +try exact H. +ring. +ring. +Qed. + +Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y. +unfold not in |- *; intros. +apply H. +apply Rplus_lt_reg_r with x. +replace (x + 0) with x. +replace (x + (y - x)) with y. +try exact H0. +ring. +ring. +Qed. + +Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y. +unfold not in |- *; intros. +apply H. +case H0; intros. +left. +apply Rplus_lt_reg_r with x. +replace (x + 0) with x. +replace (x + (y - x)) with y. +try exact H1. +ring. +ring. +right. +rewrite H1; ring. +Qed. + +Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y. +unfold Rgt in |- *; intros; assumption. +Qed. + +Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y. +intros x y; exact (Rge_le y x). +Qed. + +Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y. +exact Req_le. +Qed. + +Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y. +exact Req_le_sym. +Qed. + +Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y. +exact Rnot_ge_lt. +Qed. + +Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y. +exact Rnot_gt_le. +Qed. + +Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y. +exact Rnot_le_lt. +Qed. + +Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y. +exact Rnot_lt_ge. +Qed. diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml new file mode 100644 index 00000000..73fb4929 --- /dev/null +++ b/plugins/fourier/fourier.ml @@ -0,0 +1,205 @@ +(************************************************************************) +(* 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 = + match (partitionne s) with + [lneg;lnul;lpos] -> + let lnew = deduce_add lneg lpos in + (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; + done; + !lie +;; + +(* donne [] si le système a des 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. +*) +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/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml new file mode 100644 index 00000000..3f490bab --- /dev/null +++ b/plugins/fourier/fourierR.ml @@ -0,0 +1,629 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* r0;; + +let flin_add f x c = + let cx = flin_coef f x in + Hashtbl.remove f.fhom x; + Hashtbl.add f.fhom x (rplus cx c); + f +;; +let flin_add_cste f c = + {fhom=f.fhom; + fcste=rplus f.fcste c} +;; + +let flin_one () = flin_add_cste (flin_zero()) r1;; + +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; +;; + +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); +;; +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); +;; + +(*****************************************************************************) +open Vernacexpr + +type ineq = Rlt | Rle | Rgt | Rge + +let string_of_R_constant kn = + match Names.repr_con kn with + | MPfile dir, sec_dir, id when + sec_dir = empty_dirpath && + string_of_dirpath dir = "Coq.Reals.Rdefinitions" + -> string_of_label id + | _ -> "constant_not_of_R" + +let rec string_of_R_constr c = + match kind_of_term c with + Cast (c,_,_) -> string_of_R_constr c + |Const c -> string_of_R_constant c + | _ -> "not_of_constant" + +let rec rational_of_constr c = + match kind_of_term c with + | Cast (c,_,_) -> (rational_of_constr c) + | App (c,args) -> + (match (string_of_R_constr c) with + | "Ropp" -> + rop (rational_of_constr args.(0)) + | "Rinv" -> + rinv (rational_of_constr args.(0)) + | "Rmult" -> + rmult (rational_of_constr args.(0)) + (rational_of_constr args.(1)) + | "Rdiv" -> + rdiv (rational_of_constr args.(0)) + (rational_of_constr args.(1)) + | "Rplus" -> + rplus (rational_of_constr args.(0)) + (rational_of_constr args.(1)) + | "Rminus" -> + rminus (rational_of_constr args.(0)) + (rational_of_constr args.(1)) + | _ -> failwith "not a rational") + | Const kn -> + (match (string_of_R_constant kn) with + "R1" -> r1 + |"R0" -> r0 + | _ -> failwith "not a rational") + | _ -> failwith "not a rational" +;; + +let rec flin_of_constr c = + try( + match kind_of_term c with + | Cast (c,_,_) -> (flin_of_constr c) + | App (c,args) -> + (match (string_of_R_constr c) with + "Ropp" -> + flin_emult (rop r1) (flin_of_constr args.(0)) + | "Rplus"-> + flin_plus (flin_of_constr args.(0)) + (flin_of_constr args.(1)) + | "Rminus"-> + flin_minus (flin_of_constr args.(0)) + (flin_of_constr args.(1)) + | "Rmult"-> + (try (let a=(rational_of_constr args.(0)) in + try (let b = (rational_of_constr args.(1)) in + (flin_add_cste (flin_zero()) (rmult a b))) + with _-> (flin_add (flin_zero()) + args.(1) + a)) + with _-> (flin_add (flin_zero()) + args.(0) + (rational_of_constr args.(1)))) + | "Rinv"-> + let a=(rational_of_constr args.(0)) in + flin_add_cste (flin_zero()) (rinv a) + | "Rdiv"-> + (let b=(rational_of_constr args.(1)) in + try (let a = (rational_of_constr args.(0)) in + (flin_add_cste (flin_zero()) (rdiv a b))) + with _-> (flin_add (flin_zero()) + args.(0) + (rinv b))) + |_->assert false) + | Const c -> + (match (string_of_R_constant c) with + "R1" -> flin_one () + |"R0" -> flin_zero () + |_-> assert false) + |_-> assert false) + with _ -> flin_add (flin_zero()) + c + r1 +;; + +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. +*) +type hineq={hname:constr; (* le nom de l'hypothèse *) + htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *) + hleft:constr; + hright:constr; + hflin:flin; + hstrict:bool} +;; + +(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0 +*) +let ineq1_of_constr (h,t) = + match (kind_of_term t) with + App (f,args) -> + (match kind_of_term f with + Const c when Array.length args = 2 -> + let t1= args.(0) in + let t2= args.(1) in + (match (string_of_R_constant c) with + "Rlt" -> [{hname=h; + htype="Rlt"; + hleft=t1; + hright=t2; + hflin= flin_minus (flin_of_constr t1) + (flin_of_constr t2); + hstrict=true}] + |"Rgt" -> [{hname=h; + htype="Rgt"; + hleft=t2; + hright=t1; + hflin= flin_minus (flin_of_constr t2) + (flin_of_constr t1); + hstrict=true}] + |"Rle" -> [{hname=h; + htype="Rle"; + hleft=t1; + hright=t2; + hflin= flin_minus (flin_of_constr t1) + (flin_of_constr t2); + hstrict=false}] + |"Rge" -> [{hname=h; + htype="Rge"; + hleft=t2; + hright=t1; + hflin= flin_minus (flin_of_constr t2) + (flin_of_constr t1); + hstrict=false}] + |_->assert false) + | Ind (kn,i) -> + if IndRef(kn,i) = Coqlib.glob_eq then + let t0= args.(0) in + let t1= args.(1) in + let t2= args.(2) in + (match (kind_of_term t0) with + Const c -> + (match (string_of_R_constant c) with + "R"-> + [{hname=h; + htype="eqTLR"; + hleft=t1; + hright=t2; + hflin= flin_minus (flin_of_constr t1) + (flin_of_constr t2); + hstrict=false}; + {hname=h; + htype="eqTRL"; + hleft=t2; + hright=t1; + hflin= flin_minus (flin_of_constr t2) + (flin_of_constr t1); + hstrict=false}] + |_-> assert false) + |_-> assert false) + else + assert false + |_-> assert false) + |_-> assert false +;; + +(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq) +*) + +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 _ -> if not (Hashtbl.mem hvar x) then begin + nvar:=(!nvar)+1; + Hashtbl.add hvar x (!nvar) + end) + f.hflin.fhom) + lineq1; + 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 + unsolvable sys +;; + +(*********************************************************************) +(* Defined constants *) + +let get = Lazy.force +let constant = Coqlib.gen_constant "Fourier" + +(* Standard library *) +open Coqlib +let coq_sym_eqT = lazy (build_coq_eq_sym ()) +let coq_False = lazy (build_coq_False ()) +let coq_not = lazy (build_coq_not ()) +let coq_eq = lazy (build_coq_eq ()) + +(* Rdefinitions *) +let constant_real = constant ["Reals";"Rdefinitions"] + +let coq_Rlt = lazy (constant_real "Rlt") +let coq_Rgt = lazy (constant_real "Rgt") +let coq_Rle = lazy (constant_real "Rle") +let coq_Rge = lazy (constant_real "Rge") +let coq_R = lazy (constant_real "R") +let coq_Rminus = lazy (constant_real "Rminus") +let coq_Rmult = lazy (constant_real "Rmult") +let coq_Rplus = lazy (constant_real "Rplus") +let coq_Ropp = lazy (constant_real "Ropp") +let coq_Rinv = lazy (constant_real "Rinv") +let coq_R0 = lazy (constant_real "R0") +let coq_R1 = lazy (constant_real "R1") + +(* RIneq *) +let coq_Rinv_1 = lazy (constant ["Reals";"RIneq"] "Rinv_1") + +(* Fourier_util *) +let constant_fourier = constant ["fourier";"Fourier_util"] + +let coq_Rlt_zero_1 = lazy (constant_fourier "Rlt_zero_1") +let coq_Rlt_zero_pos_plus1 = lazy (constant_fourier "Rlt_zero_pos_plus1") +let coq_Rle_zero_pos_plus1 = lazy (constant_fourier "Rle_zero_pos_plus1") +let coq_Rlt_mult_inv_pos = lazy (constant_fourier "Rlt_mult_inv_pos") +let coq_Rle_zero_zero = lazy (constant_fourier "Rle_zero_zero") +let coq_Rle_zero_1 = lazy (constant_fourier "Rle_zero_1") +let coq_Rle_mult_inv_pos = lazy (constant_fourier "Rle_mult_inv_pos") +let coq_Rnot_lt0 = lazy (constant_fourier "Rnot_lt0") +let coq_Rle_not_lt = lazy (constant_fourier "Rle_not_lt") +let coq_Rfourier_gt_to_lt = lazy (constant_fourier "Rfourier_gt_to_lt") +let coq_Rfourier_ge_to_le = lazy (constant_fourier "Rfourier_ge_to_le") +let coq_Rfourier_eqLR_to_le = lazy (constant_fourier "Rfourier_eqLR_to_le") +let coq_Rfourier_eqRL_to_le = lazy (constant_fourier "Rfourier_eqRL_to_le") + +let coq_Rfourier_not_ge_lt = lazy (constant_fourier "Rfourier_not_ge_lt") +let coq_Rfourier_not_gt_le = lazy (constant_fourier "Rfourier_not_gt_le") +let coq_Rfourier_not_le_gt = lazy (constant_fourier "Rfourier_not_le_gt") +let coq_Rfourier_not_lt_ge = lazy (constant_fourier "Rfourier_not_lt_ge") +let coq_Rfourier_lt = lazy (constant_fourier "Rfourier_lt") +let coq_Rfourier_le = lazy (constant_fourier "Rfourier_le") +let coq_Rfourier_lt_lt = lazy (constant_fourier "Rfourier_lt_lt") +let coq_Rfourier_lt_le = lazy (constant_fourier "Rfourier_lt_le") +let coq_Rfourier_le_lt = lazy (constant_fourier "Rfourier_le_lt") +let coq_Rfourier_le_le = lazy (constant_fourier "Rfourier_le_le") +let coq_Rnot_lt_lt = lazy (constant_fourier "Rnot_lt_lt") +let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le") +let coq_Rlt_not_le_frac_opp = lazy (constant_fourier "Rlt_not_le_frac_opp") + +(****************************************************************************** +Construction de la preuve en cas de succès de la méthode de Fourier, +i.e. on obtient une contradiction. +*) +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 int_to_real n = + let nn=abs n in + if nn=0 + then get coq_R0 + else + (let s=ref (get coq_R1) in + for i=1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done; + if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s) +;; +(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1))) +*) +let rational_to_real x = + let (n,d)=rational_to_fraction x in + mkApp (get coq_Rmult, + [|int_to_real n;mkApp(get coq_Rinv,[|int_to_real d|])|]) +;; + +(* preuve que 0 False +*) +let tac_zero_inf_false gl (n,d) = + if n=0 then (apply (get coq_Rnot_lt0)) + else + (tclTHEN (apply (get coq_Rle_not_lt)) + (tac_zero_infeq_pos gl (-n,d))) +;; + +(* preuve que 0<=(-n)*(1/d) => False +*) +let tac_zero_infeq_false gl (n,d) = + (tclTHEN (apply (get coq_Rlt_not_le_frac_opp)) + (tac_zero_inf_pos gl (-n,d))) +;; + +let create_meta () = mkMeta(Evarutil.new_meta());; + +let my_cut c gl= + let concl = pf_concl gl in + apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl +;; + +let exact = exact_check;; + +let tac_use h = match h.htype with + "Rlt" -> exact h.hname + |"Rle" -> exact h.hname + |"Rgt" -> (tclTHEN (apply (get coq_Rfourier_gt_to_lt)) + (exact h.hname)) + |"Rge" -> (tclTHEN (apply (get coq_Rfourier_ge_to_le)) + (exact h.hname)) + |"eqTLR" -> (tclTHEN (apply (get coq_Rfourier_eqLR_to_le)) + (exact h.hname)) + |"eqTRL" -> (tclTHEN (apply (get coq_Rfourier_eqRL_to_le)) + (exact h.hname)) + |_->assert false +;; + +(* +let is_ineq (h,t) = + match (kind_of_term t) with + App (f,args) -> + (match (string_of_R_constr f) with + "Rlt" -> true + | "Rgt" -> true + | "Rle" -> true + | "Rge" -> true +(* Wrong:not in Rdefinitions: *) | "eqT" -> + (match (string_of_R_constr args.(0)) with + "R" -> true + | _ -> false) + | _ ->false) + |_->false +;; +*) + +let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;; + +let mkAppL a = + let l = Array.to_list a in + mkApp(List.hd l, Array.of_list (List.tl l)) +;; + +(* Résolution d'inéquations linéaires dans R *) +let rec fourier gl= + Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; + let goal = strip_outer_cast (pf_concl gl) in + let fhyp=id_of_string "new_hyp_for_fourier" in + (* si le but est une inéquation, on introduit son contraire, + et le but à prouver devient False *) + try (let tac = + match (kind_of_term goal) with + App (f,args) -> + (match (string_of_R_constr f) with + "Rlt" -> + (tclTHEN + (tclTHEN (apply (get coq_Rfourier_not_ge_lt)) + (intro_using fhyp)) + fourier) + |"Rle" -> + (tclTHEN + (tclTHEN (apply (get coq_Rfourier_not_gt_le)) + (intro_using fhyp)) + fourier) + |"Rgt" -> + (tclTHEN + (tclTHEN (apply (get coq_Rfourier_not_le_gt)) + (intro_using fhyp)) + fourier) + |"Rge" -> + (tclTHEN + (tclTHEN (apply (get coq_Rfourier_not_lt_ge)) + (intro_using fhyp)) + fourier) + |_->assert false) + |_->assert false + in tac gl) + with _ -> + (* les hypothèses *) + let hyps = List.map (fun (h,t)-> (mkVar h,t)) + (list_of_sign (pf_hyps gl)) in + let lineq =ref [] in + List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) + with _ -> ()) + hyps; + (* lineq = les inéquations découlant des hypothèses *) + if !lineq=[] then Util.error "No inequalities"; + let res=fourier_lineq (!lineq) in + let tac=ref tclIDTAC in + if res=[] + then Util.error "fourier failed" + (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *) + else (match res with + [(cres,sres,lc)]-> + (* lc=coefficients multiplicateurs des inéquations + qui donnent 0 + if c<>r0 + then (lutil:=(h,c)::(!lutil)(*; + print_rational(c);print_string " "*))) + (List.combine (!lineq) lc); + (* on construit la combinaison linéaire des inéquation *) + (match (!lutil) with + (h1,c1)::lutil -> + let s=ref (h1.hstrict) in + let t1=ref (mkAppL [|get coq_Rmult; + rational_to_real c1; + h1.hleft|]) in + let t2=ref (mkAppL [|get coq_Rmult; + rational_to_real c1; + h1.hright|]) in + List.iter (fun (h,c) -> + s:=(!s)||(h.hstrict); + t1:=(mkAppL [|get coq_Rplus; + !t1; + mkAppL [|get coq_Rmult; + rational_to_real c; + h.hleft|] |]); + t2:=(mkAppL [|get coq_Rplus; + !t2; + mkAppL [|get coq_Rmult; + rational_to_real c; + h.hright|] |])) + lutil; + let ineq=mkAppL [|if (!s) then get coq_Rlt else get coq_Rle; + !t1; + !t2 |] in + let tc=rational_to_real cres in + (* puis sa preuve *) + let tac1=ref (if h1.hstrict + then (tclTHENS (apply (get coq_Rfourier_lt)) + [tac_use h1; + tac_zero_inf_pos gl + (rational_to_fraction c1)]) + else (tclTHENS (apply (get coq_Rfourier_le)) + [tac_use h1; + tac_zero_inf_pos gl + (rational_to_fraction c1)])) in + s:=h1.hstrict; + List.iter (fun (h,c)-> + (if (!s) + then (if h.hstrict + then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt)) + [!tac1;tac_use h; + tac_zero_inf_pos gl + (rational_to_fraction c)]) + else tac1:=(tclTHENS (apply (get coq_Rfourier_lt_le)) + [!tac1;tac_use h; + tac_zero_inf_pos gl + (rational_to_fraction c)])) + else (if h.hstrict + then tac1:=(tclTHENS (apply (get coq_Rfourier_le_lt)) + [!tac1;tac_use h; + tac_zero_inf_pos gl + (rational_to_fraction c)]) + else tac1:=(tclTHENS (apply (get coq_Rfourier_le_le)) + [!tac1;tac_use h; + tac_zero_inf_pos gl + (rational_to_fraction c)]))); + s:=(!s)||(h.hstrict)) + lutil; + let tac2= if sres + then tac_zero_inf_false gl (rational_to_fraction cres) + else tac_zero_infeq_false gl (rational_to_fraction cres) + in + tac:=(tclTHENS (my_cut ineq) + [tclTHEN (change_in_concl None + (mkAppL [| get coq_not; ineq|] + )) + (tclTHEN (apply (if sres then get coq_Rnot_lt_lt + else get coq_Rnot_le_le)) + (tclTHENS (Equality.replace + (mkAppL [|get coq_Rminus;!t2;!t1|] + ) + tc) + [tac2; + (tclTHENS + (Equality.replace + (mkApp (get coq_Rinv, + [|get coq_R1|])) + (get coq_R1)) +(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) + + [tclORELSE + (Ring.polynom []) + tclIDTAC; + (tclTHEN (apply (get coq_sym_eqT)) + (apply (get coq_Rinv_1)))] + + ) + ])); + !tac1]); + tac:=(tclTHENS (cut (get coq_False)) + [tclTHEN intro (contradiction None); + !tac]) + |_-> assert false) |_-> assert false + ); +(* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) + (!tac gl) +(* ((tclABSTRACT None !tac) gl) *) + +;; + +(* +let fourier_tac x gl = + fourier gl +;; + +let v_fourier = add_tactic "Fourier" fourier_tac +*) + diff --git a/plugins/fourier/fourier_plugin.mllib b/plugins/fourier/fourier_plugin.mllib new file mode 100644 index 00000000..0383b1a8 --- /dev/null +++ b/plugins/fourier/fourier_plugin.mllib @@ -0,0 +1,4 @@ +Fourier +FourierR +G_fourier +Fourier_plugin_mod diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4 new file mode 100644 index 00000000..b952851f --- /dev/null +++ b/plugins/fourier/g_fourier.ml4 @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ fourier ] +END diff --git a/plugins/fourier/vo.itarget b/plugins/fourier/vo.itarget new file mode 100644 index 00000000..87d82dac --- /dev/null +++ b/plugins/fourier/vo.itarget @@ -0,0 +1,2 @@ +Fourier_util.vo +Fourier.vo diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v new file mode 100644 index 00000000..00302a74 --- /dev/null +++ b/plugins/funind/Recdef.v @@ -0,0 +1,48 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A) -> A -> A := + fun (fl : A -> A) (def : A) => + match n with + | O => def + | S m => fl (iter m fl def) + end. +End Iter. + +Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')). + intro p; intro p'; change (S p <= S (S (p + p'))); + apply le_S; apply Gt.gt_le_S; change (p < S (p + p')); + apply Lt.le_lt_n_Sm; apply Plus.le_plus_l. +Qed. + + +Theorem Splus_lt : forall p p' : nat, p' < S (p + p'). + intro p; intro p'; change (S p' <= S (p + p')); + apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm; + apply Plus.le_plus_r. +Qed. + +Theorem le_lt_SS : forall x y, x <= y -> x < S (S y). +intro x; intro y; intro H; change (S x <= S (S y)); + apply le_S; apply Gt.gt_le_S; change (x < S y); + apply Lt.le_lt_n_Sm; exact H. +Qed. + +Inductive max_type (m n:nat) : Set := + cmt : forall v, m <= v -> n <= v -> max_type m n. + +Definition max : forall m n:nat, max_type m n. +intros m n; case (Compare_dec.le_gt_dec m n). +intros h; exists n; [exact h | apply le_n]. +intros h; exists m; [apply le_n | apply Lt.lt_le_weak; exact h]. +Defined. diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml new file mode 100644 index 00000000..e2cad944 --- /dev/null +++ b/plugins/funind/functional_principles_proofs.ml @@ -0,0 +1,1710 @@ +open Printer +open Util +open Term +open Termops +open Namegen +open Names +open Declarations +open Pp +open Entries +open Hiddentac +open Evd +open Tacmach +open Proof_type +open Tacticals +open Tactics +open Indfun_common +open Libnames + +let msgnl = Pp.msgnl + + +let observe strm = + if do_observe () + then Pp.msgnl strm + else () + +let observennl strm = + if do_observe () + then begin Pp.msg strm;Pp.pp_flush () end + else () + + + + +let do_observe_tac s tac g = + try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v + with e -> + let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + msgnl (str "observation "++ s++str " raised exception " ++ + Cerrors.explain_exn e ++ str " on goal " ++ goal ); + raise e;; + +let observe_tac_stream s tac g = + if do_observe () + then do_observe_tac s tac g + else tac g + +let observe_tac s tac g = observe_tac_stream (str s) tac g + +(* let tclTRYD tac = *) +(* if !Flags.debug || do_observe () *) +(* then (fun g -> try (\* do_observe_tac "" *\)tac g with _ -> tclIDTAC g) *) +(* else tac *) + + +let list_chop ?(msg="") n l = + try + list_chop n l + with Failure (msg') -> + failwith (msg ^ msg') + + +let make_refl_eq constructor type_of_t t = +(* let refl_equal_term = Lazy.force refl_equal in *) + mkApp(constructor,[|type_of_t;t|]) + + +type pte_info = + { + proving_tac : (identifier list -> Tacmach.tactic); + is_valid : constr -> bool + } + +type ptes_info = pte_info Idmap.t + +type 'a dynamic_info = + { + nb_rec_hyps : int; + rec_hyps : identifier list ; + eq_hyps : identifier list; + info : 'a + } + +type body_info = constr dynamic_info + + +let finish_proof dynamic_infos g = + observe_tac "finish" + ( h_assumption) + g + + +let refine c = + Tacmach.refine_no_check c + +let thin l = + Tacmach.thin_no_check l + + +let cut_replacing id t tac :tactic= + tclTHENS (cut t) + [ tclTHEN (thin_no_check [id]) (introduction_no_check id); + tac + ] + +let intro_erasing id = tclTHEN (thin [id]) (introduction id) + + + +let rec_hyp_id = id_of_string "rec_hyp" + +let is_trivial_eq t = + let res = try + begin + match kind_of_term t with + | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> + eq_constr t1 t2 + | App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ()) -> + eq_constr t1 t2 && eq_constr a1 a2 + | _ -> false + end + with _ -> false + in +(* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) + res + +let rec incompatible_constructor_terms t1 t2 = + let c1,arg1 = decompose_app t1 + and c2,arg2 = decompose_app t2 + in + (not (eq_constr t1 t2)) && + isConstruct c1 && isConstruct c2 && + ( + not (eq_constr c1 c2) || + List.exists2 incompatible_constructor_terms arg1 arg2 + ) + +let is_incompatible_eq t = + let res = + try + match kind_of_term t with + | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> + incompatible_constructor_terms t1 t2 + | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) -> + (eq_constr u1 u2 && + incompatible_constructor_terms t1 t2) + | _ -> false + with _ -> false + in + if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t); + res + +let change_hyp_with_using msg hyp_id t tac : tactic = + fun g -> + let prov_id = pf_get_new_id hyp_id g in + tclTHENS + ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac))) + [tclTHENLIST + [ + (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); + (* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id]) + ]] g + +exception TOREMOVE + + +let prove_trivial_eq h_id context (constructor,type_of_term,term) = + let nb_intros = List.length context in + tclTHENLIST + [ + tclDO nb_intros intro; (* introducing context *) + (fun g -> + let context_hyps = + fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) + in + let context_hyps' = + (mkApp(constructor,[|type_of_term;term|])):: + (List.map mkVar context_hyps) + in + let to_refine = applist(mkVar h_id,List.rev context_hyps') in + refine to_refine g + ) + ] + + + +let find_rectype env c = + let (t, l) = decompose_app (Reduction.whd_betadeltaiota env c) in + match kind_of_term t with + | Ind ind -> (t, l) + | Construct _ -> (t,l) + | _ -> raise Not_found + + +let isAppConstruct ?(env=Global.env ()) t = + try + let t',l = find_rectype (Global.env ()) t in + observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist (t',l))); + true + with Not_found -> false + +let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) + let clos_norm_flags flgs env sigma t = + Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in + clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty + + + +let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = + let nochange ?t' msg = + begin + observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t ); + failwith "NoChange"; + end + in + let eq_constr = Reductionops.is_conv env sigma in + if not (noccurn 1 end_of_type) + then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) + if not (isApp t) then nochange "not an equality"; + let f_eq,args = destApp t in + let constructor,t1,t2,t1_typ = + try + if (eq_constr f_eq (Lazy.force eq)) + then + let t1 = (args.(1),args.(0)) + and t2 = (args.(2),args.(0)) + and t1_typ = args.(0) + in + (Lazy.force refl_equal,t1,t2,t1_typ) + else + if (eq_constr f_eq (jmeq ())) + then + (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) + else nochange "not an equality" + with _ -> nochange "not an equality" + in + if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; + let rec compute_substitution sub t1 t2 = +(* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) + if isRel t2 + then + let t2 = destRel t2 in + begin + try + let t1' = Intmap.find t2 sub in + if not (eq_constr t1 t1') then nochange "twice bound variable"; + sub + with Not_found -> + assert (closed0 t1); + Intmap.add t2 t1 sub + end + else if isAppConstruct t1 && isAppConstruct t2 + then + begin + let c1,args1 = find_rectype env t1 + and c2,args2 = find_rectype env t2 + in + if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; + List.fold_left2 compute_substitution sub args1 args2 + end + else + if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2) "cannot solve (diff)" + in + let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in + let sub = compute_substitution sub (fst t1) (fst t2) in + let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) + let new_end_of_type = + (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 + Can be safely replaced by the next comment for Ocaml >= 3.08.4 + *) + let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in + let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in + List.fold_left (fun end_of_type (i,t) -> lift 1 (substnl [t] (i-1) end_of_type)) + end_of_type_with_pop + sub'' + in + let old_context_length = List.length context + 1 in + let witness_fun = + mkLetIn(Anonymous,make_refl_eq constructor t1_typ (fst t1),t, + mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) + ) + in + let new_type_of_hyp,ctxt_size,witness_fun = + list_fold_left_i + (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> + try + let witness = Intmap.find i sub in + if b' <> None then anomaly "can not redefine a rel!"; + (pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun)) + with Not_found -> + (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) + ) + 1 + (new_end_of_type,0,witness_fun) + context + in + let new_type_of_hyp = + Reductionops.nf_betaiota Evd.empty new_type_of_hyp in + let new_ctxt,new_end_of_type = + decompose_prod_n_assum ctxt_size new_type_of_hyp + in + let prove_new_hyp : tactic = + tclTHEN + (tclDO ctxt_size intro) + (fun g -> + let all_ids = pf_ids_of_hyps g in + let new_ids,_ = list_chop ctxt_size all_ids in + let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in + refine to_refine g + ) + in + let simpl_eq_tac = + change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp + in +(* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) +(* str "removing an equation " ++ fnl ()++ *) +(* str "old_typ_of_hyp :=" ++ *) +(* Printer.pr_lconstr_env *) +(* env *) +(* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) +(* ++ fnl () ++ *) +(* str "new_typ_of_hyp := "++ *) +(* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) +(* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) +(* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) +(* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) +(* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) +(* ); *) + new_ctxt,new_end_of_type,simpl_eq_tac + + +let is_property ptes_info t_x full_type_of_hyp = + if isApp t_x + then + let pte,args = destApp t_x in + if isVar pte && array_for_all closed0 args + then + try + let info = Idmap.find (destVar pte) ptes_info in + info.is_valid full_type_of_hyp + with Not_found -> false + else false + else false + +let isLetIn t = + match kind_of_term t with + | LetIn _ -> true + | _ -> false + + +let h_reduce_with_zeta = + h_reduce + (Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) + + + +let rewrite_until_var arg_num eq_ids : tactic = + (* tests if the declares recursive argument is neither a Constructor nor + an applied Constructor since such a form for the recursive argument + will break the Guard when trying to save the Lemma. + *) + let test_var g = + let _,args = destApp (pf_concl g) in + not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num)) + in + let rec do_rewrite eq_ids g = + if test_var g + then tclIDTAC g + else + match eq_ids with + | [] -> anomaly "Cannot find a way to prove recursive property"; + | eq_id::eq_ids -> + tclTHEN + (tclTRY (Equality.rewriteRL (mkVar eq_id))) + (do_rewrite eq_ids) + g + in + do_rewrite eq_ids + + +let rec_pte_id = id_of_string "Hrec" +let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = + let coq_False = Coqlib.build_coq_False () in + let coq_True = Coqlib.build_coq_True () in + let coq_I = Coqlib.build_coq_I () in + let rec scan_type context type_of_hyp : tactic = + if isLetIn type_of_hyp then + let real_type_of_hyp = it_mkProd_or_LetIn ~init:type_of_hyp context in + let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in + (* length of context didn't change ? *) + let new_context,new_typ_of_hyp = + decompose_prod_n_assum (List.length context) reduced_type_of_hyp + in + tclTHENLIST + [ + h_reduce_with_zeta + (Tacticals.onHyp hyp_id) + ; + scan_type new_context new_typ_of_hyp + + ] + else if isProd type_of_hyp + then + begin + let (x,t_x,t') = destProd type_of_hyp in + let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in + if is_property ptes_infos t_x actual_real_type_of_hyp then + begin + let pte,pte_args = (destApp t_x) in + let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in + let prove_new_type_of_hyp = + let context_length = List.length context in + tclTHENLIST + [ + tclDO context_length intro; + (fun g -> + let context_hyps_ids = + fst (list_chop ~msg:"rec hyp : context_hyps" + context_length (pf_ids_of_hyps g)) + in + let rec_pte_id = pf_get_new_id rec_pte_id g in + let to_refine = + applist(mkVar hyp_id, + List.rev_map mkVar (rec_pte_id::context_hyps_ids) + ) + in +(* observe_tac "rec hyp " *) + (tclTHENS + (assert_tac (Name rec_pte_id) t_x) + [ + (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); +(* observe_tac "prove rec hyp" *) + (refine to_refine) + ]) + g + ) + ] + in + tclTHENLIST + [ +(* observe_tac "hyp rec" *) + (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); + scan_type context popped_t' + ] + end + else if eq_constr t_x coq_False then + begin +(* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) +(* str " since it has False in its preconds " *) +(* ); *) + raise TOREMOVE; (* False -> .. useless *) + end + else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) + else if eq_constr t_x coq_True (* Trivial => we remove this precons *) + then +(* observe (str "In "++Ppconstr.pr_id hyp_id++ *) +(* str " removing useless precond True" *) +(* ); *) + let popped_t' = pop t' in + let real_type_of_hyp = + it_mkProd_or_LetIn ~init:popped_t' context + in + let prove_trivial = + let nb_intro = List.length context in + tclTHENLIST [ + tclDO nb_intro intro; + (fun g -> + let context_hyps = + fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) + in + let to_refine = + applist (mkVar hyp_id, + List.rev (coq_I::List.map mkVar context_hyps) + ) + in + refine to_refine g + ) + ] + in + tclTHENLIST[ + change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp + ((* observe_tac "prove_trivial" *) prove_trivial); + scan_type context popped_t' + ] + else if is_trivial_eq t_x + then (* t_x := t = t => we remove this precond *) + let popped_t' = pop t' in + let real_type_of_hyp = + it_mkProd_or_LetIn ~init:popped_t' context + in + let hd,args = destApp t_x in + let get_args hd args = + if eq_constr hd (Lazy.force eq) + then (Lazy.force refl_equal,args.(0),args.(1)) + else (jmeq_refl (),args.(0),args.(1)) + in + tclTHENLIST + [ + change_hyp_with_using + "prove_trivial_eq" + hyp_id + real_type_of_hyp + ((* observe_tac "prove_trivial_eq" *) + (prove_trivial_eq hyp_id context (get_args hd args))); + scan_type context popped_t' + ] + else + begin + try + let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in + tclTHEN + tac + (scan_type new_context new_t') + with Failure "NoChange" -> + (* Last thing todo : push the rel in the context and continue *) + scan_type ((x,None,t_x)::context) t' + end + end + else + tclIDTAC + in + try + scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id] + with TOREMOVE -> + thin [hyp_id],[] + + +let clean_goal_with_heq ptes_infos continue_tac dyn_infos = + fun g -> + let env = pf_env g + and sigma = project g + in + let tac,new_hyps = + List.fold_left ( + fun (hyps_tac,new_hyps) hyp_id -> + let hyp_tac,new_hyp = + clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + in + (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps + ) + (tclIDTAC,[]) + dyn_infos.rec_hyps + in + let new_infos = + { dyn_infos with + rec_hyps = new_hyps; + nb_rec_hyps = List.length new_hyps + } + in + tclTHENLIST + [ + tac ; + (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos) + ] + g + +let heq_id = id_of_string "Heq" + +let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = + fun g -> + let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in + tclTHENLIST + [ + (* We first introduce the variables *) + tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps); + (* Then the equation itself *) + intro_using heq_id; + onLastHypId (fun heq_id -> tclTHENLIST [ + (* Then the new hypothesis *) + tclMAP introduction_no_check dyn_infos.rec_hyps; + (* observe_tac "after_introduction" *)(fun g' -> + (* We get infos on the equations introduced*) + let new_term_value_eq = pf_type_of g' (mkVar heq_id) in + (* compute the new value of the body *) + let new_term_value = + match kind_of_term new_term_value_eq with + | App(f,[| _;_;args2 |]) -> args2 + | _ -> + observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ + pr_lconstr_env (pf_env g') new_term_value_eq + ); + anomaly "cannot compute new term value" + in + let fun_body = + mkLambda(Anonymous, + pf_type_of g' term, + replace_term term (mkRel 1) dyn_infos.info + ) + in + let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in + let new_infos = + {dyn_infos with + info = new_body; + eq_hyps = heq_id::dyn_infos.eq_hyps + } + in + clean_goal_with_heq ptes_infos continue_tac new_infos g' + )]) + ] + g + + +let my_orelse tac1 tac2 g = + try + tac1 g + with e -> +(* observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *) + tac2 g + +let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = + let args = Array.of_list (List.map mkVar args_id) in + let instanciate_one_hyp hid = + my_orelse + ( (* we instanciate the hyp if possible *) + fun g -> + let prov_hid = pf_get_new_id hid g in + tclTHENLIST[ + pose_proof (Name prov_hid) (mkApp(mkVar hid,args)); + thin [hid]; + h_rename [prov_hid,hid] + ] g + ) + ( (* + if not then we are in a mutual function block + and this hyp is a recursive hyp on an other function. + + We are not supposed to use it while proving this + principle so that we can trash it + + *) + (fun g -> +(* observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *) + thin [hid] g + ) + ) + in + if args_id = [] + then + tclTHENLIST [ + tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; + do_prove hyps + ] + else + tclTHENLIST + [ + tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; + tclMAP instanciate_one_hyp hyps; + (fun g -> + let all_g_hyps_id = + List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty + in + let remaining_hyps = + List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps + in + do_prove remaining_hyps g + ) + ] + +let build_proof + (interactive_proof:bool) + (fnames:constant list) + ptes_infos + dyn_infos + : tactic = + let rec build_proof_aux do_finalize dyn_infos : tactic = + fun g -> +(* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) + match kind_of_term dyn_infos.info with + | Case(ci,ct,t,cb) -> + let do_finalize_t dyn_info' = + fun g -> + let t = dyn_info'.info in + let dyn_infos = {dyn_info' with info = + mkCase(ci,ct,t,cb)} in + let g_nb_prod = nb_prod (pf_concl g) in + let type_of_term = pf_type_of g t in + let term_eq = + make_refl_eq (Lazy.force refl_equal) type_of_term t + in + tclTHENSEQ + [ + h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); + thin dyn_infos.rec_hyps; + pattern_option [(false,[1]),t] None; + (fun g -> observe_tac "toto" ( + tclTHENSEQ [h_simplest_case t; + (fun g' -> + let g'_nb_prod = nb_prod (pf_concl g') in + let nb_instanciate_partial = g'_nb_prod - g_nb_prod in + observe_tac "treat_new_case" + (treat_new_case + ptes_infos + nb_instanciate_partial + (build_proof do_finalize) + t + dyn_infos) + g' + ) + + ]) g + ) + ] + g + in + build_proof do_finalize_t {dyn_infos with info = t} g + | Lambda(n,t,b) -> + begin + match kind_of_term( pf_concl g) with + | Prod _ -> + tclTHEN + intro + (fun g' -> + let (id,_,_) = pf_last_hyp g' in + let new_term = + pf_nf_betaiota g' + (mkApp(dyn_infos.info,[|mkVar id|])) + in + let new_infos = {dyn_infos with info = new_term} in + let do_prove new_hyps = + build_proof do_finalize + {new_infos with + rec_hyps = new_hyps; + nb_rec_hyps = List.length new_hyps + } + in +(* observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' + (* build_proof do_finalize new_infos g' *) + ) g + | _ -> + do_finalize dyn_infos g + end + | Cast(t,_,_) -> + build_proof do_finalize {dyn_infos with info = t} g + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> + do_finalize dyn_infos g + | App(_,_) -> + let f,args = decompose_app dyn_infos.info in + begin + match kind_of_term f with + | App _ -> assert false (* we have collected all the app in decompose_app *) + | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> + let new_infos = + { dyn_infos with + info = (f,args) + } + in + build_proof_args do_finalize new_infos g + | Const c when not (List.mem c fnames) -> + let new_infos = + { dyn_infos with + info = (f,args) + } + in +(* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) + build_proof_args do_finalize new_infos g + | Const _ -> + do_finalize dyn_infos g + | Lambda _ -> + let new_term = + Reductionops.nf_beta Evd.empty dyn_infos.info in + build_proof do_finalize {dyn_infos with info = new_term} + g + | LetIn _ -> + let new_infos = + { dyn_infos with info = nf_betaiotazeta dyn_infos.info } + in + + tclTHENLIST + [tclMAP + (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) + dyn_infos.rec_hyps; + h_reduce_with_zeta Tacticals.onConcl; + build_proof do_finalize new_infos + ] + g + | Cast(b,_,_) -> + build_proof do_finalize {dyn_infos with info = b } g + | Case _ | Fix _ | CoFix _ -> + let new_finalize dyn_infos = + let new_infos = + { dyn_infos with + info = dyn_infos.info,args + } + in + build_proof_args do_finalize new_infos + in + build_proof new_finalize {dyn_infos with info = f } g + end + | Fix _ | CoFix _ -> + error ( "Anonymous local (co)fixpoints are not handled yet") + + | Prod _ -> error "Prod" + | LetIn _ -> + let new_infos = + { dyn_infos with + info = nf_betaiotazeta dyn_infos.info + } + in + + tclTHENLIST + [tclMAP + (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) + dyn_infos.rec_hyps; + h_reduce_with_zeta Tacticals.onConcl; + build_proof do_finalize new_infos + ] g + | Rel _ -> anomaly "Free var in goal conclusion !" + and build_proof do_finalize dyn_infos g = +(* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) + observe_tac "build_proof" (build_proof_aux do_finalize dyn_infos) g + and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = + fun g -> + let (f_args',args) = dyn_infos.info in + let tac : tactic = + fun g -> + match args with + | [] -> + do_finalize {dyn_infos with info = f_args'} g + | arg::args -> +(* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) +(* fnl () ++ *) +(* pr_goal (Tacmach.sig_it g) *) +(* ); *) + let do_finalize dyn_infos = + let new_arg = dyn_infos.info in + (* tclTRYD *) + (build_proof_args + do_finalize + {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} + ) + in + build_proof do_finalize + {dyn_infos with info = arg } + g + in + (* observe_tac "build_proof_args" *) (tac ) g + in + let do_finish_proof dyn_infos = + (* tclTRYD *) (clean_goal_with_heq + ptes_infos + finish_proof dyn_infos) + in + (* observe_tac "build_proof" *) + (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) + + + + + + + + + + + + +(* Proof of principles from structural functions *) +let is_pte_type t = + isSort ((strip_prod t)) + +let is_pte (_,_,t) = is_pte_type t + + + + +type static_fix_info = + { + idx : int; + name : identifier; + types : types; + offset : int; + nb_realargs : int; + body_with_param : constr; + num_in_block : int + } + + + +let prove_rec_hyp_for_struct fix_info = + (fun eq_hyps -> tclTHEN + (rewrite_until_var (fix_info.idx) eq_hyps) + (fun g -> + let _,pte_args = destApp (pf_concl g) in + let rec_hyp_proof = + mkApp(mkVar fix_info.name,array_get_start pte_args) + in + refine rec_hyp_proof g + )) + +let prove_rec_hyp fix_info = + { proving_tac = prove_rec_hyp_for_struct fix_info + ; + is_valid = fun _ -> true + } + + +exception Not_Rec + +let generalize_non_dep hyp g = +(* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) + let hyps = [hyp] in + let env = Global.env () in + let hyp_typ = pf_type_of g (mkVar hyp) in + let to_revert,_ = + Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> + if List.mem hyp hyps + or List.exists (occur_var_in_decl env hyp) keep + or occur_var env hyp hyp_typ + or Termops.is_section_variable hyp (* should be dangerous *) + then (clear,decl::keep) + else (hyp::clear,keep)) + ~init:([],[]) (pf_env g) + in +(* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) + tclTHEN + ((* observe_tac "h_generalize" *) (h_generalize (List.map mkVar to_revert) )) + ((* observe_tac "thin" *) (thin to_revert)) + g + +let id_of_decl (na,_,_) = (Nameops.out_name na) +let var_of_decl decl = mkVar (id_of_decl decl) +let revert idl = + tclTHEN + (generalize (List.map mkVar idl)) + (thin idl) + +let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = +(* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) +(* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) +(* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) + let f_def = Global.lookup_constant (destConst f) in + let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in + let f_body = + force (Option.get f_def.const_body) + in + let params,f_body_with_params = decompose_lam_n nb_params f_body in + let (_,num),(_,_,bodies) = destFix f_body_with_params in + let fnames_with_params = + let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in + let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in + fnames + in +(* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) +(* observe (str "body " ++ pr_lconstr bodies.(num)); *) + let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in +(* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) + let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in +(* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) + let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args) + (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in + let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in + let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in + let f_id = id_of_label (con_label (destConst f)) in + let prove_replacement = + tclTHENSEQ + [ + tclDO (nb_params + rec_args_num + 1) intro; + (* observe_tac "" *) (fun g -> + let rec_id = pf_nth_hyp_id g 1 in + tclTHENSEQ + [(* observe_tac "generalize_non_dep in generate_equation_lemma" *) (generalize_non_dep rec_id); + (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Rawterm.NoBindings)); + intros_reflexivity] g + ) + ] + in + Lemmas.start_proof + (*i The next call to mk_equation_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + (mk_equation_id f_id) + (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) + lemma_type + (fun _ _ -> ()); + Pfedit.by (prove_replacement); + Lemmas.save_named false + + + + +let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = + let equation_lemma = + try + let finfos = find_Function_infos (destConst f) in + mkConst (Option.get finfos.equation_lemma) + with (Not_found | Option.IsNone as e) -> + let f_id = id_of_label (con_label (destConst f)) in + (*i The next call to mk_equation_id is valid since we will construct the lemma + Ensures by: obvious + i*) + let equation_lemma_id = (mk_equation_id f_id) in + generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; + let _ = + match e with + | Option.IsNone -> + let finfos = find_Function_infos (destConst f) in + update_Function + {finfos with + equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with + ConstRef c -> c + | _ -> Util.anomaly "Not a constant" + ) + } + | _ -> () + + in + Tacinterp.constr_of_id (pf_env g) equation_lemma_id + in + let nb_intro_to_do = nb_prod (pf_concl g) in + tclTHEN + (tclDO nb_intro_to_do intro) + ( + fun g' -> + let just_introduced = nLastDecls nb_intro_to_do g' in + let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in + tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g' + ) + g + +let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic = + fun g -> + let princ_type = pf_concl g in + let princ_info = compute_elim_sig princ_type in + let fresh_id = + let avoid = ref (pf_ids_of_hyps g) in + (fun na -> + let new_id = + match na with + Name id -> fresh_id !avoid (string_of_id id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + (Name new_id) + ) + in + let fresh_decl = + (fun (na,b,t) -> + (fresh_id na,b,t) + ) + in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params; + predicates = List.map fresh_decl princ_info.predicates; + branches = List.map fresh_decl princ_info.branches; + args = List.map fresh_decl princ_info.args + } + in + let get_body const = + match (Global.lookup_constant const ).const_body with + | Some b -> + let body = force b in + Tacred.cbv_norm_flags + (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + (Global.env ()) + (Evd.empty) + body + | None -> error ( "Cannot define a principle over an axiom ") + in + let fbody = get_body fnames.(fun_num) in + let f_ctxt,f_body = decompose_lam fbody in + let f_ctxt_length = List.length f_ctxt in + let diff_params = princ_info.nparams - f_ctxt_length in + let full_params,princ_params,fbody_with_full_params = + if diff_params > 0 + then + let princ_params,full_params = + list_chop diff_params princ_info.params + in + (full_params, (* real params *) + princ_params, (* the params of the principle which are not params of the function *) + substl (* function instanciated with real params *) + (List.map var_of_decl full_params) + f_body + ) + else + let f_ctxt_other,f_ctxt_params = + list_chop (- diff_params) f_ctxt in + let f_body = compose_lam f_ctxt_other f_body in + (princ_info.params, (* real params *) + [],(* all params are full params *) + substl (* function instanciated with real params *) + (List.map var_of_decl princ_info.params) + f_body + ) + in +(* observe (str "full_params := " ++ *) +(* prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *) +(* full_params *) +(* ); *) +(* observe (str "princ_params := " ++ *) +(* prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *) +(* princ_params *) +(* ); *) +(* observe (str "fbody_with_full_params := " ++ *) +(* pr_lconstr fbody_with_full_params *) +(* ); *) + let all_funs_with_full_params = + Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs + in + let fix_offset = List.length princ_params in + let ptes_to_fix,infos = + match kind_of_term fbody_with_full_params with + | Fix((idxs,i),(names,typess,bodies)) -> + let bodies_with_all_params = + Array.map + (fun body -> + Reductionops.nf_betaiota Evd.empty + (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, + List.rev_map var_of_decl princ_params)) + ) + bodies + in + let info_array = + Array.mapi + (fun i types -> + let types = prod_applist types (List.rev_map var_of_decl princ_params) in + { idx = idxs.(i) - fix_offset; + name = Nameops.out_name (fresh_id names.(i)); + types = types; + offset = fix_offset; + nb_realargs = + List.length + (fst (decompose_lam bodies.(i))) - fix_offset; + body_with_param = bodies_with_all_params.(i); + num_in_block = i + } + ) + typess + in + let pte_to_fix,rev_info = + list_fold_left_i + (fun i (acc_map,acc_info) (pte,_,_) -> + let infos = info_array.(i) in + let type_args,_ = decompose_prod infos.types in + let nargs = List.length type_args in + let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in + let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in + let app_f = mkApp(f,first_args) in + let pte_args = (Array.to_list first_args)@[app_f] in + let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in + let body_with_param,num = + let body = get_body fnames.(i) in + let body_with_full_params = + Reductionops.nf_betaiota Evd.empty ( + applist(body,List.rev_map var_of_decl full_params)) + in + match kind_of_term body_with_full_params with + | Fix((_,num),(_,_,bs)) -> + Reductionops.nf_betaiota Evd.empty + ( + (applist + (substl + (List.rev + (Array.to_list all_funs_with_full_params)) + bs.(num), + List.rev_map var_of_decl princ_params)) + ),num + | _ -> error "Not a mutual block" + in + let info = + {infos with + types = compose_prod type_args app_pte; + body_with_param = body_with_param; + num_in_block = num + } + in +(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) +(* str " to " ++ Ppconstr.pr_id info.name); *) + (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info) + ) + 0 + (Idmap.empty,[]) + (List.rev princ_info.predicates) + in + pte_to_fix,List.rev rev_info + | _ -> Idmap.empty,[] + in + let mk_fixes : tactic = + let pre_info,infos = list_chop fun_num infos in + match pre_info,infos with + | [],[] -> tclIDTAC + | _, this_fix_info::others_infos -> + let other_fix_infos = + List.map + (fun fi -> fi.name,fi.idx + 1 ,fi.types) + (pre_info@others_infos) + in + if other_fix_infos = [] + then + (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1)) + else + h_mutual_fix false this_fix_info.name (this_fix_info.idx + 1) + other_fix_infos + | _ -> anomaly "Not a valid information" + in + let first_tac : tactic = (* every operations until fix creations *) + tclTHENSEQ + [ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params)); + (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates)); + (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches)); + (* observe_tac "building fixes" *) mk_fixes; + ] + in + let intros_after_fixes : tactic = + fun gl -> + let ctxt,pte_app = (decompose_prod_assum (pf_concl gl)) in + let pte,pte_args = (decompose_app pte_app) in + try + let pte = try destVar pte with _ -> anomaly "Property is not a variable" in + let fix_info = Idmap.find pte ptes_to_fix in + let nb_args = fix_info.nb_realargs in + tclTHENSEQ + [ + (* observe_tac ("introducing args") *) (tclDO nb_args intro); + (fun g -> (* replacement of the function by its body *) + let args = nLastDecls nb_args g in + let fix_body = fix_info.body_with_param in +(* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) + let args_id = List.map (fun (id,_,_) -> id) args in + let dyn_infos = + { + nb_rec_hyps = -100; + rec_hyps = []; + info = + Reductionops.nf_betaiota Evd.empty + (applist(fix_body,List.rev_map mkVar args_id)); + eq_hyps = [] + } + in + tclTHENSEQ + [ +(* observe_tac "do_replace" *) + (do_replace + full_params + (fix_info.idx + List.length princ_params) + (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params)) + (all_funs.(fix_info.num_in_block)) + fix_info.num_in_block + all_funs + ); +(* observe_tac "do_replace" *) +(* (do_replace princ_info.params fix_info.idx args_id *) +(* (List.hd (List.rev pte_args)) fix_body); *) + let do_prove = + build_proof + interactive_proof + (Array.to_list fnames) + (Idmap.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + {dyn_infos with + rec_hyps = branches; + nb_rec_hyps = List.length branches + } + in + observe_tac "cleaning" (clean_goal_with_heq + (Idmap.map prove_rec_hyp ptes_to_fix) + do_prove + dyn_infos) + in +(* observe (str "branches := " ++ *) +(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) +(* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) + +(* ); *) + (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) + ] + g + ); + ] gl + with Not_found -> + let nb_args = min (princ_info.nargs) (List.length ctxt) in + tclTHENSEQ + [ + tclDO nb_args intro; + (fun g -> (* replacement of the function by its body *) + let args = nLastDecls nb_args g in + let args_id = List.map (fun (id,_,_) -> id) args in + let dyn_infos = + { + nb_rec_hyps = -100; + rec_hyps = []; + info = + Reductionops.nf_betaiota Evd.empty + (applist(fbody_with_full_params, + (List.rev_map var_of_decl princ_params)@ + (List.rev_map mkVar args_id) + )); + eq_hyps = [] + } + in + let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in + tclTHENSEQ + [unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)]; + let do_prove = + build_proof + interactive_proof + (Array.to_list fnames) + (Idmap.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + {dyn_infos with + rec_hyps = branches; + nb_rec_hyps = List.length branches + } + in + clean_goal_with_heq + (Idmap.map prove_rec_hyp ptes_to_fix) + do_prove + dyn_infos + in + instanciate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id) + ] + g + ) + ] + gl + in + tclTHEN + first_tac + intros_after_fixes + g + + + + + + +(* Proof of principles of general functions *) +let h_id = Recdef.h_id +and hrec_id = Recdef.hrec_id +and acc_inv_id = Recdef.acc_inv_id +and ltof_ref = Recdef.ltof_ref +and acc_rel = Recdef.acc_rel +and well_founded = Recdef.well_founded +and delayed_force = Recdef.delayed_force +and h_intros = Recdef.h_intros +and list_rewrite = Recdef.list_rewrite +and evaluable_of_global_reference = Recdef.evaluable_of_global_reference + + + + + +let prove_with_tcc tcc_lemma_constr eqs : tactic = + match !tcc_lemma_constr with + | None -> anomaly "No tcc proof !!" + | Some lemma -> + fun gls -> +(* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) +(* let ids = hid::pf_ids_of_hyps gls in *) + tclTHENSEQ + [ +(* generalize [lemma]; *) +(* h_intro hid; *) +(* Elim.h_decompose_and (mkVar hid); *) + tclTRY(list_rewrite true eqs); +(* (fun g -> *) +(* let ids' = pf_ids_of_hyps g in *) +(* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) +(* rewrite *) +(* ) *) + Eauto.gen_eauto false (false,5) [] (Some []) + ] + gls + + +let backtrack_eqs_until_hrec hrec eqs : tactic = + fun gls -> + let eqs = List.map mkVar eqs in + let rewrite = + tclFIRST (List.map Equality.rewriteRL eqs ) + in + let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in + let f_app = array_last (snd (destApp hrec_concl)) in + let f = (fst (destApp f_app)) in + let rec backtrack : tactic = + fun g -> + let f_app = array_last (snd (destApp (pf_concl g))) in + match kind_of_term f_app with + | App(f',_) when eq_constr f' f -> tclIDTAC g + | _ -> tclTHEN rewrite backtrack g + in + backtrack gls + + + +let build_clause eqs = + { + Tacexpr.onhyps = + Some (List.map + (fun id -> (Rawterm.all_occurrences_expr,id),InHyp) + eqs + ); + Tacexpr.concl_occs = Rawterm.no_occurrences_expr + } + +let rec rewrite_eqs_in_eqs eqs = + match eqs with + | [] -> tclIDTAC + | eq::eqs -> + + tclTHEN + (tclMAP + (fun id gl -> + observe_tac + (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id)) + (tclTRY (Equality.general_rewrite_in true all_occurrences (* dep proofs also: *) true id (mkVar eq) false)) + gl + ) + eqs + ) + (rewrite_eqs_in_eqs eqs) + +let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = + fun gls -> + (tclTHENSEQ + [ + backtrack_eqs_until_hrec hrec eqs; + (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *) + (tclTHENS (* We must have exactly ONE subgoal !*) + (apply (mkVar hrec)) + [ tclTHENSEQ + [ + keep (tcc_hyps@eqs); + apply (Lazy.force acc_inv); + (fun g -> + if is_mes + then + unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g + else tclIDTAC g + ); + observe_tac "rew_and_finish" + (tclTHENLIST + [tclTRY(Recdef.list_rewrite false (List.map mkVar eqs)); + observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); + (observe_tac "finishing using" + ( + tclCOMPLETE( + Eauto.eauto_with_bases + false + (true,5) + [Lazy.force refl_equal] + [Auto.Hint_db.empty empty_transparent_state false] + ) + ) + ) + ] + ) + ] + ]) + ]) + gls + + +let is_valid_hypothesis predicates_name = + let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in + let is_pte typ = + if isApp typ + then + let pte,_ = destApp typ in + if isVar pte + then Idset.mem (destVar pte) predicates_name + else false + else false + in + let rec is_valid_hypothesis typ = + is_pte typ || + match kind_of_term typ with + | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' + | _ -> false + in + is_valid_hypothesis + +let prove_principle_for_gen + (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes + rec_arg_num rec_arg_type relation gl = + let princ_type = pf_concl gl in + let princ_info = compute_elim_sig princ_type in + let fresh_id = + let avoid = ref (pf_ids_of_hyps gl) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (string_of_id id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + Name new_id + in + let fresh_decl (na,b,t) = (fresh_id na,b,t) in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params; + predicates = List.map fresh_decl princ_info.predicates; + branches = List.map fresh_decl princ_info.branches; + args = List.map fresh_decl princ_info.args + } + in + let wf_tac = + if is_mes + then + (fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None) + else fun _ -> prove_with_tcc tcc_lemma_ref [] + in + let real_rec_arg_num = rec_arg_num - princ_info.nparams in + let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in +(* observe ( *) +(* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) +(* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) + +(* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) +(* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) +(* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) +(* str "npost_rec_arg := " ++ int npost_rec_arg ); *) + let (post_rec_arg,pre_rec_arg) = + Util.list_chop npost_rec_arg princ_info.args + in + let rec_arg_id = + match List.rev post_rec_arg with + | (Name id,_,_)::_ -> id + | _ -> assert false + in +(* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) + let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in + let relation = substl subst_constrs relation in + let input_type = substl subst_constrs rec_arg_type in + let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in + let acc_rec_arg_id = + Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id))))) + in + let revert l = + tclTHEN (h_generalize (List.map mkVar l)) (clear l) + in + let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in + let prove_rec_arg_acc g = + ((* observe_tac "prove_rec_arg_acc" *) + (tclCOMPLETE + (tclTHEN + (assert_by (Name wf_thm_id) + (mkApp (delayed_force well_founded,[|input_type;relation|])) + (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)) + ( + (* observe_tac *) +(* "apply wf_thm" *) + h_simplest_apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|])) + ) + ) + ) + ) + g + in + let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in + let lemma = + match !tcc_lemma_ref with + | None -> anomaly ( "No tcc proof !!") + | Some lemma -> lemma + in +(* let rec list_diff del_list check_list = *) +(* match del_list with *) +(* [] -> *) +(* [] *) +(* | f::r -> *) +(* if List.mem f check_list then *) +(* list_diff r check_list *) +(* else *) +(* f::(list_diff r check_list) *) +(* in *) + let tcc_list = ref [] in + let start_tac gls = + let hyps = pf_ids_of_hyps gls in + let hid = + next_ident_away_in_goal + (id_of_string "prov") + hyps + in + tclTHENSEQ + [ + generalize [lemma]; + h_intro hid; + Elim.h_decompose_and (mkVar hid); + (fun g -> + let new_hyps = pf_ids_of_hyps g in + tcc_list := List.rev (list_subtract new_hyps (hid::hyps)); + if !tcc_list = [] + then + begin + tcc_list := [hid]; + tclIDTAC g + end + else thin [hid] g + ) + ] + gls + in + tclTHENSEQ + [ + observe_tac "start_tac" start_tac; + h_intros + (List.rev_map (fun (na,_,_) -> Nameops.out_name na) + (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) + ); + (* observe_tac "" *) (assert_by + (Name acc_rec_arg_id) + (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) + (prove_rec_arg_acc) + ); +(* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); +(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) +(* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) + (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1)); +(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *) + h_intros (List.rev (acc_rec_arg_id::args_ids)); + Equality.rewriteLR (mkConst eq_ref); + (* observe_tac "finish" *) (fun gl' -> + let body = + let _,args = destApp (pf_concl gl') in + array_last args + in + let body_info rec_hyps = + { + nb_rec_hyps = List.length rec_hyps; + rec_hyps = rec_hyps; + eq_hyps = []; + info = body + } + in + let acc_inv = + lazy ( + mkApp ( + delayed_force acc_inv_id, + [|input_type;relation;mkVar rec_arg_id|] + ) + ) + in + let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in + let predicates_names = + List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates + in + let pte_info = + { proving_tac = + (fun eqs -> +(* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) +(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *) +(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *) +(* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) +(* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) + + (* observe_tac "new_prove_with_tcc" *) + (new_prove_with_tcc + is_mes acc_inv fix_id + + (!tcc_list@(List.map + (fun (na,_,_) -> (Nameops.out_name na)) + (princ_info.args@princ_info.params) + )@ ([acc_rec_arg_id])) eqs + ) + + ); + is_valid = is_valid_hypothesis predicates_names + } + in + let ptes_info : pte_info Idmap.t = + List.fold_left + (fun map pte_id -> + Idmap.add pte_id + pte_info + map + ) + Idmap.empty + predicates_names + in + let make_proof rec_hyps = + build_proof + false + [f_ref] + ptes_info + (body_info rec_hyps) + in + (* observe_tac "instanciate_hyps_with_args" *) + (instanciate_hyps_with_args + make_proof + (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches) + (List.rev args_ids) + ) + gl' + ) + + ] + gl + + + + + + + + diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli new file mode 100644 index 00000000..ff98f2b9 --- /dev/null +++ b/plugins/funind/functional_principles_proofs.mli @@ -0,0 +1,19 @@ +open Names +open Term + +val prove_princ_for_struct : + bool -> + int -> constant array -> constr array -> int -> Tacmach.tactic + + +val prove_principle_for_gen : + constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *) + constr option ref -> (* a pointer to the obligation proofs lemma *) + bool -> (* is that function uses measure *) + int -> (* the number of recursive argument *) + types -> (* the type of the recursive argument *) + constr -> (* the wf relation used to prove the function *) + Tacmach.tactic + + +(* val is_pte : rel_declaration -> bool *) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml new file mode 100644 index 00000000..b756492b --- /dev/null +++ b/plugins/funind/functional_principles_types.ml @@ -0,0 +1,737 @@ +open Printer +open Util +open Term +open Termops +open Namegen +open Names +open Declarations +open Pp +open Entries +open Hiddentac +open Evd +open Tacmach +open Proof_type +open Tacticals +open Tactics +open Indfun_common +open Functional_principles_proofs + +exception Toberemoved_with_rel of int*constr +exception Toberemoved + + +let pr_elim_scheme el = + let env = Global.env () in + let msg = str "params := " ++ Printer.pr_rel_context env el.params in + let env = Environ.push_rel_context el.params env in + let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in + let env = Environ.push_rel_context el.predicates env in + let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in + let env = Environ.push_rel_context el.branches env in + let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in + let env = Environ.push_rel_context el.args env in + msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl + + +let observe s = + if do_observe () + then Pp.msgnl s + + +let pr_elim_scheme el = + let env = Global.env () in + let msg = str "params := " ++ Printer.pr_rel_context env el.params in + let env = Environ.push_rel_context el.params env in + let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in + let env = Environ.push_rel_context el.predicates env in + let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in + let env = Environ.push_rel_context el.branches env in + let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in + let env = Environ.push_rel_context el.args env in + msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl + + +let observe s = + if do_observe () + then Pp.msgnl s + +(* + Transform an inductive induction principle into + a functional one +*) +let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = + let princ_type_info = compute_elim_sig princ_type in + let env = Global.env () in + let env_with_params = Environ.push_rel_context princ_type_info.params env in + let tbl = Hashtbl.create 792 in + let rec change_predicates_names (avoid:identifier list) (predicates:rel_context) : rel_context = + match predicates with + | [] -> [] + |(Name x,v,t)::predicates -> + let id = Namegen.next_ident_away x avoid in + Hashtbl.add tbl id x; + (Name id,v,t)::(change_predicates_names (id::avoid) predicates) + | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder " + in + let avoid = (Termops.ids_of_context env_with_params ) in + let princ_type_info = + { princ_type_info with + predicates = change_predicates_names avoid princ_type_info.predicates + } + in +(* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) +(* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) + let change_predicate_sort i (x,_,t) = + let new_sort = sorts.(i) in + let args,_ = decompose_prod t in + let real_args = + if princ_type_info.indarg_in_concl + then List.tl args + else args + in + Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) + in + let new_predicates = + list_map_i + change_predicate_sort + 0 + princ_type_info.predicates + in + let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in + let rel_as_kn = + fst (match princ_type_info.indref with + | Some (Libnames.IndRef ind) -> ind + | _ -> error "Not a valid predicate" + ) + in + let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in + let is_pte = + let set = List.fold_right Idset.add ptes_vars Idset.empty in + fun t -> + match kind_of_term t with + | Var id -> Idset.mem id set + | _ -> false + in + let pre_princ = + it_mkProd_or_LetIn + ~init: + (it_mkProd_or_LetIn + ~init:(Option.fold_right + mkProd_or_LetIn + princ_type_info.indarg + princ_type_info.concl + ) + princ_type_info.args + ) + princ_type_info.branches + in + let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in + let is_dom c = + match kind_of_term c with + | Ind((u,_)) -> u = rel_as_kn + | Construct((u,_),_) -> u = rel_as_kn + | _ -> false + in + let get_fun_num c = + match kind_of_term c with + | Ind(_,num) -> num + | Construct((_,num),_) -> num + | _ -> assert false + in + let dummy_var = mkVar (id_of_string "________") in + let mk_replacement c i args = + let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in +(* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *) + res + in + let rec has_dummy_var t = + fold_constr + (fun b t -> b || (eq_constr t dummy_var) || (has_dummy_var t)) + false + t + in + let rec compute_new_princ_type remove env pre_princ : types*(constr list) = + let (new_princ_type,_) as res = + match kind_of_term pre_princ with + | Rel n -> + begin + try match Environ.lookup_rel n env with + | _,_,t when is_dom t -> raise Toberemoved + | _ -> pre_princ,[] with Not_found -> assert false + end + | Prod(x,t,b) -> + compute_new_princ_type_for_binder remove mkProd env x t b + | Lambda(x,t,b) -> + compute_new_princ_type_for_binder remove mkLambda env x t b + | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved + | App(f,args) when is_dom f -> + let var_to_be_removed = destRel (array_last args) in + let num = get_fun_num f in + raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) + | App(f,args) -> + let args = + if is_pte f && remove + then array_get_start args + else args + in + let new_args,binders_to_remove = + Array.fold_right (compute_new_princ_type_with_acc remove env) + args + ([],[]) + in + let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in + applist(new_f, new_args), + list_union_eq eq_constr binders_to_remove_from_f binders_to_remove + | LetIn(x,v,t,b) -> + compute_new_princ_type_for_letin remove env x v t b + | _ -> pre_princ,[] + in +(* let _ = match kind_of_term pre_princ with *) +(* | Prod _ -> *) +(* observe(str "compute_new_princ_type for "++ *) +(* pr_lconstr_env env pre_princ ++ *) +(* str" is "++ *) +(* pr_lconstr_env env new_princ_type ++ fnl ()) *) +(* | _ -> () in *) + res + + and compute_new_princ_type_for_binder remove bind_fun env x t b = + begin + try + let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in + let new_x : name = get_name (ids_of_context env) x in + let new_env = Environ.push_rel (x,None,t) env in + let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in + if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b + then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b + else + ( + bind_fun(new_x,new_t,new_b), + list_union_eq + eq_constr + binders_to_remove_from_t + (List.map pop binders_to_remove_from_b) + ) + + with + | Toberemoved -> +(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in + new_b, List.map pop binders_to_remove_from_b + | Toberemoved_with_rel (n,c) -> +(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in + new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) + end + and compute_new_princ_type_for_letin remove env x v t b = + begin + try + let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in + let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in + let new_x : name = get_name (ids_of_context env) x in + let new_env = Environ.push_rel (x,Some v,t) env in + let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in + if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b + then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b + else + ( + mkLetIn(new_x,new_v,new_t,new_b), + list_union_eq + eq_constr + (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) + (List.map pop binders_to_remove_from_b) + ) + + with + | Toberemoved -> +(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in + new_b, List.map pop binders_to_remove_from_b + | Toberemoved_with_rel (n,c) -> +(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in + new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) + end + and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = + let new_e,to_remove_from_e = compute_new_princ_type remove env e + in + new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc + in +(* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) + let pre_res,_ = + compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ + in + let pre_res = + replace_vars + (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars) + (lift (List.length ptes_vars) pre_res) + in + it_mkProd_or_LetIn + ~init:(it_mkProd_or_LetIn + ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) + new_predicates) + ) + princ_type_info.params + + + +let change_property_sort toSort princ princName = + let princ_info = compute_elim_sig princ in + let change_sort_in_predicate (x,v,t) = + (x,None, + let args,_ = decompose_prod t in + compose_prod args (mkSort toSort) + ) + in + let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in + let init = + let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in + mkApp(princName_as_constr, + Array.init nargs + (fun i -> mkRel (nargs - i ))) + in + it_mkLambda_or_LetIn + ~init: + (it_mkLambda_or_LetIn ~init + (List.map change_sort_in_predicate princ_info.predicates) + ) + princ_info.params + + +let pp_dur time time' = + str (string_of_float (System.time_difference time time')) + +(* let qed () = save_named true *) +let defined () = + try + Lemmas.save_named false + with + | UserError("extract_proof",msg) -> + Util.errorlabstrm + "defined" + ((try + str "On goal : " ++ fnl () ++ pr_open_subgoals () ++ fnl () + with _ -> mt () + ) ++msg) + | e -> raise e + + + +let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook = + (* First we get the type of the old graph principle *) + let mutr_nparams = (compute_elim_sig old_princ_type).nparams in + (* let time1 = System.get_time () in *) + let new_principle_type = + compute_new_princ_type_from_rel + (Array.map mkConst funs) + sorts + old_princ_type + in + (* let time2 = System.get_time () in *) + (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) + observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); + let new_princ_name = + next_ident_away_in_goal (id_of_string "___________princ_________") [] + in + begin + Lemmas.start_proof + new_princ_name + (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) + new_principle_type + (hook new_principle_type) + ; + (* let _tim1 = System.get_time () in *) + Pfedit.by (proof_tac (Array.map mkConst funs) mutr_nparams); + (* let _tim2 = System.get_time () in *) + (* begin *) + (* let dur1 = System.time_difference tim1 tim2 in *) + (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) + (* end; *) + get_proof_clean true + end + + + +let generate_functional_principle + interactive_proof + old_princ_type sorts new_princ_name funs i proof_tac + = + try + + let f = funs.(i) in + let type_sort = Termops.new_sort_in_family InType in + let new_sorts = + match sorts with + | None -> Array.make (Array.length funs) (type_sort) + | Some a -> a + in + let base_new_princ_name,new_princ_name = + match new_princ_name with + | Some (id) -> id,id + | None -> + let id_of_f = id_of_label (con_label f) in + id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) + in + let names = ref [new_princ_name] in + let hook new_principle_type _ _ = + if sorts = None + then + (* let id_of_f = id_of_label (con_label f) in *) + let register_with_sort fam_sort = + let s = Termops.new_sort_in_family fam_sort in + let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in + let value = change_property_sort s new_principle_type new_princ_name in + (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let ce = + { const_entry_body = value; + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = Flags.boxed_definitions() + } + in + ignore( + Declare.declare_constant + name + (Entries.DefinitionEntry ce, + Decl_kinds.IsDefinition (Decl_kinds.Scheme) + ) + ); + Flags.if_verbose + (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) + name; + names := name :: !names + in + register_with_sort InProp; + register_with_sort InSet + in + let (id,(entry,g_kind,hook)) = + build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook + in + (* Pr 1278 : + Don't forget to close the goal if an error is raised !!!! + *) + save false new_princ_name entry g_kind hook + with e -> + begin + begin + try + let id = Pfedit.get_current_proof_name () in + let s = string_of_id id in + let n = String.length "___________princ_________" in + if String.length s >= n + then if String.sub s 0 n = "___________princ_________" + then Pfedit.delete_current_proof () + else () + else () + with _ -> () + end; + raise (Defining_principle e) + end +(* defined () *) + + +exception Not_Rec + +let get_funs_constant mp dp = + let rec get_funs_constant const e : (Names.constant*int) array = + match kind_of_term ((strip_lam e)) with + | Fix((_,(na,_,_))) -> + Array.mapi + (fun i na -> + match na with + | Name id -> + let const = make_con mp dp (label_of_id id) in + const,i + | Anonymous -> + anomaly "Anonymous fix" + ) + na + | _ -> [|const,0|] + in + function const -> + let find_constant_body const = + match (Global.lookup_constant const ).const_body with + | Some b -> + let body = force b in + let body = Tacred.cbv_norm_flags + (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + (Global.env ()) + (Evd.empty) + body + in + body + | None -> error ( "Cannot define a principle over an axiom ") + in + let f = find_constant_body const in + let l_const = get_funs_constant const f in + (* + We need to check that all the functions found are in the same block + to prevent Reset stange thing + *) + let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in + let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in + (* all the paremeter must be equal*) + let _check_params = + let first_params = List.hd l_params in + List.iter + (fun params -> + if not ((=) first_params params) + then error "Not a mutal recursive block" + ) + l_params + in + (* The bodies has to be very similar *) + let _check_bodies = + try + let extract_info is_first body = + match kind_of_term body with + | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) + | _ -> + if is_first && (List.length l_bodies = 1) + then raise Not_Rec + else error "Not a mutal recursive block" + in + let first_infos = extract_info true (List.hd l_bodies) in + let check body = (* Hope this is correct *) + if not (first_infos = (extract_info false body)) + then error "Not a mutal recursive block" + in + List.iter check l_bodies + with Not_Rec -> () + in + l_const + +exception No_graph_found +exception Found_type of int + +let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list = + let env = Global.env () + and sigma = Evd.empty in + let funs = List.map fst fas in + let first_fun = List.hd funs in + + + let funs_mp,funs_dp,_ = Names.repr_con first_fun in + let first_fun_kn = + try + fst (find_Function_infos first_fun).graph_ind + with Not_found -> raise No_graph_found + in + let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in + let this_block_funs = Array.map fst this_block_funs_indexes in + let prop_sort = InProp in + let funs_indexes = + let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + List.map + (function const -> List.assoc const this_block_funs_indexes) + funs + in + let ind_list = + List.map + (fun (idx) -> + let ind = first_fun_kn,idx in + ind,true,prop_sort + ) + funs_indexes + in + let l_schemes = + List.map + (Typing.type_of env sigma) + (Indrec.build_mutual_induction_scheme env sigma ind_list) + in + let i = ref (-1) in + let sorts = + List.rev_map (fun (_,x) -> + Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) + ) + fas + in + (* We create the first priciple by tactic *) + let first_type,other_princ_types = + match l_schemes with + s::l_schemes -> s,l_schemes + | _ -> anomaly "" + in + let (_,(const,_,_)) = + try + build_functional_principle false + first_type + (Array.of_list sorts) + this_block_funs + 0 + (prove_princ_for_struct false 0 (Array.of_list funs)) + (fun _ _ _ -> ()) + with e -> + begin + begin + try + let id = Pfedit.get_current_proof_name () in + let s = string_of_id id in + let n = String.length "___________princ_________" in + if String.length s >= n + then if String.sub s 0 n = "___________princ_________" + then Pfedit.delete_current_proof () + else () + else () + with _ -> () + end; + raise (Defining_principle e) + end + + in + incr i; + let opacity = + let finfos = find_Function_infos this_block_funs.(0) in + try + let equation = Option.get finfos.equation_lemma in + (Global.lookup_constant equation).Declarations.const_opaque + with Option.IsNone -> (* non recursive definition *) + false + in + let const = {const with const_entry_opaque = opacity } in + (* The others are just deduced *) + if other_princ_types = [] + then + [const] + else + let other_fun_princ_types = + let funs = Array.map mkConst this_block_funs in + let sorts = Array.of_list sorts in + List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types + in + let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in + let ctxt,fix = decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*) + let (idxs,_),(_,ta,_ as decl) = destFix fix in + let other_result = + List.map (* we can now compute the other principles *) + (fun scheme_type -> + incr i; + observe (Printer.pr_lconstr scheme_type); + let type_concl = (strip_prod_assum scheme_type) in + let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in + let f = fst (decompose_app applied_f) in + try (* we search the number of the function in the fix block (name of the function) *) + Array.iteri + (fun j t -> + let t = (strip_prod_assum t) in + let applied_g = List.hd (List.rev (snd (decompose_app t))) in + let g = fst (decompose_app applied_g) in + if eq_constr f g + then raise (Found_type j); + observe (Printer.pr_lconstr f ++ str " <> " ++ + Printer.pr_lconstr g) + + ) + ta; + (* If we reach this point, the two principle are not mutually recursive + We fall back to the previous method + *) + let (_,(const,_,_)) = + build_functional_principle + false + (List.nth other_princ_types (!i - 1)) + (Array.of_list sorts) + this_block_funs + !i + (prove_princ_for_struct false !i (Array.of_list funs)) + (fun _ _ _ -> ()) + in + const + with Found_type i -> + let princ_body = + Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt + in + {const with + Entries.const_entry_body = princ_body; + Entries.const_entry_type = Some scheme_type + } + ) + other_fun_princ_types + in + const::other_result + +let build_scheme fas = + Dumpglob.pause (); + let bodies_types = + make_scheme + (List.map + (fun (_,f,sort) -> + let f_as_constant = + try + match Nametab.global f with + | Libnames.ConstRef c -> c + | _ -> Util.error "Functional Scheme can only be used with functions" + with Not_found -> + Util.error ("Cannot find "^ Libnames.string_of_reference f) + in + (f_as_constant,sort) + ) + fas + ) + in + List.iter2 + (fun (princ_id,_,_) def_entry -> + ignore + (Declare.declare_constant + princ_id + (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); + Flags.if_verbose + (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id + ) + fas + bodies_types; + Dumpglob.continue () + + + +let build_case_scheme fa = + let env = Global.env () + and sigma = Evd.empty in +(* let id_to_constr id = *) +(* Tacinterp.constr_of_id env id *) +(* in *) + let funs = (fun (_,f,_) -> + try Libnames.constr_of_global (Nametab.global f) + with Not_found -> + Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in + let first_fun = destConst funs in + + let funs_mp,funs_dp,_ = Names.repr_con first_fun in + let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in + + + + let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in + let this_block_funs = Array.map fst this_block_funs_indexes in + let prop_sort = InProp in + let funs_indexes = + let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + List.assoc (destConst funs) this_block_funs_indexes + in + let ind_fun = + let ind = first_fun_kn,funs_indexes in + ind,prop_sort + in + let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun) in + let sorts = + (fun (_,_,x) -> + Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) + ) + fa + in + let princ_name = (fun (x,_,_) -> x) fa in + let _ = + (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ + pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs + ); + *) + generate_functional_principle + false + scheme_type + (Some ([|sorts|])) + (Some princ_name) + this_block_funs + 0 + (prove_princ_for_struct false 0 [|destConst funs|]) + in + () diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli new file mode 100644 index 00000000..fb04c6ec --- /dev/null +++ b/plugins/funind/functional_principles_types.mli @@ -0,0 +1,34 @@ +open Names +open Term + + +val generate_functional_principle : + (* do we accept interactive proving *) + bool -> + (* induction principle on rel *) + types -> + (* *) + sorts array option -> + (* Name of the new principle *) + (identifier) option -> + (* the compute functions to use *) + constant array -> + (* We prove the nth- principle *) + int -> + (* The tactic to use to make the proof w.r + the number of params + *) + (constr array -> int -> Tacmach.tactic) -> + unit + +val compute_new_princ_type_from_rel : constr array -> sorts array -> + types -> types + + +exception No_graph_found + +val make_scheme : (constant*Rawterm.rawsort) list -> Entries.definition_entry list + +val build_scheme : (identifier*Libnames.reference*Rawterm.rawsort) list -> unit +val build_case_scheme : (identifier*Libnames.reference*Rawterm.rawsort) -> unit + diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 new file mode 100644 index 00000000..bc400ae1 --- /dev/null +++ b/plugins/funind/g_indfun.ml4 @@ -0,0 +1,524 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) + | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) + +let pr_bindings prc prlc = function + | Rawterm.ImplicitBindings l -> + brk (1,1) ++ str "with" ++ brk (1,1) ++ + Util.prlist_with_sep spc prc l + | Rawterm.ExplicitBindings l -> + brk (1,1) ++ str "with" ++ brk (1,1) ++ + Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l + | Rawterm.NoBindings -> mt () + +let pr_with_bindings prc prlc (c,bl) = + prc c ++ hv 0 (pr_bindings prc prlc bl) + +let pr_fun_ind_using prc prlc _ opt_c = + match opt_c with + | None -> mt () + | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc b) + +(* Duplication of printing functions because "'a with_bindings" is + (internally) not uniform in 'a: indeed constr_with_bindings at the + "typed" level has type "open_constr with_bindings" instead of + "constr with_bindings"; hence, its printer cannot be polymorphic in + (prc,prlc)... *) + +let pr_with_bindings_typed prc prlc (c,bl) = + prc c ++ + hv 0 (pr_bindings prc prlc bl) + +let pr_fun_ind_using_typed prc prlc _ opt_c = + match opt_c with + | None -> mt () + | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b.Evd.it) + + +ARGUMENT EXTEND fun_ind_using + TYPED AS constr_with_bindings_opt + PRINTED BY pr_fun_ind_using_typed + RAW_TYPED AS constr_with_bindings_opt + RAW_PRINTED BY pr_fun_ind_using + GLOB_TYPED AS constr_with_bindings_opt + GLOB_PRINTED BY pr_fun_ind_using +| [ "using" constr_with_bindings(c) ] -> [ Some c ] +| [ ] -> [ None ] +END + + +TACTIC EXTEND newfuninv + [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> + [ + Invfun.invfun hyp fname + ] +END + + +let pr_intro_as_pat prc _ _ pat = + match pat with + | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat + | None -> mt () + + +ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat +| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] +| [] ->[ None ] +END + + + + +TACTIC EXTEND newfunind + ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> + [ + let c = match cl with + | [] -> assert false + | [c] -> c + | c::cl -> applist(c,cl) + in + Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ] +END +(***** debug only ***) +TACTIC EXTEND snewfunind + ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> + [ + let c = match cl with + | [] -> assert false + | [c] -> c + | c::cl -> applist(c,cl) + in + Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ] +END + + +let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_comma prc + +ARGUMENT EXTEND constr_coma_sequence' + TYPED AS constr_list + PRINTED BY pr_constr_coma_sequence +| [ constr(c) "," constr_coma_sequence'(l) ] -> [ c::l ] +| [ constr(c) ] -> [ [c] ] +END + +let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc + +ARGUMENT EXTEND auto_using' + TYPED AS constr_list + PRINTED BY pr_auto_using +| [ "using" constr_coma_sequence'(l) ] -> [ l ] +| [ ] -> [ [] ] +END + +let pr_rec_annotation2_aux s r id l = + str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++ + Util.pr_opt Nameops.pr_id id ++ + Pptactic.pr_auto_using Ppconstr.pr_constr_expr l ++ str "}" + +let pr_rec_annotation2 = function + | Struct id -> str "{struct" ++ Nameops.pr_id id ++ str "}" + | Wf(r,id,l) -> pr_rec_annotation2_aux "wf" r id l + | Mes(r,id,l) -> pr_rec_annotation2_aux "measure" r id l + +VERNAC ARGUMENT EXTEND rec_annotation2 +PRINTED BY pr_rec_annotation2 + [ "{" "struct" ident(id) "}"] -> [ Struct id ] +| [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ] +| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] +END + +let pr_binder2 (idl,c) = + str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++ + str ": " ++ Ppconstr.pr_lconstr_expr c ++ str ")" + +VERNAC ARGUMENT EXTEND binder2 +PRINTED BY pr_binder2 + [ "(" ne_ident_list(idl) ":" lconstr(c) ")"] -> [ (idl,c) ] +END + +let make_binder2 (idl,c) = + LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c) + +let pr_rec_definition2 (id,bl,annot,type_,def) = + Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++ + Util.pr_opt pr_rec_annotation2 annot ++ spc () ++ str ":" ++ spc () ++ + Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++ + Ppconstr.pr_lconstr_expr def + +VERNAC ARGUMENT EXTEND rec_definition2 +PRINTED BY pr_rec_definition2 + [ ident(id) binder2_list(bl) + rec_annotation2_opt(annot) ":" lconstr(type_) + ":=" lconstr(def)] -> + [ (id,bl,annot,type_,def) ] +END + +let make_rec_definitions2 (id,bl,annot,type_,def) = + let bl = List.map make_binder2 bl in + let names = List.map snd (Topconstr.names_of_local_assums bl) in + let check_one_name () = + if List.length names > 1 then + Util.user_err_loc + (Util.dummy_loc,"Function", + Pp.str "the recursive argument needs to be specified"); + in + let check_exists_args an = + try + let id = match an with + | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id + | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" + in + (try ignore(Util.list_index0 (Name id) names); annot + with Not_found -> Util.user_err_loc + (Util.dummy_loc,"Function", + Pp.str "No argument named " ++ Nameops.pr_id id) + ) + with Failure "check_exists_args" -> check_one_name ();annot + in + let ni = + match annot with + | None -> + annot + | Some an -> + check_exists_args an + in + ((Util.dummy_loc,id), ni, bl, type_, def) + + +VERNAC COMMAND EXTEND Function + ["Function" ne_rec_definition2_list_sep(recsl,"with")] -> + [ + do_generate_principle false (List.map make_rec_definitions2 recsl); + + ] +END + +let pr_fun_scheme_arg (princ_name,fun_name,s) = + Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ + Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ + Ppconstr.pr_rawsort s + +VERNAC ARGUMENT EXTEND fun_scheme_arg +PRINTED BY pr_fun_scheme_arg +| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] +END + + +let warning_error names e = + match e with + | Building_graph e -> + Pp.msg_warning + (str "Cannot define graph(s) for " ++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ + if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) + | Defining_principle e -> + Pp.msg_warning + (str "Cannot define principle(s) for "++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ + if do_observe () then Cerrors.explain_exn e else mt ()) + | _ -> anomaly "" + + +VERNAC COMMAND EXTEND NewFunctionalScheme + ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] -> + [ + begin + try + Functional_principles_types.build_scheme fas + with Functional_principles_types.No_graph_found -> + begin + match fas with + | (_,fun_name,_)::_ -> + begin + begin + make_graph (Nametab.global fun_name) + end + ; + try Functional_principles_types.build_scheme fas + with Functional_principles_types.No_graph_found -> + Util.error ("Cannot generate induction principle(s)") + | e -> + let names = List.map (fun (_,na,_) -> na) fas in + warning_error names e + + end + | _ -> assert false (* we can only have non empty list *) + end + | e -> + let names = List.map (fun (_,na,_) -> na) fas in + warning_error names e + + end + ] +END +(***** debug only ***) + +VERNAC COMMAND EXTEND NewFunctionalCase + ["Functional" "Case" fun_scheme_arg(fas) ] -> + [ + Functional_principles_types.build_case_scheme fas + ] +END + +(***** debug only ***) +VERNAC COMMAND EXTEND GenerateGraph +["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ] +END + + + + + +(* FINDUCTION *) + +(* comment this line to see debug msgs *) +let msg x = () ;; let pr_lconstr c = str "" + (* uncomment this to see debugging *) +let prconstr c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") +let prlistconstr lc = List.iter prconstr lc +let prstr s = msg(str s) +let prNamedConstr s c = + begin + msg(str ""); + msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n"); + msg(str ""); + end + + + +(** Information about an occurrence of a function call (application) + inside a term. *) +type fapp_info = { + fname: constr; (** The function applied *) + largs: constr list; (** List of arguments *) + free: bool; (** [true] if all arguments are debruijn free *) + max_rel: int; (** max debruijn index in the funcall *) + onlyvars: bool (** [true] if all arguments are variables (and not debruijn) *) +} + + +(** [constr_head_match(a b c) a] returns true, false otherwise. *) +let constr_head_match u t= + if isApp u + then + let uhd,args= destApp u in + uhd=t + else false + +(** [hdMatchSub inu t] returns the list of occurrences of [t] in + [inu]. DeBruijn are not pushed, so some of them may be unbound in + the result. *) +let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = + let subres = + match kind_of_term inu with + | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> + hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test + | Fix (_,(lna,tl,bl)) -> (* not sure Fix is correct *) + Array.fold_left + (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) + [] bl + | _ -> (* Cofix will be wrong *) + fold_constr + (fun l cstr -> + l @ hdMatchSub cstr test) [] inu in + if not (test inu) then subres + else + let f,args = decompose_app inu in + let freeset = Termops.free_rels inu in + let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in + {fname = f; largs = args; free = Util.Intset.is_empty freeset; + max_rel = max_rel; onlyvars = List.for_all isVar args } + ::subres + +let mkEq typ c1 c2 = + mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|]) + + +let poseq_unsafe idunsafe cstr gl = + let typ = Tacmach.pf_type_of gl cstr in + tclTHEN + (Tactics.letin_tac None (Name idunsafe) cstr None allHypsAndConcl) + (tclTHENFIRST + (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) + Tactics.reflexivity) + gl + + +let poseq id cstr gl = + let x = Tactics.fresh_id [] id gl in + poseq_unsafe x cstr gl + +(* dirty? *) + +let list_constr_largs = ref [] + +let rec poseq_list_ids_rec lcstr gl = + match lcstr with + | [] -> tclIDTAC gl + | c::lcstr' -> + match kind_of_term c with + | Var _ -> + (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl) + | _ -> + let _ = prstr "c = " in + let _ = prconstr c in + let _ = prstr "\n" in + let typ = Tacmach.pf_type_of gl c in + let cname = Namegen.id_of_name_using_hdchar (Global.env()) typ Anonymous in + let x = Tactics.fresh_id [] cname gl in + let _ = list_constr_largs:=mkVar x :: !list_constr_largs in + let _ = prstr " list_constr_largs = " in + let _ = prlistconstr !list_constr_largs in + let _ = prstr "\n" in + + tclTHEN + (poseq_unsafe x c) + (poseq_list_ids_rec lcstr') + gl + +let poseq_list_ids lcstr gl = + let _ = list_constr_largs := [] in + poseq_list_ids_rec lcstr gl + +(** [find_fapp test g] returns the list of [app_info] of all calls to + functions that satisfy [test] in the conclusion of goal g. Trivial + repetition (not modulo conversion) are deleted. *) +let find_fapp (test:constr -> bool) g : fapp_info list = + let pre_res = hdMatchSub (Tacmach.pf_concl g) test in + let res = + List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in + (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res); + res) + + + +(** [finduction id filter g] tries to apply functional induction on + an occurence of function [id] in the conclusion of goal [g]. If + [id]=[None] then calls to any function are selected. In any case + [heuristic] is used to select the most pertinent occurrence. *) +let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list) + (nexttac:Proof_type.tactic) g = + let test = match oid with + | Some id -> + let idconstr = mkConst (const_of_id id) in + (fun u -> constr_head_match u idconstr) (* select only id *) + | None -> (fun u -> isApp u) in (* select calls to any function *) + let info_list = find_fapp test g in + let ordered_info_list = heuristic info_list in + prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); + if List.length ordered_info_list = 0 then Util.error "function not found in goal\n"; + let taclist: Proof_type.tactic list = + List.map + (fun info -> + (tclTHEN + (tclTHEN (poseq_list_ids info.largs) + ( + fun gl -> + (functional_induction + true (applist (info.fname, List.rev !list_constr_largs)) + None None) gl)) + nexttac)) ordered_info_list in + (* we try each (f t u v) until one does not fail *) + (* TODO: try also to mix functional schemes *) + tclFIRST taclist g + + + + +(** [chose_heuristic oi x] returns the heuristic for reordering + (and/or forgetting some elts of) a list of occurrences of + function calls infos to chose first with functional induction. *) +let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list = + match oi with + | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *) + | None -> + (* Default heuristic: put first occurrences where all arguments + are *bound* (meaning already introduced) variables *) + let ordering x y = + if x.free && x.onlyvars && y.free && y.onlyvars then 0 (* both pertinent *) + else if x.free && x.onlyvars then -1 + else if y.free && y.onlyvars then 1 + else 0 (* both not pertinent *) + in + List.sort ordering + + + +TACTIC EXTEND finduction + ["finduction" ident(id) natural_opt(oi)] -> + [ + match oi with + | Some(n) when n<=0 -> Util.error "numerical argument must be > 0" + | _ -> + let heuristic = chose_heuristic oi in + finduction (Some id) heuristic tclIDTAC + ] +END + + + +TACTIC EXTEND fauto + [ "fauto" tactic(tac)] -> + [ + let heuristic = chose_heuristic None in + finduction None heuristic (snd tac) + ] + | + [ "fauto" ] -> + [ + let heuristic = chose_heuristic None in + finduction None heuristic tclIDTAC + ] + +END + + +TACTIC EXTEND poseq + [ "poseq" ident(x) constr(c) ] -> + [ poseq x c ] +END + +VERNAC COMMAND EXTEND Showindinfo + [ "showindinfo" ident(x) ] -> [ Merge.showind x ] +END + +VERNAC COMMAND EXTEND MergeFunind + [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" + "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] -> + [ + let f1 = Constrintern.interp_constr Evd.empty (Global.env()) + (CRef (Libnames.Ident (Util.dummy_loc,id1))) in + let f2 = Constrintern.interp_constr Evd.empty (Global.env()) + (CRef (Libnames.Ident (Util.dummy_loc,id2))) in + let f1type = Typing.type_of (Global.env()) Evd.empty f1 in + let f2type = Typing.type_of (Global.env()) Evd.empty f2 in + let ar1 = List.length (fst (decompose_prod f1type)) in + let ar2 = List.length (fst (decompose_prod f2type)) in + let _ = + if ar1 <> List.length cl1 then + Util.error ("not the right number of arguments for " ^ string_of_id id1) in + let _ = + if ar2 <> List.length cl2 then + Util.error ("not the right number of arguments for " ^ string_of_id id2) in + Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2) id + ] +END diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml new file mode 100644 index 00000000..38f42844 --- /dev/null +++ b/plugins/funind/indfun.ml @@ -0,0 +1,776 @@ +open Util +open Names +open Term +open Pp +open Indfun_common +open Libnames +open Rawterm +open Declarations + +let is_rec_info scheme_info = + let test_branche min acc (_,_,br) = + acc || ( + let new_branche = + it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in + let free_rels_in_br = Termops.free_rels new_branche in + let max = min + scheme_info.Tactics.npredicates in + Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br + ) + in + Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) + + +let choose_dest_or_ind scheme_info = + if is_rec_info scheme_info + then Tactics.new_induct false + else Tactics.new_destruct false + + +let functional_induction with_clean c princl pat = + Dumpglob.pause (); + let res = let f,args = decompose_app c in + fun g -> + let princ,bindings, princ_type = + match princl with + | None -> (* No principle is given let's find the good one *) + begin + match kind_of_term f with + | Const c' -> + let princ_option = + let finfo = (* we first try to find out a graph on f *) + try find_Function_infos c' + with Not_found -> + errorlabstrm "" (str "Cannot find induction information on "++ + Printer.pr_lconstr (mkConst c') ) + in + match Tacticals.elimination_sort_of_goal g with + | InProp -> finfo.prop_lemma + | InSet -> finfo.rec_lemma + | InType -> finfo.rect_lemma + in + let princ = (* then we get the principle *) + try mkConst (Option.get princ_option ) + with Option.IsNone -> + (*i If there is not default lemma defined then, + we cross our finger and try to find a lemma named f_ind + (or f_rec, f_rect) i*) + let princ_name = + Indrec.make_elimination_ident + (id_of_label (con_label c')) + (Tacticals.elimination_sort_of_goal g) + in + try + mkConst(const_of_id princ_name ) + with Not_found -> (* This one is neither defined ! *) + errorlabstrm "" (str "Cannot find induction principle for " + ++Printer.pr_lconstr (mkConst c') ) + in + (princ,Rawterm.NoBindings, Tacmach.pf_type_of g princ) + | _ -> raise (UserError("",str "functional induction must be used with a function" )) + + end + | Some ((princ,binding)) -> + princ,binding,Tacmach.pf_type_of g princ + in + let princ_infos = Tactics.compute_elim_sig princ_type in + let args_as_induction_constr = + let c_list = + if princ_infos.Tactics.farg_in_concl + then [c] else [] + in + List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list) + in + let princ' = Some (princ,bindings) in + let princ_vars = + List.fold_right + (fun a acc -> + try Idset.add (destVar a) acc + with _ -> acc + ) + args + Idset.empty + in + let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in + let old_idl = Idset.diff old_idl princ_vars in + let subst_and_reduce g = + if with_clean + then + let idl = + map_succeed + (fun id -> + if Idset.mem id old_idl then failwith "subst_and_reduce"; + id + ) + (Tacmach.pf_ids_of_hyps g) + in + let flag = + Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + } + in + Tacticals.tclTHEN + (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl ) + (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl) + g + else Tacticals.tclIDTAC g + + in + Tacticals.tclTHEN + (choose_dest_or_ind + princ_infos + args_as_induction_constr + princ' + (None,pat) + None) + subst_and_reduce + g + in + Dumpglob.continue (); + res + + + + +type annot = + Struct of identifier + | Wf of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list + | Mes of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list + + +type newfixpoint_expr = + identifier * annot * Topconstr.local_binder list * Topconstr.constr_expr * Topconstr.constr_expr + +let rec abstract_rawconstr c = function + | [] -> c + | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_rawconstr c bl) + | Topconstr.LocalRawAssum (idl,k,t)::bl -> + List.fold_right (fun x b -> Topconstr.mkLambdaC([x],k,t,b)) idl + (abstract_rawconstr c bl) + +let interp_casted_constr_with_implicits sigma env impls c = +(* Constrintern.interp_rawconstr_with_implicits sigma env [] impls c *) + Constrintern.intern_gen false sigma env ~impls + ~allow_patvar:false ~ltacvars:([],[]) c + + +(* + Construct a fixpoint as a Rawterm + and not as a constr +*) +let build_newrecursive +(lnameargsardef) = + let env0 = Global.env() + and sigma = Evd.empty + in + let (rec_sign,rec_impls) = + List.fold_left + (fun (env,impls) ((_,recname),_,bl,arityc,_) -> + let arityc = Topconstr.prod_constr_expr arityc bl in + let arity = Constrintern.interp_type sigma env0 arityc in + let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in + (Environ.push_named (recname,None,arity) env, (recname,impl) :: impls)) + (env0,[]) lnameargsardef in + let rec_impls = Constrintern.set_internalization_env_params rec_impls [] in + let recdef = + (* Declare local notations *) + let fs = States.freeze() in + let def = + try + List.map + (fun (_,_,bl,_,def) -> + let def = abstract_rawconstr def bl in + interp_casted_constr_with_implicits + sigma rec_sign rec_impls def + ) + lnameargsardef + with e -> + States.unfreeze fs; raise e in + States.unfreeze fs; def + in + recdef,rec_impls + + +let compute_annot (name,annot,args,types,body) = + let names = List.map snd (Topconstr.names_of_local_assums args) in + match annot with + | None -> + if List.length names > 1 then + user_err_loc + (dummy_loc,"Function", + Pp.str "the recursive argument needs to be specified"); + let new_annot = (id_of_name (List.hd names)) in + (name,Struct new_annot,args,types,body) + | Some r -> (name,r,args,types,body) + + +(* Checks whether or not the mutual bloc is recursive *) +let rec is_rec names = + let names = List.fold_right Idset.add names Idset.empty in + let check_id id names = Idset.mem id names in + let rec lookup names = function + | RVar(_,id) -> check_id id names + | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ | RDynamic _ -> false + | RCast(_,b,_) -> lookup names b + | RRec _ -> error "RRec not handled" + | RIf(_,b,_,lhs,rhs) -> + (lookup names b) || (lookup names lhs) || (lookup names rhs) + | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b) -> + lookup names t || lookup (Nameops.name_fold Idset.remove na names) b + | RLetTuple(_,nal,_,t,b) -> lookup names t || + lookup + (List.fold_left + (fun acc na -> Nameops.name_fold Idset.remove na acc) + names + nal + ) + b + | RApp(_,f,args) -> List.exists (lookup names) (f::args) + | RCases(_,_,_,el,brl) -> + List.exists (fun (e,_) -> lookup names e) el || + List.exists (lookup_br names) brl + and lookup_br names (_,idl,_,rt) = + let new_names = List.fold_right Idset.remove idl names in + lookup new_names rt + in + lookup names + +let rec local_binders_length = function + (* Assume that no `{ ... } contexts occur *) + | [] -> 0 + | Topconstr.LocalRawDef _::bl -> 1 + local_binders_length bl + | Topconstr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl + +let prepare_body (name,annot,args,types,body) rt = + let n = local_binders_length args in +(* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_rawconstr rt); *) + let fun_args,rt' = chop_rlambda_n n rt in + (fun_args,rt') + + +let derive_inversion fix_names = + try + (* we first transform the fix_names identifier into their corresponding constant *) + let fix_names_as_constant = + List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names + in + (* + Then we check that the graphs have been defined + If one of the graphs haven't been defined + we do nothing + *) + List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ; + try + Invfun.derive_correctness + Functional_principles_types.make_scheme + functional_induction + fix_names_as_constant + (*i The next call to mk_rel_id is valid since we have just construct the graph + Ensures by : register_built + i*) + (List.map + (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id))) + fix_names + ) + with e -> + msg_warning + (str "Cannot built inversion information" ++ + if do_observe () then Cerrors.explain_exn e else mt ()) + with _ -> () + +let warning_error names e = + let e_explain e = + match e with + | ToShow e -> spc () ++ Cerrors.explain_exn e + | _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt () + in + match e with + | Building_graph e -> + Pp.msg_warning + (str "Cannot define graph(s) for " ++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + e_explain e) + | Defining_principle e -> + Pp.msg_warning + (str "Cannot define principle(s) for "++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + e_explain e) + | _ -> anomaly "" + +let error_error names e = + let e_explain e = + match e with + | ToShow e -> spc () ++ Cerrors.explain_exn e + | _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt () + in + match e with + | Building_graph e -> + errorlabstrm "" + (str "Cannot define graph(s) for " ++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + e_explain e) + | _ -> anomaly "" + +let generate_principle on_error + is_general do_built fix_rec_l recdefs interactive_proof + (continue_proof : int -> Names.constant array -> Term.constr array -> int -> + Tacmach.tactic) : unit = + let names = List.map (function ((_, name),_,_,_,_) -> name) fix_rec_l in + let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in + let funs_args = List.map fst fun_bodies in + let funs_types = List.map (function (_,_,_,types,_) -> types) fix_rec_l in + try + (* We then register the Inductive graphs of the functions *) + Rawterm_to_relation.build_inductive names funs_args funs_types recdefs; + if do_built + then + begin + (*i The next call to mk_rel_id is valid since we have just construct the graph + Ensures by : do_built + i*) + let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in + let ind_kn = + fst (locate_with_msg + (pr_reference f_R_mut++str ": Not an inductive type!") + locate_ind + f_R_mut) + in + let fname_kn (fname,_,_,_,_) = + let f_ref = Ident fname in + locate_with_msg + (pr_reference f_ref++str ": Not an inductive type!") + locate_constant + f_ref + in + let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in + let _ = + list_map_i + (fun i x -> + let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in + let princ_type = Typeops.type_of_constant (Global.env()) princ + in + Functional_principles_types.generate_functional_principle + interactive_proof + princ_type + None + None + funs_kn + i + (continue_proof 0 [|funs_kn.(i)|]) + ) + 0 + fix_rec_l + in + Array.iter (add_Function is_general) funs_kn; + () + end + with e -> + on_error names e + +let register_struct is_rec fixpoint_exprl = + match fixpoint_exprl with + | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> + let ce,imps = + Command.interp_definition + (Flags.boxed_definitions ()) bl None body (Some ret_type) + in + Command.declare_definition + fname (Decl_kinds.Global,Decl_kinds.Definition) + ce imps (fun _ _ -> ()) + | _ -> + let fixpoint_exprl = + List.map (fun ((name,annot,bl,types,body),ntn) -> + ((name,annot,bl,types,Some body),ntn)) fixpoint_exprl in + Command.do_fixpoint fixpoint_exprl (Flags.boxed_definitions()) + +let generate_correction_proof_wf f_ref tcc_lemma_ref + is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation + (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = + Functional_principles_proofs.prove_principle_for_gen + (f_ref,functional_ref,eq_ref) + tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation + + +let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body + pre_hook + = + let type_of_f = Topconstr.prod_constr_expr ret_type args in + let rec_arg_num = + let names = + List.map + snd + (Topconstr.names_of_local_assums args) + in + match wf_arg with + | None -> + if List.length names = 1 then 1 + else error "Recursive argument must be specified" + | Some wf_arg -> + list_index (Name wf_arg) names + in + let unbounded_eq = + let f_app_args = + Topconstr.CAppExpl + (dummy_loc, + (None,(Ident (dummy_loc,fname))) , + (List.map + (function + | _,Anonymous -> assert false + | _,Name e -> (Topconstr.mkIdentC e) + ) + (Topconstr.names_of_local_assums args) + ) + ) + in + Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))), + [(f_app_args,None);(body,None)]) + in + let eq = Topconstr.prod_constr_expr unbounded_eq args in + let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type + nb_args relation = + try + pre_hook + (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes + functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation + ); + derive_inversion [fname] + with e -> + (* No proof done *) + () + in + Recdef.recursive_definition + is_mes fname rec_impls + type_of_f + wf_rel_expr + rec_arg_num + eq + hook + using_lemmas + + +let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body = + let wf_arg_type,wf_arg = + match wf_arg with + | None -> + begin + match args with + | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x + | _ -> error "Recursive argument must be specified" + end + | Some wf_args -> + try + match + List.find + (function + | Topconstr.LocalRawAssum(l,k,t) -> + List.exists + (function (_,Name id) -> id = wf_args | _ -> false) + l + | _ -> false + ) + args + with + | Topconstr.LocalRawAssum(_,k,t) -> t,wf_args + | _ -> assert false + with Not_found -> assert false + in + let ltof = + let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in + Libnames.Qualid (dummy_loc,Libnames.qualid_of_path + (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof"))) + in + let fun_from_mes = + let applied_mes = + Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg]) in + Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes) + in + let wf_rel_from_mes = + Topconstr.mkAppC(Topconstr.mkRefC ltof,[wf_arg_type;fun_from_mes]) + in + register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg) + using_lemmas args ret_type body + + +let do_generate_principle on_error register_built interactive_proof fixpoint_exprl = + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let _is_struct = + match fixpoint_exprl with + | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> + let pre_hook = + generate_principle + on_error + true + register_built + fixpoint_exprl + recdefs + true + in + if register_built + then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook; + false + | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> + let pre_hook = + generate_principle + on_error + true + register_built + fixpoint_exprl + recdefs + true + in + if register_built + then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook; + true + | _ -> + let fix_names = + List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl + in + let is_one_rec = is_rec fix_names in + let old_fixpoint_exprl = + List.map + (function + | (name,Some (Struct id),args,types,body),_ -> + let annot = + try Some (dummy_loc, id), Topconstr.CStructRec + with Not_found -> + raise (UserError("",str "Cannot find argument " ++ + Ppconstr.pr_id id)) + in + (name,annot,args,types,body),([]:Vernacexpr.decl_notation list) + | (name,None,args,types,body),recdef -> + let names = (Topconstr.names_of_local_assums args) in + if is_one_rec recdef && List.length names > 1 then + user_err_loc + (dummy_loc,"Function", + Pp.str "the recursive argument needs to be specified in Function") + else + let loc, na = List.hd names in + (name,(Some (loc, Nameops.out_name na), Topconstr.CStructRec),args,types,body), + ([]:Vernacexpr.decl_notation list) + | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> + error + ("Cannot use mutual definition with well-founded recursion or measure") + ) + (List.combine fixpoint_exprl recdefs) + in + (* ok all the expressions are structural *) + let fix_names = + List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl + in + let is_rec = List.exists (is_rec fix_names) recdefs in + if register_built then register_struct is_rec old_fixpoint_exprl; + generate_principle + on_error + false + register_built + fixpoint_exprl + recdefs + interactive_proof + (Functional_principles_proofs.prove_princ_for_struct interactive_proof); + if register_built then derive_inversion fix_names; + true; + in + () + +open Topconstr +let rec add_args id new_args b = + match b with + | CRef r -> + begin match r with + | Libnames.Ident(loc,fname) when fname = id -> + CAppExpl(dummy_loc,(None,r),new_args) + | _ -> b + end + | CFix _ | CCoFix _ -> anomaly "add_args : todo" + | CArrow(loc,b1,b2) -> + CArrow(loc,add_args id new_args b1, add_args id new_args b2) + | CProdN(loc,nal,b1) -> + CProdN(loc, + List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, + add_args id new_args b1) + | CLambdaN(loc,nal,b1) -> + CLambdaN(loc, + List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, + add_args id new_args b1) + | CLetIn(loc,na,b1,b2) -> + CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) + | CAppExpl(loc,(pf,r),exprl) -> + begin + match r with + | Libnames.Ident(loc,fname) when fname = id -> + CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl)) + | _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl) + end + | CApp(loc,(pf,b),bl) -> + CApp(loc,(pf,add_args id new_args b), + List.map (fun (e,o) -> add_args id new_args e,o) bl) + | CCases(loc,sty,b_option,cel,cal) -> + CCases(loc,sty,Option.map (add_args id new_args) b_option, + List.map (fun (b,(na,b_option)) -> + add_args id new_args b, + (na,Option.map (add_args id new_args) b_option)) cel, + List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal + ) + | CLetTuple(loc,nal,(na,b_option),b1,b2) -> + CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option), + add_args id new_args b1, + add_args id new_args b2 + ) + + | CIf(loc,b1,(na,b_option),b2,b3) -> + CIf(loc,add_args id new_args b1, + (na,Option.map (add_args id new_args) b_option), + add_args id new_args b2, + add_args id new_args b3 + ) + | CHole _ -> b + | CPatVar _ -> b + | CEvar _ -> b + | CSort _ -> b + | CCast(loc,b1,CastConv(ck,b2)) -> + CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2)) + | CCast(loc,b1,CastCoerce) -> + CCast(loc,add_args id new_args b1,CastCoerce) + | CRecord (loc, w, pars) -> + CRecord (loc, + (match w with Some w -> Some (add_args id new_args w) | _ -> None), + List.map (fun (e,o) -> e, add_args id new_args o) pars) + | CNotation _ -> anomaly "add_args : CNotation" + | CGeneralization _ -> anomaly "add_args : CGeneralization" + | CPrim _ -> b + | CDelimiters _ -> anomaly "add_args : CDelimiters" + | CDynamic _ -> anomaly "add_args : CDynamic" +exception Stop of Topconstr.constr_expr + + +(* [chop_n_arrow n t] chops the [n] first arrows in [t] + Acts on Topconstr.constr_expr +*) +let rec chop_n_arrow n t = + if n <= 0 + then t (* If we have already removed all the arrows then return the type *) + else (* If not we check the form of [t] *) + match t with + | Topconstr.CArrow(_,_,t) -> (* If we have an arrow, we discard it and recall [chop_n_arrow] *) + chop_n_arrow (n-1) t + | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : + either we need to discard more than the number of arrows contained + in this product declaration then we just recall [chop_n_arrow] on + the remaining number of arrow to chop and [t'] we discard it and + recall [chop_n_arrow], either this product contains more arrows + than the number we need to chop and then we return the new type + *) + begin + try + let new_n = + let rec aux (n:int) = function + [] -> n + | (nal,k,t'')::nal_ta' -> + let nal_l = List.length nal in + if n >= nal_l + then + aux (n - nal_l) nal_ta' + else + let new_t' = + Topconstr.CProdN(dummy_loc, + ((snd (list_chop n nal)),k,t'')::nal_ta',t') + in + raise (Stop new_t') + in + aux n nal_ta' + in + chop_n_arrow new_n t' + with Stop t -> t + end + | _ -> anomaly "Not enough products" + + +let rec get_args b t : Topconstr.local_binder list * + Topconstr.constr_expr * Topconstr.constr_expr = + match b with + | Topconstr.CLambdaN (loc, (nal_ta), b') -> + begin + let n = + (List.fold_left (fun n (nal,_,_) -> + n+List.length nal) 0 nal_ta ) + in + let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in + (List.map (fun (nal,k,ta) -> + (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' + end + | _ -> [],b,t + + +let make_graph (f_ref:global_reference) = + let c,c_body = + match f_ref with + | ConstRef c -> + begin try c,Global.lookup_constant c + with Not_found -> + raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) + end + | _ -> raise (UserError ("", str "Not a function reference") ) + + in + Dumpglob.pause (); + (match c_body.const_body with + | None -> error "Cannot build a graph over an axiom !" + | Some b -> + let env = Global.env () in + let body = (force b) in + let extern_body,extern_type = + with_full_print + (fun () -> + (Constrextern.extern_constr false env body, + Constrextern.extern_type false env + (Typeops.type_of_constant_type env c_body.const_type) + ) + ) + () + in + let (nal_tas,b,t) = get_args extern_body extern_type in + let expr_list = + match b with + | Topconstr.CFix(loc,l_id,fixexprl) -> + let l = + List.map + (fun (id,(n,recexp),bl,t,b) -> + let loc, rec_id = Option.get n in + let new_args = + List.flatten + (List.map + (function + | Topconstr.LocalRawDef (na,_)-> [] + | Topconstr.LocalRawAssum (nal,_,_) -> + List.map + (fun (loc,n) -> + CRef(Libnames.Ident(loc, Nameops.out_name n))) + nal + ) + nal_tas + ) + in + let b' = add_args (snd id) new_args b in + (id, Some (Struct rec_id),nal_tas@bl,t,b') + ) + fixexprl + in + l + | _ -> + let id = id_of_label (con_label c) in + [((dummy_loc,id),None,nal_tas,t,b)] + in + do_generate_principle error_error false false expr_list; + (* We register the infos *) + let mp,dp,_ = repr_con c in + List.iter + (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) + expr_list); + Dumpglob.continue () + + +(* let make_graph _ = assert false *) + +let do_generate_principle = do_generate_principle warning_error true + + diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml new file mode 100644 index 00000000..0f048f59 --- /dev/null +++ b/plugins/funind/indfun_common.ml @@ -0,0 +1,558 @@ +open Names +open Pp + +open Libnames + +let mk_prefix pre id = id_of_string (pre^(string_of_id id)) +let mk_rel_id = mk_prefix "R_" +let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" +let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" +let mk_equation_id id = Nameops.add_suffix id "_equation" + +let msgnl m = + () + +let invalid_argument s = raise (Invalid_argument s) + + +let fresh_id avoid s = Namegen.next_ident_away_in_goal (id_of_string s) avoid + +let fresh_name avoid s = Name (fresh_id avoid s) + +let get_name avoid ?(default="H") = function + | Anonymous -> fresh_name avoid default + | Name n -> Name n + +let array_get_start a = + try + Array.init + (Array.length a - 1) + (fun i -> a.(i)) + with Invalid_argument "index out of bounds" -> + invalid_argument "array_get_start" + +let id_of_name = function + Name id -> id + | _ -> raise Not_found + +let locate ref = + let (loc,qid) = qualid_of_reference ref in + Nametab.locate qid + +let locate_ind ref = + match locate ref with + | IndRef x -> x + | _ -> raise Not_found + +let locate_constant ref = + match locate ref with + | ConstRef x -> x + | _ -> raise Not_found + + +let locate_with_msg msg f x = + try + f x + with + | Not_found -> raise (Util.UserError("", msg)) + | e -> raise e + + +let filter_map filter f = + let rec it = function + | [] -> [] + | e::l -> + if filter e + then + (f e) :: it l + else it l + in + it + + +let chop_rlambda_n = + let rec chop_lambda_n acc n rt = + if n == 0 + then List.rev acc,rt + else + match rt with + | Rawterm.RLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b + | Rawterm.RLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b + | _ -> + raise (Util.UserError("chop_rlambda_n", + str "chop_rlambda_n: Not enough Lambdas")) + in + chop_lambda_n [] + +let chop_rprod_n = + let rec chop_prod_n acc n rt = + if n == 0 + then List.rev acc,rt + else + match rt with + | Rawterm.RProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b + | _ -> raise (Util.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) + in + chop_prod_n [] + + + +let list_union_eq eq_fun l1 l2 = + let rec urec = function + | [] -> l2 + | a::l -> if List.exists (eq_fun a) l2 then urec l else a::urec l + in + urec l1 + +let list_add_set_eq eq_fun x l = + if List.exists (eq_fun x) l then l else x::l + + + + +let const_of_id id = + let _,princ_ref = + qualid_of_reference (Libnames.Ident (Util.dummy_loc,id)) + in + try Nametab.locate_constant princ_ref + with Not_found -> Util.error ("cannot find "^ string_of_id id) + +let def_of_const t = + match (Term.kind_of_term t) with + Term.Const sp -> + (try (match (Global.lookup_constant sp) with + {Declarations.const_body=Some c} -> Declarations.force c + |_ -> assert false) + with _ -> assert false) + |_ -> assert false + +let coq_constant s = + Coqlib.gen_constant_in_modules "RecursiveDefinition" + Coqlib.init_modules s;; + +let constant sl s = + constr_of_global + (Nametab.locate (make_qualid(Names.make_dirpath + (List.map id_of_string (List.rev sl))) + (id_of_string s)));; + +let find_reference sl s = + (Nametab.locate (make_qualid(Names.make_dirpath + (List.map id_of_string (List.rev sl))) + (id_of_string s)));; + +let eq = lazy(coq_constant "eq") +let refl_equal = lazy(coq_constant "eq_refl") + +(*****************************************************************) +(* Copy of the standart save mechanism but without the much too *) +(* slow reduction function *) +(*****************************************************************) +open Declarations +open Entries +open Decl_kinds +open Declare +let definition_message id = + Flags.if_verbose message ((string_of_id id) ^ " is defined") + + +let save with_clean id const (locality,kind) hook = + let {const_entry_body = pft; + const_entry_type = tpo; + const_entry_opaque = opacity } = const in + let l,r = match locality with + | Local when Lib.sections_are_opened () -> + let k = logical_kind_of_goal_kind kind in + let c = SectionLocalDef (pft, tpo, opacity) in + let _ = declare_variable id (Lib.cwd(), c, k) in + (Local, VarRef id) + | Local -> + let k = logical_kind_of_goal_kind kind in + let kn = declare_constant id (DefinitionEntry const, k) in + (Global, ConstRef kn) + | Global -> + let k = logical_kind_of_goal_kind kind in + let kn = declare_constant id (DefinitionEntry const, k) in + (Global, ConstRef kn) in + if with_clean then Pfedit.delete_current_proof (); + hook l r; + definition_message id + + + + +let extract_pftreestate pts = + let pfterm,subgoals = Refiner.extract_open_pftreestate pts in + let tpfsigma = Refiner.evc_of_pftreestate pts in + let exl = Evarutil.non_instantiated tpfsigma in + if subgoals <> [] or exl <> [] then + Util.errorlabstrm "extract_proof" + (if subgoals <> [] then + str "Attempt to save an incomplete proof" + else + str "Attempt to save a proof with existential variables still non-instantiated"); + let env = Global.env_of_context (Refiner.proof_of_pftreestate pts).Proof_type.goal.Evd.evar_hyps in + env,tpfsigma,pfterm + + +let nf_betaiotazeta = + let clos_norm_flags flgs env sigma t = + Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in + clos_norm_flags Closure.betaiotazeta + +let nf_betaiota = + let clos_norm_flags flgs env sigma t = + Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in + clos_norm_flags Closure.betaiota + +let cook_proof do_reduce = + let pfs = Pfedit.get_pftreestate () +(* and ident = Pfedit.get_current_proof_name () *) + and (ident,strength,concl,hook) = Pfedit.current_proof_statement () in + let env,sigma,pfterm = extract_pftreestate pfs in + let pfterm = + if do_reduce + then nf_betaiota env sigma pfterm + else pfterm + in + (ident, + ({ const_entry_body = pfterm; + const_entry_type = Some concl; + const_entry_opaque = false; + const_entry_boxed = false}, + strength, hook)) + + +let new_save_named opacity = + let id,(const,persistence,hook) = cook_proof true in + let const = { const with const_entry_opaque = opacity } in + save true id const persistence hook + +let get_proof_clean do_reduce = + let result = cook_proof do_reduce in + Pfedit.delete_current_proof (); + result + +let with_full_print f a = + let old_implicit_args = Impargs.is_implicit_args () + and old_strict_implicit_args = Impargs.is_strict_implicit_args () + and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in + let old_rawprint = !Flags.raw_print in + Flags.raw_print := true; + Impargs.make_implicit_args false; + Impargs.make_strict_implicit_args false; + Impargs.make_contextual_implicit_args false; + Impargs.make_contextual_implicit_args false; + Dumpglob.pause (); + try + let res = f a in + Impargs.make_implicit_args old_implicit_args; + Impargs.make_strict_implicit_args old_strict_implicit_args; + Impargs.make_contextual_implicit_args old_contextual_implicit_args; + Flags.raw_print := old_rawprint; + Dumpglob.continue (); + res + with + | e -> + Impargs.make_implicit_args old_implicit_args; + Impargs.make_strict_implicit_args old_strict_implicit_args; + Impargs.make_contextual_implicit_args old_contextual_implicit_args; + Flags.raw_print := old_rawprint; + Dumpglob.continue (); + raise e + + + + + + +(**********************) + +type function_info = + { + function_constant : constant; + graph_ind : inductive; + equation_lemma : constant option; + correctness_lemma : constant option; + completeness_lemma : constant option; + rect_lemma : constant option; + rec_lemma : constant option; + prop_lemma : constant option; + is_general : bool; (* Has this function been defined using general recursive definition *) + } + + +(* type function_db = function_info list *) + +(* let function_table = ref ([] : function_db) *) + + +let from_function = ref Cmap.empty +let from_graph = ref Indmap.empty +(* +let rec do_cache_info finfo = function + | [] -> raise Not_found + | (finfo'::finfos as l) -> + if finfo' == finfo then l + else if finfo'.function_constant = finfo.function_constant + then finfo::finfos + else + let res = do_cache_info finfo finfos in + if res == finfos then l else finfo'::l + + +let cache_Function (_,(finfos)) = + let new_tbl = + try do_cache_info finfos !function_table + with Not_found -> finfos::!function_table + in + if new_tbl != !function_table + then function_table := new_tbl +*) + +let cache_Function (_,finfos) = + from_function := Cmap.add finfos.function_constant finfos !from_function; + from_graph := Indmap.add finfos.graph_ind finfos !from_graph + + +let load_Function _ = cache_Function +let open_Function _ = cache_Function +let subst_Function (subst,finfos) = + let do_subst_con c = fst (Mod_subst.subst_con subst c) + and do_subst_ind (kn,i) = (Mod_subst.subst_ind subst kn,i) + in + let function_constant' = do_subst_con finfos.function_constant in + let graph_ind' = do_subst_ind finfos.graph_ind in + let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in + let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in + let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in + let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in + let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in + let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in + if function_constant' == finfos.function_constant && + graph_ind' == finfos.graph_ind && + equation_lemma' == finfos.equation_lemma && + correctness_lemma' == finfos.correctness_lemma && + completeness_lemma' == finfos.completeness_lemma && + rect_lemma' == finfos.rect_lemma && + rec_lemma' == finfos.rec_lemma && + prop_lemma' == finfos.prop_lemma + then finfos + else + { function_constant = function_constant'; + graph_ind = graph_ind'; + equation_lemma = equation_lemma' ; + correctness_lemma = correctness_lemma' ; + completeness_lemma = completeness_lemma' ; + rect_lemma = rect_lemma' ; + rec_lemma = rec_lemma'; + prop_lemma = prop_lemma'; + is_general = finfos.is_general + } + +let classify_Function infos = Libobject.Substitute infos + + +let discharge_Function (_,finfos) = + let function_constant' = Lib.discharge_con finfos.function_constant + and graph_ind' = Lib.discharge_inductive finfos.graph_ind + and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma + and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma + and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma + and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma + and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma + and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma + in + if function_constant' == finfos.function_constant && + graph_ind' == finfos.graph_ind && + equation_lemma' == finfos.equation_lemma && + correctness_lemma' == finfos.correctness_lemma && + completeness_lemma' == finfos.completeness_lemma && + rect_lemma' == finfos.rect_lemma && + rec_lemma' == finfos.rec_lemma && + prop_lemma' == finfos.prop_lemma + then Some finfos + else + Some { function_constant = function_constant' ; + graph_ind = graph_ind' ; + equation_lemma = equation_lemma' ; + correctness_lemma = correctness_lemma' ; + completeness_lemma = completeness_lemma'; + rect_lemma = rect_lemma'; + rec_lemma = rec_lemma'; + prop_lemma = prop_lemma' ; + is_general = finfos.is_general + } + +open Term +let pr_info f_info = + str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ + str "function_constant_type := " ++ + (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++ + str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++ + str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++ + str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++ + str "rect_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++ + str "rec_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++ + str "prop_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++ + str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () + +let pr_table tb = + let l = Cmap.fold (fun k v acc -> v::acc) tb [] in + Util.prlist_with_sep fnl pr_info l + +let in_Function,out_Function = + Libobject.declare_object + {(Libobject.default_object "FUNCTIONS_DB") with + Libobject.cache_function = cache_Function; + Libobject.load_function = load_Function; + Libobject.classify_function = classify_Function; + Libobject.subst_function = subst_Function; + Libobject.discharge_function = discharge_Function +(* Libobject.open_function = open_Function; *) + } + + + +(* Synchronisation with reset *) +let freeze () = + !from_function,!from_graph +let unfreeze (functions,graphs) = +(* Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *) + from_function := functions; + from_graph := graphs + +let init () = +(* Pp.msgnl (str "reseting function_table"); *) + from_function := Cmap.empty; + from_graph := Indmap.empty + +let _ = + Summary.declare_summary "functions_db_sum" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init } + +let find_or_none id = + try Some + (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" + ) + with Not_found -> None + + + +let find_Function_infos f = + Cmap.find f !from_function + + +let find_Function_of_graph ind = + Indmap.find ind !from_graph + +let update_Function finfo = +(* Pp.msgnl (pr_info finfo); *) + Lib.add_anonymous_leaf (in_Function finfo) + + +let add_Function is_general f = + let f_id = id_of_label (con_label f) in + let equation_lemma = find_or_none (mk_equation_id f_id) + and correctness_lemma = find_or_none (mk_correct_id f_id) + and completeness_lemma = find_or_none (mk_complete_id f_id) + and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect") + and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec") + and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") + and graph_ind = + match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) + with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive" + in + let finfos = + { function_constant = f; + equation_lemma = equation_lemma; + completeness_lemma = completeness_lemma; + correctness_lemma = correctness_lemma; + rect_lemma = rect_lemma; + rec_lemma = rec_lemma; + prop_lemma = prop_lemma; + graph_ind = graph_ind; + is_general = is_general + + } + in + update_Function finfos + +let pr_table () = pr_table !from_function +(*********************************) +(* Debuging *) +let functional_induction_rewrite_dependent_proofs = ref true +let function_debug = ref false +open Goptions + +let functional_induction_rewrite_dependent_proofs_sig = + { + optsync = false; + optname = "Functional Induction Rewrite Dependent"; + optkey = ["Functional";"Induction";"Rewrite";"Dependent"]; + optread = (fun () -> !functional_induction_rewrite_dependent_proofs); + optwrite = (fun b -> functional_induction_rewrite_dependent_proofs := b) + } +let _ = declare_bool_option functional_induction_rewrite_dependent_proofs_sig + +let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = true + +let function_debug_sig = + { + optsync = false; + optname = "Function debug"; + optkey = ["Function_debug"]; + optread = (fun () -> !function_debug); + optwrite = (fun b -> function_debug := b) + } + +let _ = declare_bool_option function_debug_sig + + +let do_observe () = + !function_debug = true + + + +let strict_tcc = ref false +let is_strict_tcc () = !strict_tcc +let strict_tcc_sig = + { + optsync = false; + optname = "Raw Function Tcc"; + optkey = ["Function_raw_tcc"]; + optread = (fun () -> !strict_tcc); + optwrite = (fun b -> strict_tcc := b) + } + +let _ = declare_bool_option strict_tcc_sig + + +exception Building_graph of exn +exception Defining_principle of exn +exception ToShow of exn + +let init_constant dir s = + try + Coqlib.gen_constant "Function" dir s + with e -> raise (ToShow e) + +let jmeq () = + try + (Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; + init_constant ["Logic";"JMeq"] "JMeq") + with e -> raise (ToShow e) + +let jmeq_rec () = + try + Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; + init_constant ["Logic";"JMeq"] "JMeq_rec" + with e -> raise (ToShow e) + +let jmeq_refl () = + try + Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; + init_constant ["Logic";"JMeq"] "JMeq_refl" + with e -> raise (ToShow e) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli new file mode 100644 index 00000000..6f6607fc --- /dev/null +++ b/plugins/funind/indfun_common.mli @@ -0,0 +1,121 @@ +open Names +open Pp + +(* + The mk_?_id function build different name w.r.t. a function + Each of their use is justified in the code +*) +val mk_rel_id : identifier -> identifier +val mk_correct_id : identifier -> identifier +val mk_complete_id : identifier -> identifier +val mk_equation_id : identifier -> identifier + + +val msgnl : std_ppcmds -> unit + +val invalid_argument : string -> 'a + +val fresh_id : identifier list -> string -> identifier +val fresh_name : identifier list -> string -> name +val get_name : identifier list -> ?default:string -> name -> name + +val array_get_start : 'a array -> 'a array + +val id_of_name : name -> identifier + +val locate_ind : Libnames.reference -> inductive +val locate_constant : Libnames.reference -> constant +val locate_with_msg : + Pp.std_ppcmds -> (Libnames.reference -> 'a) -> + Libnames.reference -> 'a + +val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list +val list_union_eq : + ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list +val list_add_set_eq : + ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list + +val chop_rlambda_n : int -> Rawterm.rawconstr -> + (name*Rawterm.rawconstr*bool) list * Rawterm.rawconstr + +val chop_rprod_n : int -> Rawterm.rawconstr -> + (name*Rawterm.rawconstr) list * Rawterm.rawconstr + +val def_of_const : Term.constr -> Term.constr +val eq : Term.constr Lazy.t +val refl_equal : Term.constr Lazy.t +val const_of_id: identifier -> constant +val jmeq : unit -> Term.constr +val jmeq_refl : unit -> Term.constr + +(* [save_named] is a copy of [Command.save_named] but uses + [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] + + + + DON'T USE IT if you cannot ensure that there is no VMcast in the proof + +*) + +(* val nf_betaiotazeta : Reductionops.reduction_function *) + +val new_save_named : bool -> unit + +val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> + Tacexpr.declaration_hook -> unit + +(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and + abort the proof +*) +val get_proof_clean : bool -> + Names.identifier * + (Entries.definition_entry * Decl_kinds.goal_kind * + Tacexpr.declaration_hook) + + + +(* [with_full_print f a] applies [f] to [a] in full printing environment + + This function preserves the print settings +*) +val with_full_print : ('a -> 'b) -> 'a -> 'b + + +(*****************) + +type function_info = + { + function_constant : constant; + graph_ind : inductive; + equation_lemma : constant option; + correctness_lemma : constant option; + completeness_lemma : constant option; + rect_lemma : constant option; + rec_lemma : constant option; + prop_lemma : constant option; + is_general : bool; + } + +val find_Function_infos : constant -> function_info +val find_Function_of_graph : inductive -> function_info +(* WARNING: To be used just after the graph definition !!! *) +val add_Function : bool -> constant -> unit + +val update_Function : function_info -> unit + + +(** debugging *) +val pr_info : function_info -> Pp.std_ppcmds +val pr_table : unit -> Pp.std_ppcmds + + +(* val function_debug : bool ref *) +val do_observe : unit -> bool +val do_rewrite_dependent : unit -> bool + +(* To localize pb *) +exception Building_graph of exn +exception Defining_principle of exn +exception ToShow of exn + +val is_strict_tcc : unit -> bool diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml new file mode 100644 index 00000000..8c22265d --- /dev/null +++ b/plugins/funind/invfun.ml @@ -0,0 +1,1020 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) + | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) + +let pr_bindings prc prlc = function + | Rawterm.ImplicitBindings l -> + brk (1,1) ++ str "with" ++ brk (1,1) ++ + Util.prlist_with_sep spc prc l + | Rawterm.ExplicitBindings l -> + brk (1,1) ++ str "with" ++ brk (1,1) ++ + Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l + | Rawterm.NoBindings -> mt () + + +let pr_with_bindings prc prlc (c,bl) = + prc c ++ hv 0 (pr_bindings prc prlc bl) + + + +let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = + pr_with_bindings prc prc (c,bl) + +(* The local debuging mechanism *) +let msgnl = Pp.msgnl + +let observe strm = + if do_observe () + then Pp.msgnl strm + else () + +let observennl strm = + if do_observe () + then begin Pp.msg strm;Pp.pp_flush () end + else () + + +let do_observe_tac s tac g = + let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + try + let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v + with e -> + msgnl (str "observation "++ s++str " raised exception " ++ + Cerrors.explain_exn e ++ str " on goal " ++ goal ); + raise e;; + + +let observe_tac s tac g = + if do_observe () + then do_observe_tac (str s) tac g + else tac g + +(* [nf_zeta] $\zeta$-normalization of a term *) +let nf_zeta = + Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + Environ.empty_env + Evd.empty + + +(* [id_to_constr id] finds the term associated to [id] in the global environment *) +let id_to_constr id = + try + Tacinterp.constr_of_id (Global.env ()) id + with Not_found -> + raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id)) + +(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] + (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. + + [generate_type true f i] returns + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, + graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion + + [generate_type false f i] returns + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, + res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion + *) + +let generate_type g_to_f f graph i = + (*i we deduce the number of arguments of the function and its returned type from the graph i*) + let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in + let ctxt,_ = decompose_prod_assum graph_arity in + let fun_ctxt,res_type = + match ctxt with + | [] | [_] -> anomaly "Not a valid context" + | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type + in + let nb_args = List.length fun_ctxt in + let args_from_decl i decl = + match decl with + | (_,Some _,_) -> incr i; failwith "args_from_decl" + | _ -> let j = !i in incr i;mkRel (nb_args - j + 1) + in + (*i We need to name the vars [res] and [fv] i*) + let res_id = + Namegen.next_ident_away_in_goal + (id_of_string "res") + (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt) + in + let fv_id = + Namegen.next_ident_away_in_goal + (id_of_string "fv") + (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt)) + in + (*i we can then type the argument to be applied to the function [f] i*) + let args_as_rels = + let i = ref 0 in + Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt))) + in + let args_as_rels = Array.map Termops.pop args_as_rels in + (*i + the hypothesis [res = fv] can then be computed + We will need to lift it by one in order to use it as a conclusion + i*) + let res_eq_f_of_args = + mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) + in + (*i + The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed + We will need to lift it by one in order to use it as a conclusion + i*) + let graph_applied = + let args_and_res_as_rels = + let i = ref 0 in + Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) ) + in + let args_and_res_as_rels = + Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels + in + mkApp(graph,args_and_res_as_rels) + in + (*i The [pre_context] is the defined to be the context corresponding to + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] + i*) + let pre_ctxt = + (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt + in + (*i and we can return the solution depending on which lemma type we are defining i*) + if g_to_f + then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args) + else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied) + + +(* + [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] + + WARNING: while convertible, [type_of body] and [type] can be non equal +*) +let find_induction_principle f = + let f_as_constant = match kind_of_term f with + | Const c' -> c' + | _ -> error "Must be used with a function" + in + let infos = find_Function_infos f_as_constant in + match infos.rect_lemma with + | None -> raise Not_found + | Some rect_lemma -> + let rect_lemma = mkConst rect_lemma in + let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in + rect_lemma,typ + + + +(* let fname = *) +(* match kind_of_term f with *) +(* | Const c' -> *) +(* id_of_label (con_label c') *) +(* | _ -> error "Must be used with a function" *) +(* in *) + +(* let princ_name = *) +(* ( *) +(* Indrec.make_elimination_ident *) +(* fname *) +(* InType *) +(* ) *) +(* in *) +(* let c = (\* mkConst(mk_from_const (destConst f) princ_name ) in *\) failwith "" in *) +(* c,Typing.type_of (Global.env ()) Evd.empty c *) + + +let rec generate_fresh_id x avoid i = + if i == 0 + then [] + else + let id = Namegen.next_ident_away_in_goal x avoid in + id::(generate_fresh_id x (id::avoid) (pred i)) + + +(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] + is the tactic used to prove correctness lemma. + + [functional_induction] is the tactic defined in [indfun] (dependency problem) + [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions + (resp. graphs of the functions and principles and correctness lemma types) to prove correct. + + [i] is the indice of the function to prove correct + + The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is + it looks like~: + [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, + res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res] + + + The sketch of the proof is the following one~: + \begin{enumerate} + \item intros until $x_n$ + \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i) + \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the + apply the corresponding constructor of the corresponding graph inductive. + \end{enumerate} + +*) +let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic = + fun g -> + (* first of all we recreate the lemmas types to be used as predicates of the induction principle + that is~: + \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] + *) + let lemmas = + Array.map + (fun (_,(ctxt,concl)) -> + match ctxt with + | [] | [_] | [_;_] -> anomaly "bad context" + | hres::res::(x,_,t)::ctxt -> + Termops.it_mkLambda_or_LetIn + ~init:(Termops.it_mkProd_or_LetIn ~init:concl [hres;res]) + ((x,None,t)::ctxt) + ) + lemmas_types_infos + in + (* we the get the definition of the graphs block *) + let graph_ind = destInd graphs_constr.(i) in + let kn = fst graph_ind in + let mib,_ = Global.lookup_inductive graph_ind in + (* and the principle to use in this lemma in $\zeta$ normal form *) + let f_principle,princ_type = schemes.(i) in + let princ_type = nf_zeta princ_type in + let princ_infos = Tactics.compute_elim_sig princ_type in + (* The number of args of the function is then easilly computable *) + let nb_fun_args = nb_prod (pf_concl g) - 2 in + let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in + let ids = args_names@(pf_ids_of_hyps g) in + (* Since we cannot ensure that the funcitonnal principle is defined in the + environement and due to the bug #1174, we will need to pose the principle + using a name + *) + let principle_id = Namegen.next_ident_away_in_goal (id_of_string "princ") ids in + let ids = principle_id :: ids in + (* We get the branches of the principle *) + let branches = List.rev princ_infos.branches in + (* and built the intro pattern for each of them *) + let intro_pats = + List.map + (fun (_,_,br_type) -> + List.map + (fun id -> dummy_loc, Genarg.IntroIdentifier id) + (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) + ) + branches + in + (* before building the full intro pattern for the principle *) + let pat = Some (dummy_loc,Genarg.IntroOrAndPattern intro_pats) in + let eq_ind = Coqlib.build_coq_eq () in + let eq_construct = mkConstruct((destInd eq_ind),1) in + (* The next to referencies will be used to find out which constructor to apply in each branch *) + let ind_number = ref 0 + and min_constr_number = ref 0 in + (* The tactic to prove the ith branch of the principle *) + let prove_branche i g = + (* We get the identifiers of this branch *) + let this_branche_ids = + List.fold_right + (fun (_,pat) acc -> + match pat with + | Genarg.IntroIdentifier id -> Idset.add id acc + | _ -> anomaly "Not an identifier" + ) + (List.nth intro_pats (pred i)) + Idset.empty + in + (* and get the real args of the branch by unfolding the defined constant *) + let pre_args,pre_tac = + List.fold_right + (fun (id,b,t) (pre_args,pre_tac) -> + if Idset.mem id this_branche_ids + then + match b with + | None -> (id::pre_args,pre_tac) + | Some b -> + (pre_args, + tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac + ) + + else (pre_args,pre_tac) + ) + (pf_hyps g) + ([],tclIDTAC) + in + (* + We can then recompute the arguments of the constructor. + For each [hid] introduced by this branch, if [hid] has type + $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are + [ fv (hid fv (refl_equal fv)) ]. + + If [hid] has another type the corresponding argument of the constructor is [hid] + *) + let constructor_args = + List.fold_right + (fun hid acc -> + let type_of_hid = pf_type_of g (mkVar hid) in + match kind_of_term type_of_hid with + | Prod(_,_,t') -> + begin + match kind_of_term t' with + | Prod(_,t'',t''') -> + begin + match kind_of_term t'',kind_of_term t''' with + | App(eq,args), App(graph',_) + when + (eq_constr eq eq_ind) && + array_exists (eq_constr graph') graphs_constr -> + ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) + ::args.(2)::acc) + | _ -> mkVar hid :: acc + end + | _ -> mkVar hid :: acc + end + | _ -> mkVar hid :: acc + ) pre_args [] + in + (* in fact we must also add the parameters to the constructor args *) + let constructor_args = + let params_id = fst (list_chop princ_infos.nparams args_names) in + (List.map mkVar params_id)@(List.rev constructor_args) + in + (* We then get the constructor corresponding to this branch and + modifies the references has needed i.e. + if the constructor is the last one of the current inductive then + add one the number of the inductive to take and add the number of constructor of the previous + graph to the minimal constructor number + *) + let constructor = + let constructor_num = i - !min_constr_number in + let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in + if constructor_num <= length + then + begin + (kn,!ind_number),constructor_num + end + else + begin + incr ind_number; + min_constr_number := !min_constr_number + length ; + (kn,!ind_number),1 + end + in + (* we can then build the final proof term *) + let app_constructor = applist((mkConstruct(constructor)),constructor_args) in + (* an apply the tactic *) + let res,hres = + match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with + | [res;hres] -> res,hres + | _ -> assert false + in + observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); + ( + tclTHENSEQ + [ + (* unfolding of all the defined variables introduced by this branch *) + observe_tac "unfolding" pre_tac; + (* $zeta$ normalizing of the conclusion *) + h_reduce + (Rawterm.Cbv + { Rawterm.all_flags with + Rawterm.rDelta = false ; + Rawterm.rConst = [] + } + ) + onConcl; + (* introducing the the result of the graph and the equality hypothesis *) + observe_tac "introducing" (tclMAP h_intro [res;hres]); + (* replacing [res] with its value *) + observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres)); + (* Conclusion *) + observe_tac "exact" (h_exact app_constructor) + ] + ) + g + in + (* end of branche proof *) + let param_names = fst (list_chop princ_infos.nparams args_names) in + let params = List.map mkVar param_names in + let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in + (* The bindings of the principle + that is the params of the principle and the different lemma types + *) + let bindings = + let params_bindings,avoid = + List.fold_left2 + (fun (bindings,avoid) (x,_,_) p -> + let id = Namegen.next_ident_away (Nameops.out_name x) avoid in + (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid + ) + ([],pf_ids_of_hyps g) + princ_infos.params + (List.rev params) + in + let lemmas_bindings = + List.rev (fst (List.fold_left2 + (fun (bindings,avoid) (x,_,_) p -> + let id = Namegen.next_ident_away (Nameops.out_name x) avoid in + (dummy_loc,Rawterm.NamedHyp id,(nf_zeta p))::bindings,id::avoid) + ([],avoid) + princ_infos.predicates + (lemmas))) + in + Rawterm.ExplicitBindings (params_bindings@lemmas_bindings) + in + tclTHENSEQ + [ observe_tac "intro args_names" (tclMAP h_intro args_names); + observe_tac "principle" (assert_by + (Name principle_id) + princ_type + (h_exact f_principle)); + tclTHEN_i + (observe_tac "functional_induction" ( + fun g -> + observe + (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings)); + functional_induction false (applist(funs_constr.(i),List.map mkVar args_names)) + (Some (mkVar principle_id,bindings)) + pat g + )) + (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) + ] + g + +(* [generalize_dependent_of x hyp g] + generalize every hypothesis which depends of [x] but [hyp] +*) +let generalize_dependent_of x hyp g = + tclMAP + (function + | (id,None,t) when not (id = hyp) && + (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id]) + | _ -> tclIDTAC + ) + (pf_hyps g) + g + + + + + + (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis + (unfolding, substituting, destructing cases \ldots) + *) +let rec intros_with_rewrite g = + observe_tac "intros_with_rewrite" intros_with_rewrite_aux g +and intros_with_rewrite_aux : tactic = + fun g -> + let eq_ind = Coqlib.build_coq_eq () in + match kind_of_term (pf_concl g) with + | Prod(_,t,t') -> + begin + match kind_of_term t with + | App(eq,args) when (eq_constr eq eq_ind) -> + if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) + then + let id = pf_get_new_id (id_of_string "y") g in + tclTHENSEQ [ h_intro id; thin [id]; intros_with_rewrite ] g + + else if isVar args.(1) + then + let id = pf_get_new_id (id_of_string "y") g in + tclTHENSEQ [ h_intro id; + generalize_dependent_of (destVar args.(1)) id; + tclTRY (Equality.rewriteLR (mkVar id)); + intros_with_rewrite + ] + g + else + begin + let id = pf_get_new_id (id_of_string "y") g in + tclTHENSEQ[ + h_intro id; + tclTRY (Equality.rewriteLR (mkVar id)); + intros_with_rewrite + ] g + end + | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> + Tauto.tauto g + | Case(_,_,v,_) -> + tclTHENSEQ[ + h_case false (v,Rawterm.NoBindings); + intros_with_rewrite + ] g + | LetIn _ -> + tclTHENSEQ[ + h_reduce + (Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) + onConcl + ; + intros_with_rewrite + ] g + | _ -> + let id = pf_get_new_id (id_of_string "y") g in + tclTHENSEQ [ h_intro id;intros_with_rewrite] g + end + | LetIn _ -> + tclTHENSEQ[ + h_reduce + (Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) + onConcl + ; + intros_with_rewrite + ] g + | _ -> tclIDTAC g + +let rec reflexivity_with_destruct_cases g = + let destruct_case () = + try + match kind_of_term (snd (destApp (pf_concl g))).(2) with + | Case(_,_,v,_) -> + tclTHENSEQ[ + h_case false (v,Rawterm.NoBindings); + intros; + observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases + ] + | _ -> reflexivity + with _ -> reflexivity + in + let eq_ind = Coqlib.build_coq_eq () in + let discr_inject = + Tacticals.onAllHypsAndConcl ( + fun sc g -> + match sc with + None -> tclIDTAC g + | Some id -> + match kind_of_term (pf_type_of g (mkVar id)) with + | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> + if Equality.discriminable (pf_env g) (project g) t1 t2 + then Equality.discrHyp id g + else if Equality.injectable (pf_env g) (project g) t1 t2 + then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite] g + else tclIDTAC g + | _ -> tclIDTAC g + ) + in + (tclFIRST + [ reflexivity; + tclTHEN (tclPROGRESS discr_inject) (destruct_case ()); + (* We reach this point ONLY if + the same value is matched (at least) two times + along binding path. + In this case, either we have a discriminable hypothesis and we are done, + either at least an injectable one and we do the injection before continuing + *) + tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases + ]) + g + + +(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] + is the tactic used to prove completness lemma. + + [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions + (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. + + [i] is the indice of the function to prove complete + + The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is + it looks like~: + [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, + graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in] + + + The sketch of the proof is the following one~: + \begin{enumerate} + \item intros until $H:graph\ x_1\ldots x_n\ res$ + \item $elim\ H$ using schemes.(i) + \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has + type [x=?] with [x] a variable, then subst [x], + if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else + if [h] is a match then destruct it, else do just introduce it, + after all intros, the conclusion should be a reflexive equality. + \end{enumerate} + +*) + + +let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = + fun g -> + (* We compute the types of the different mutually recursive lemmas + in $\zeta$ normal form + *) + let lemmas = + Array.map + (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt)) + lemmas_types_infos + in + (* We get the constant and the principle corresponding to this lemma *) + let f = funcs.(i) in + let graph_principle = nf_zeta schemes.(i) in + let princ_type = pf_type_of g graph_principle in + let princ_infos = Tactics.compute_elim_sig princ_type in + (* Then we get the number of argument of the function + and compute a fresh name for each of them + *) + let nb_fun_args = nb_prod (pf_concl g) - 2 in + let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in + let ids = args_names@(pf_ids_of_hyps g) in + (* and fresh names for res H and the principle (cf bug bug #1174) *) + let res,hres,graph_principle_id = + match generate_fresh_id (id_of_string "z") ids 3 with + | [res;hres;graph_principle_id] -> res,hres,graph_principle_id + | _ -> assert false + in + let ids = res::hres::graph_principle_id::ids in + (* we also compute fresh names for each hyptohesis of each branche of the principle *) + let branches = List.rev princ_infos.branches in + let intro_pats = + List.map + (fun (_,_,br_type) -> + List.map + (fun id -> id) + (generate_fresh_id (id_of_string "y") ids (nb_prod br_type)) + ) + branches + in + (* We will need to change the function by its body + using [f_equation] if it is recursive (that is the graph is infinite + or unfold if the graph is finite + *) + let rewrite_tac j ids : tactic = + let graph_def = graphs.(j) in + let infos = try find_Function_infos (destConst funcs.(j)) with Not_found -> error "No graph found" in + if infos.is_general || Rtree.is_infinite graph_def.mind_recargs + then + let eq_lemma = + try Option.get (infos).equation_lemma + with Option.IsNone -> anomaly "Cannot find equation lemma" + in + tclTHENSEQ[ + tclMAP h_intro ids; + Equality.rewriteLR (mkConst eq_lemma); + (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) + h_reduce + (Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) + onConcl + ; + h_generalize (List.map mkVar ids); + thin ids + ] + else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))] + in + (* The proof of each branche itself *) + let ind_number = ref 0 in + let min_constr_number = ref 0 in + let prove_branche i g = + (* we fist compute the inductive corresponding to the branch *) + let this_ind_number = + let constructor_num = i - !min_constr_number in + let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in + if constructor_num <= length + then !ind_number + else + begin + incr ind_number; + min_constr_number := !min_constr_number + length; + !ind_number + end + in + let this_branche_ids = List.nth intro_pats (pred i) in + tclTHENSEQ[ + (* we expand the definition of the function *) + observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); + (* introduce hypothesis with some rewrite *) + observe_tac "intros_with_rewrite" intros_with_rewrite; + (* The proof is (almost) complete *) + observe_tac "reflexivity" (reflexivity_with_destruct_cases) + ] + g + in + let params_names = fst (list_chop princ_infos.nparams args_names) in + let params = List.map mkVar params_names in + tclTHENSEQ + [ tclMAP h_intro (args_names@[res;hres]); + observe_tac "h_generalize" + (h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); + h_intro graph_principle_id; + observe_tac "" (tclTHEN_i + (observe_tac "elim" ((elim false (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings))))) + (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) + ] + g + + + + +let do_save () = Lemmas.save_named false + + +(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness + lemmas for each function in [funs] w.r.t. [graphs] + + [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and + [functional_induction] is Indfun.functional_induction (same pb) +*) + +let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = + let funs = Array.of_list funs and graphs = Array.of_list graphs in + let funs_constr = Array.map mkConst funs in + try + let graphs_constr = Array.map mkInd graphs in + let lemmas_types_infos = + Util.array_map2_i + (fun i f_constr graph -> + let const_of_f = destConst f_constr in + let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = + generate_type false const_of_f graph i + in + let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in + let type_of_lemma = nf_zeta type_of_lemma in + observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); + type_of_lemma,type_info + ) + funs_constr + graphs_constr + in + let schemes = + (* The functional induction schemes are computed and not saved if there is more that one function + if the block contains only one function we can safely reuse [f_rect] + *) + try + if Array.length funs_constr <> 1 then raise Not_found; + [| find_induction_principle funs_constr.(0) |] + with Not_found -> + Array.of_list + (List.map + (fun entry -> + (entry.Entries.const_entry_body, Option.get entry.Entries.const_entry_type ) + ) + (make_scheme (array_map_to_list (fun const -> const,Rawterm.RType None) funs)) + ) + in + let proving_tac = + prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = id_of_label (con_label f_as_constant) in + Lemmas.start_proof + (*i The next call to mk_correct_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + (mk_correct_id f_id) + (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) + (fst lemmas_types_infos.(i)) + (fun _ _ -> ()); + Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i)); + do_save (); + let finfo = find_Function_infos f_as_constant in + update_Function + {finfo with + correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id))) + } + + ) + funs; + let lemmas_types_infos = + Util.array_map2_i + (fun i f_constr graph -> + let const_of_f = destConst f_constr in + let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = + generate_type true const_of_f graph i + in + let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in + let type_of_lemma = nf_zeta type_of_lemma in + observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); + type_of_lemma,type_info + ) + funs_constr + graphs_constr + in + let kn,_ as graph_ind = destInd graphs_constr.(0) in + let mib,mip = Global.lookup_inductive graph_ind in + let schemes = + Array.of_list + (Indrec.build_mutual_induction_scheme (Global.env ()) Evd.empty + (Array.to_list + (Array.mapi + (fun i _ -> (kn,i),true,InType) + mib.Declarations.mind_packets + ) + ) + ) + in + let proving_tac = + prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = id_of_label (con_label f_as_constant) in + Lemmas.start_proof + (*i The next call to mk_complete_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + (mk_complete_id f_id) + (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) + (fst lemmas_types_infos.(i)) + (fun _ _ -> ()); + Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i)); + do_save (); + let finfo = find_Function_infos f_as_constant in + update_Function + {finfo with + completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id))) + } + ) + funs; + with e -> + (* In case of problem, we reset all the lemmas *) + (*i The next call to mk_correct_id is valid since we are erasing the lemmas + Ensures by: obvious + i*) + let first_lemma_id = + let f_id = id_of_label (con_label funs.(0)) in + + mk_correct_id f_id + in + ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ()); + raise e + + + + + +(***********************************************) + +(* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res + when [kn] denotes a graph block into + f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result + + if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing +*) +let revert_graph kn post_tac hid g = + let typ = pf_type_of g (mkVar hid) in + match kind_of_term typ with + | App(i,args) when isInd i -> + let ((kn',num) as ind') = destInd i in + if kn = kn' + then (* We have generated a graph hypothesis so that we must change it if we can *) + let info = + try find_Function_of_graph ind' + with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) + anomaly "Cannot retrieve infos about a mutual block" + in + (* if we can find a completeness lemma for this function + then we can come back to the functional form. If not, we do nothing + *) + match info.completeness_lemma with + | None -> tclIDTAC g + | Some f_complete -> + let f_args,res = array_chop (Array.length args - 1) args in + tclTHENSEQ + [ + h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; + thin [hid]; + h_intro hid; + post_tac hid + ] + g + + else tclIDTAC g + | _ -> tclIDTAC g + + +(* + [functional_inversion hid fconst f_correct ] is the functional version of [inversion] + + [hid] is the hypothesis to invert, [fconst] is the function to invert and [f_correct] + is the correctness lemma for [fconst]. + + The sketch is the follwing~: + \begin{enumerate} + \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ + (fails if it is not possible) + \item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct] + \item apply [inversion] on [hid] + \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever + such a lemma exists) + \end{enumerate} +*) + +let functional_inversion kn hid fconst f_correct : tactic = + fun g -> + let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in + let type_of_h = pf_type_of g (mkVar hid) in + match kind_of_term type_of_h with + | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + let pre_tac,f_args,res = + match kind_of_term args.(1),kind_of_term args.(2) with + | App(f,f_args),_ when eq_constr f fconst -> + ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2)) + |_,App(f,f_args) when eq_constr f fconst -> + ((fun hid -> tclIDTAC),f_args,args.(1)) + | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) + in + tclTHENSEQ[ + pre_tac hid; + h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; + thin [hid]; + h_intro hid; + Inv.inv FullInversion None (Rawterm.NamedHyp hid); + (fun g -> + let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in + tclMAP (revert_graph kn pre_tac) (hid::new_ids) g + ); + ] g + | _ -> tclFAIL 1 (mt ()) g + + + +let invfun qhyp f = + let f = + match f with + | ConstRef f -> f + | _ -> raise (Util.UserError("",str "Not a function")) + in + try + let finfos = find_Function_infos f in + let f_correct = mkConst(Option.get finfos.correctness_lemma) + and kn = fst finfos.graph_ind + in + Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp + with + | Not_found -> error "No graph found" + | Option.IsNone -> error "Cannot use equivalence with graph!" + + +let invfun qhyp f g = + match f with + | Some f -> invfun qhyp f g + | None -> + Tactics.try_intros_until + (fun hid g -> + let hyp_typ = pf_type_of g (mkVar hid) in + match kind_of_term hyp_typ with + | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + begin + let f1,_ = decompose_app args.(1) in + try + if not (isConst f1) then failwith ""; + let finfos = find_Function_infos (destConst f1) in + let f_correct = mkConst(Option.get finfos.correctness_lemma) + and kn = fst finfos.graph_ind + in + functional_inversion kn hid f1 f_correct g + with | Failure "" | Option.IsNone | Not_found -> + try + let f2,_ = decompose_app args.(2) in + if not (isConst f2) then failwith ""; + let finfos = find_Function_infos (destConst f2) in + let f_correct = mkConst(Option.get finfos.correctness_lemma) + and kn = fst finfos.graph_ind + in + functional_inversion kn hid f2 f_correct g + with + | Failure "" -> + errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function") + | Option.IsNone -> + if do_observe () + then + error "Cannot use equivalence with graph for any side of the equality" + else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + | Not_found -> + if do_observe () + then + error "No graph found for any side of equality" + else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + end + | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") + ) + qhyp + g diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml new file mode 100644 index 00000000..f596e2d7 --- /dev/null +++ b/plugins/funind/merge.ml @@ -0,0 +1,1032 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* false) t1 t2 + then true + else false + +let rec compare_constr' t1 t2 = + if compare_constr_nosub t1 t2 + then true + else (compare_constr (compare_constr') t1 t2) + +let rec substitterm prof t by_t in_u = + if (compare_constr' (lift prof t) in_u) + then (lift prof by_t) + else map_constr_with_binders succ + (fun i -> substitterm i t by_t) prof in_u + +let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl + +let understand = Pretyping.Default.understand Evd.empty (Global.env()) + +(** Operations on names and identifiers *) +let id_of_name = function + Anonymous -> id_of_string "H" + | Name id -> id;; +let name_of_string str = Name (id_of_string str) +let string_of_name nme = string_of_id (id_of_name nme) + +(** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) +let isVarf f x = + match x with + | RVar (_,x) -> Pervasives.compare x f = 0 + | _ -> false + +(** [ident_global_exist id] returns true if identifier [id] is linked + in global environment. *) +let ident_global_exist id = + try + let ans = CRef (Libnames.Ident (dummy_loc,id)) in + let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in + true + with _ -> false + +(** [next_ident_fresh id] returns a fresh identifier (ie not linked in + global env) with base [id]. *) +let next_ident_fresh (id:identifier) = + let res = ref id in + while ident_global_exist !res do res := Nameops.lift_subscript !res done; + !res + + +(** {2 Debugging} *) +(* comment this line to see debug msgs *) +let msg x = () ;; let pr_lconstr c = str "" +(* uncomment this to see debugging *) +let prconstr c = msg (str" " ++ Printer.pr_lconstr c) +let prconstrnl c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") +let prlistconstr lc = List.iter prconstr lc +let prstr s = msg(str s) +let prNamedConstr s c = + begin + msg(str ""); + msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} "); + msg(str ""); + end +let prNamedRConstr s c = + begin + msg(str ""); + msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} "); + msg(str ""); + end +let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc +let prNamedLConstr s lc = + begin + prstr "[§§§ "; + prstr s; + prNamedLConstr_aux lc; + prstr " §§§]\n"; + end +let prNamedLDecl s lc = + begin + prstr s; prstr "\n"; + List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc; + prstr "\n"; + end +let prNamedRLDecl s lc = + begin + prstr s; prstr "\n"; prstr "{§§ "; + List.iter + (fun x -> + match x with + | (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp + | (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy + | _ -> assert false + ) lc; + prstr " §§}\n"; + prstr "\n"; + end + +let showind (id:identifier) = + let cstrid = Tacinterp.constr_of_id (Global.env()) id in + let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in + let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in + List.iter (fun (nm, optcstr, tp) -> + print_string (string_of_name nm^":"); + prconstr tp; print_string "\n") + ib1.mind_arity_ctxt; + (match ib1.mind_arity with + | Monomorphic x -> + Printf.printf "arity :"; prconstr x.mind_user_arity + | Polymorphic x -> + Printf.printf "arity : universe?"); + Array.iteri + (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) + ib1.mind_user_lc + +(** {2 Misc} *) + +exception Found of int + +(* Array scanning *) + +let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int = + try + for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done; + Array.length arr (* all elt are positive *) + with Found i -> i + +let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = + let i = ref 0 in + Array.fold_left + (fun acc x -> + let res = f !i acc x in i := !i + 1; res) + acc arr + +(* Like list_chop but except that [i] is the size of the suffix of [l]. *) +let list_chop_end i l = + let size_prefix = List.length l -i in + if size_prefix < 0 then failwith "list_chop_end" + else list_chop size_prefix l + +let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = + let i = ref 0 in + List.fold_left + (fun acc x -> + let res = f !i acc x in i := !i + 1; res) + acc arr + +let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = + let i = ref 0 in + List.filter (fun x -> let res = f !i x in i := !i + 1; res) l + + +(** Iteration module *) +module For = +struct + let rec map i j (f: int -> 'a) = if i>j then [] else f i :: (map (i+1) j f) + let rec foldup i j (f: 'a -> int -> 'a) acc = + if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc + let rec folddown i j (f: 'a -> int -> 'a) acc = + if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc + let fold i j = if i Printf.sprintf "Linked %d" i + | Unlinked -> Printf.sprintf "Unlinked" + | Funres -> Printf.sprintf "Funres" + +let linkmonad f lnkvar = + match lnkvar with + | Linked i -> Linked (f i) + | Unlinked -> Unlinked + | Funres -> Funres + +let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar + +(* This map is used to deal with debruijn linked indices. *) +module Link = Map.Make (struct type t = int let compare = Pervasives.compare end) + +let pr_links l = + Printf.printf "links:\n"; + Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l; + Printf.printf "_____________\n" + +type 'a merged_arg = + | Prm_stable of 'a + | Prm_linked of 'a + | Prm_arg of 'a + | Arg_stable of 'a + | Arg_linked of 'a + | Arg_funres + +(** Information about graph merging of two inductives. + All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *) + +type merge_infos = + { + ident:identifier; (** new inductive name *) + mib1: mutual_inductive_body; + oib1: one_inductive_body; + mib2: mutual_inductive_body; + oib2: one_inductive_body; + + (** Array of links of the first inductive (should be all stable) *) + lnk1: int merged_arg array; + + (** Array of links of the second inductive (point to the first ind param/args) *) + lnk2: int merged_arg array; + + (** rec params which remain rec param (ie not linked) *) + recprms1: rel_declaration list; + recprms2: rel_declaration list; + nrecprms1: int; + nrecprms2: int; + + (** rec parms which became non parm (either linked to something + or because after a rec parm that became non parm) *) + otherprms1: rel_declaration list; + otherprms2: rel_declaration list; + notherprms1:int; + notherprms2:int; + + (** args which remain args in merge *) + args1:rel_declaration list; + args2:rel_declaration list; + nargs1:int; + nargs2:int; + + (** functional result args *) + funresprms1: rel_declaration list; + funresprms2: rel_declaration list; + nfunresprms1:int; + nfunresprms2:int; + } + + +let pr_merginfo x = + let i,s= + match x with + | Prm_linked i -> Some i,"Prm_linked" + | Arg_linked i -> Some i,"Arg_linked" + | Prm_stable i -> Some i,"Prm_stable" + | Prm_arg i -> Some i,"Prm_arg" + | Arg_stable i -> Some i,"Arg_stable" + | Arg_funres -> None , "Arg_funres" in + match i with + | Some i -> Printf.sprintf "%s(%d)" s i + | None -> Printf.sprintf "%s" s + +let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false + +(* ?? prm_linked?? *) +let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false + +let is_stable x = + match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false + +let isArg_funres x = match x with Arg_funres -> true | _ -> false + +let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list = + let prms = list_filteri (fun i _ -> isPrm_stable lnk.(i)) l in + let args = list_filteri (fun i _ -> isArg_stable lnk.(i)) l in + let fres = list_filteri (fun i _ -> isArg_funres lnk.(i)) l in + prms@args@fres + +(** Reverse the link map, keeping only linked vars, elements are list + of int as several vars may be linked to the same var. *) +let revlinked lnk = + For.fold 0 (Array.length lnk - 1) + (fun acc k -> + match lnk.(k) with + | Unlinked | Funres -> acc + | Linked i -> + let old = try Link.find i acc with Not_found -> [] in + Link.add i (k::old) acc) + Link.empty + +let array_switch arr i j = + let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux + +let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = + let larr = Array.of_list l in + let _ = + Array.iteri + (fun j x -> + match x with + | Prm_linked i -> array_switch larr i j + | Arg_linked i -> array_switch larr i j + | Prm_stable i -> () + | Prm_arg i -> () + | Arg_stable i -> () + | Arg_funres -> () + ) lnk in + filter_shift_stable lnk (Array.to_list larr) + + + + +(** {1 Utilities for merging} *) + +let ind1name = id_of_string "__ind1" +let ind2name = id_of_string "__ind2" + +(** Performs verifications on two graphs before merging: they must not + be co-inductive, and for the moment they must not be mutual + either. *) +let verify_inds mib1 mib2 = + if not mib1.mind_finite then error "First argument is coinductive"; + if not mib2.mind_finite then error "Second argument is coinductive"; + if mib1.mind_ntypes <> 1 then error "First argument is mutual"; + if mib2.mind_ntypes <> 1 then error "Second argument is mutual"; + () + +(* +(** [build_raw_params prms_decl avoid] returns a list of variables + attributed to the list of decl [prms_decl], avoiding names in + [avoid]. *) +let build_raw_params prms_decl avoid = + let dummy_constr = compose_prod (List.map (fun (x,_,z) -> x,z) prms_decl) (mkRel 1) in + let _ = prNamedConstr "DUMMY" dummy_constr in + let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in + let _ = prNamedRConstr "RAWDUMMY" dummy_rawconstr in + let res,_ = raw_decompose_prod dummy_rawconstr in + let comblist = List.combine prms_decl res in + comblist, res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr))) +*) + +let ids_of_rawlist avoid rawl = + List.fold_left Idset.union avoid (List.map ids_of_rawterm rawl) + + + +(** {1 Merging function graphs} *) + +(** [shift_linked_params mib1 mib2 lnk] Computes which parameters (rec + uniform and ordinary ones) of mutual inductives [mib1] and [mib2] + remain uniform when linked by [lnk]. All parameters are + considered, ie we take parameters of the first inductive body of + [mib1] and [mib2]. + + Explanation: The two inductives have parameters, some of the first + are recursively uniform, some of the last are functional result of + the functional graph. + + (I x1 x2 ... xk ... xk' ... xn) + (J y1 y2 ... xl ... yl' ... ym) + + Problem is, if some rec unif params are linked to non rec unif + ones, they become non rec (and the following too). And functinal + argument have to be shifted at the end *) +let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id = + let _ = prstr "\nYOUHOU shift\n" in + let linked_targets = revlinked lnk2 in + let is_param_of_mib1 x = x < mib1.mind_nparams_rec in + let is_param_of_mib2 x = x < mib2.mind_nparams_rec in + let is_targetted_by_non_recparam_lnk1 i = + try + let targets = Link.find i linked_targets in + List.exists (fun x -> not (is_param_of_mib2 x)) targets + with Not_found -> false in + let mlnk1 = + Array.mapi + (fun i lkv -> + let isprm = is_param_of_mib1 i in + let prmlost = is_targetted_by_non_recparam_lnk1 i in + match isprm , prmlost, lnk1.(i) with + | true , true , _ -> Prm_arg i (* recparam becoming ordinary *) + | true , false , _-> Prm_stable i (* recparam remains recparam*) + | false , false , Funres -> Arg_funres + | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *) + | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *) + lnk1 in + let mlnk2 = + Array.mapi + (fun i lkv -> + (* Is this correct if some param of ind2 is lost? *) + let isprm = is_param_of_mib2 i in + match isprm , lnk2.(i) with + | true , Linked j when not (is_param_of_mib1 j) -> + Prm_arg j (* recparam becoming ordinary *) + | true , Linked j -> Prm_linked j (*recparam linked to recparam*) + | true , Unlinked -> Prm_stable i (* recparam remains recparam*) + | false , Linked j -> Arg_linked j (* Args of lnk2 lost *) + | false , Unlinked -> Arg_stable i (* Args of lnk2 remains *) + | false , Funres -> Arg_funres + | true , Funres -> assert false (* fun res cannot be a rec param *) + ) + lnk2 in + let oib1 = mib1.mind_packets.(0) in + let oib2 = mib2.mind_packets.(0) in + (* count params remaining params *) + let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in + let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in + let bldprms arity_ctxt mlnk = + list_fold_lefti + (fun i (acc1,acc2,acc3,acc4) x -> + prstr (pr_merginfo mlnk.(i));prstr "\n"; + match mlnk.(i) with + | Prm_stable _ -> x::acc1 , acc2 , acc3, acc4 + | Prm_arg _ -> acc1 , x::acc2 , acc3, acc4 + | Arg_stable _ -> acc1 , acc2 , x::acc3, acc4 + | Arg_funres -> acc1 , acc2 , acc3, x::acc4 + | _ -> acc1 , acc2 , acc3, acc4) + ([],[],[],[]) arity_ctxt in +(* let arity_ctxt2 = + build_raw_params oib2.mind_arity_ctxt + (Idset.elements (ids_of_rawterm oib1.mind_arity_ctxt)) in*) + let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in + let _ = prstr "\n\n\n" in + let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in + let _ = prstr "\notherprms1:\n" in + let _ = + List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") + otherprms1 in + let _ = prstr "\notherprms2:\n" in + let _ = + List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") + otherprms2 in + { + ident=id; + mib1=mib1; + oib1 = oib1; + mib2=mib2; + oib2 = oib2; + lnk1 = mlnk1; + lnk2 = mlnk2; + nrecprms1 = n_params1; + recprms1 = recprms1; + otherprms1 = otherprms1; + args1 = args1; + funresprms1 = funresprms1; + notherprms1 = Array.length mlnk1 - n_params1; + nfunresprms1 = List.length funresprms1; + nargs1 = List.length args1; + nrecprms2 = n_params2; + recprms2 = recprms2; + otherprms2 = otherprms2; + args2 = args2; + funresprms2 = funresprms2; + notherprms2 = Array.length mlnk2 - n_params2; + nargs2 = List.length args2; + nfunresprms2 = List.length funresprms2; + } + + + + +(** {1 Merging functions} *) + +exception NoMerge + +let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = + let lnk = Array.append shift.lnk1 shift.lnk2 in + match c1 , c2 with + | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> + let _ = prstr "\nICI1!\n";Pp.flush_all() in + let args = filter_shift_stable lnk (arr1 @ arr2) in + RApp (dummy_loc,RVar (dummy_loc,shift.ident) , args) + | RApp(_,f1, arr1), RApp(_,f2,arr2) -> raise NoMerge + | RLetIn(_,nme,bdy,trm) , _ -> + let _ = prstr "\nICI2!\n";Pp.flush_all() in + let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in + RLetIn(dummy_loc,nme,bdy,newtrm) + | _, RLetIn(_,nme,bdy,trm) -> + let _ = prstr "\nICI3!\n";Pp.flush_all() in + let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in + RLetIn(dummy_loc,nme,bdy,newtrm) + | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in + raise NoMerge + +let rec merge_app_unsafe c1 c2 shift filter_shift_stable = + let lnk = Array.append shift.lnk1 shift.lnk2 in + match c1 , c2 with + | RApp(_,f1, arr1), RApp(_,f2,arr2) -> + let args = filter_shift_stable lnk (arr1 @ arr2) in + RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args) + (* FIXME: what if the function appears in the body of the let? *) + | RLetIn(_,nme,bdy,trm) , _ -> + let _ = prstr "\nICI2 '!\n";Pp.flush_all() in + let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in + RLetIn(dummy_loc,nme,bdy,newtrm) + | _, RLetIn(_,nme,bdy,trm) -> + let _ = prstr "\nICI3 '!\n";Pp.flush_all() in + let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in + RLetIn(dummy_loc,nme,bdy,newtrm) + | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge + + + +(* Heuristic when merging two lists of hypothesis: merge every rec + calls of branch 1 with all rec calls of branch 2. *) +(* TODO: reecrire cette heuristique (jusqu'a merge_types) *) +let rec merge_rec_hyps shift accrec + (ltyp:(Names.name * rawconstr option * rawconstr option) list) + filter_shift_stable : (Names.name * rawconstr option * rawconstr option) list = + let mergeonehyp t reldecl = + match reldecl with + | (nme,x,Some (RApp(_,i,args) as ind)) + -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable) + | (nme,Some _,None) -> error "letins with recursive calls not treated yet" + | (nme,None,Some _) -> assert false + | (nme,None,None) | (nme,Some _,Some _) -> assert false in + match ltyp with + | [] -> [] + | (nme,None,Some (RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> + let rechyps = List.map (mergeonehyp t) accrec in + rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable + | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable + + +let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift = + List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec + + +let find_app (nme:identifier) ltyp = + try + ignore + (List.map + (fun x -> + match x with + | _,None,Some (RApp(_,f,_)) when isVarf nme f -> raise (Found 0) + | _ -> ()) + ltyp); + false + with Found _ -> true + +let prnt_prod_or_letin nm letbdy typ = + match letbdy , typ with + | Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy + | None , Some tp -> prNamedRConstr (string_of_name nm) tp + | _ , _ -> assert false + + +let rec merge_types shift accrec1 + (ltyp1:(name * rawconstr option * rawconstr option) list) + (concl1:rawconstr) (ltyp2:(name * rawconstr option * rawconstr option) list) concl2 + : (name * rawconstr option * rawconstr option) list * rawconstr = + let _ = prstr "MERGE_TYPES\n" in + let _ = prstr "ltyp 1 : " in + let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in + let _ = prstr "\nltyp 2 : " in + let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp2 in + let _ = prstr "\n" in + let res = + match ltyp1 with + | [] -> + let isrec1 = (accrec1<>[]) in + let isrec2 = find_app ind2name ltyp2 in + let rechyps = + if isrec1 && isrec2 + then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *) + merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 + filter_shift_stable_right + @ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2] + filter_shift_stable + else if isrec1 + (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *) + then + merge_rec_hyps shift accrec1 + (ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable + else if isrec2 + then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 + filter_shift_stable_right + else ltyp2 in + let _ = prstr"\nrechyps : " in + let _ = List.iter(fun (nm,lbdy,tp)-> prnt_prod_or_letin nm lbdy tp) rechyps in + let _ = prstr "MERGE CONCL : " in + let _ = prNamedRConstr "concl1" concl1 in + let _ = prstr " with " in + let _ = prNamedRConstr "concl2" concl2 in + let _ = prstr "\n" in + let concl = + merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in + let _ = prstr "FIN " in + let _ = prNamedRConstr "concl" concl in + let _ = prstr "\n" in + + rechyps , concl + | (nme,None, Some t1)as e ::lt1 -> + (match t1 with + | RApp(_,f,carr) when isVarf ind1name f -> + merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 + | _ -> + let recres, recconcl2 = + merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in + ((nme,None,Some t1) :: recres) , recconcl2) + | (nme,Some bd, None) ::lt1 -> + (* FIXME: what if ind1name appears in bd? *) + let recres, recconcl2 = + merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in + ((nme,Some bd,None) :: recres) , recconcl2 + | (_,None,None)::_ | (_,Some _,Some _)::_ -> assert false + in + res + + +(** [build_link_map_aux allargs1 allargs2 shift] returns the mapping of + linked args [allargs2] to target args of [allargs1] as specified + in [shift]. [allargs1] and [allargs2] are in reverse order. Also + returns the list of unlinked vars of [allargs2]. *) +let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array) + (lnk:int merged_arg array) = + array_fold_lefti + (fun i acc e -> + if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *) + else + match e with + | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc + | _ -> acc) + Idmap.empty lnk + +let build_link_map allargs1 allargs2 lnk = + let allargs1 = + Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs1)) in + let allargs2 = + Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs2)) in + build_link_map_aux allargs1 allargs2 lnk + + +(** [merge_one_constructor lnk shift typcstr1 typcstr2] merges the two + constructor rawtypes [typcstr1] and [typcstr2]. [typcstr1] and + [typcstr2] contain all parameters (including rec. unif. ones) of + their inductive. + + if [typcstr1] and [typcstr2] are of the form: + + forall recparams1, forall ordparams1, H1a -> H2a... (I1 x1 y1 ... z1) + forall recparams2, forall ordparams2, H2b -> H2b... (I2 x2 y2 ... z2) + + we build: + + forall recparams1 (recparams2 without linked params), + forall ordparams1 (ordparams2 without linked params), + H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ... + -> (newI x1 ... z1 x2 y2 ...z2 without linked params) + + where Hix' have been adapted, ie: + - linked vars have been changed, + - rec calls to I1 and I2 have been replaced by rec calls to + newI. More precisely calls to I1 and I2 have been merge by an + experimental heuristic (in particular if n o rec calls for I1 + or I2 is found, we use the conclusion as a rec call). See + [merge_types] above. + + Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint. + + TODO: return nothing if equalities (after linking) are contradictory. *) +let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr) + (typcstr2:rawconstr) : rawconstr = + (* FIXME: les noms des parametres corerspondent en principe au + parametres du niveau mib, mais il faudrait s'en assurer *) + (* shift.nfunresprmsx last args are functional result *) + let nargs1 = + shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in + let nargs2 = + shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in + let allargs1,rest1 = raw_decompose_prod_or_letin_n nargs1 typcstr1 in + let allargs2,rest2 = raw_decompose_prod_or_letin_n nargs2 typcstr2 in + (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *) + let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in + let rest2 = change_vars linked_map rest2 in + let hyps1,concl1 = raw_decompose_prod_or_letin rest1 in + let hyps2,concl2' = raw_decompose_prod_or_letin rest2 in + let ltyp,concl2 = + merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in + let _ = prNamedRLDecl "ltyp result:" ltyp in + let typ = raw_compose_prod_or_letin concl2 (List.rev ltyp) in + let revargs1 = + list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in + let _ = prNamedRLDecl "ltyp allargs1" allargs1 in + let _ = prNamedRLDecl "ltyp revargs1" revargs1 in + let revargs2 = + list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in + let _ = prNamedRLDecl "ltyp allargs2" allargs2 in + let _ = prNamedRLDecl "ltyp revargs2" revargs2 in + let typwithprms = + raw_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in + typwithprms + + +(** constructor numbering *) +let fresh_cstror_suffix , cstror_suffix_init = + let cstror_num = ref 0 in + (fun () -> + let res = string_of_int !cstror_num in + cstror_num := !cstror_num + 1; + res) , + (fun () -> cstror_num := 0) + +(** [merge_constructor_id id1 id2 shift] returns the identifier of the + new constructor from the id of the two merged constructor and + the merging info. *) +let merge_constructor_id id1 id2 shift:identifier = + let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in + next_ident_fresh (id_of_string id) + + + +(** [merge_constructors lnk shift avoid] merges the two list of + constructor [(name*type)]. These are translated to rawterms + first, each of them having distinct var names. *) +let rec merge_constructors (shift:merge_infos) (avoid:Idset.t) + (typcstr1:(identifier * rawconstr) list) + (typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list = + List.flatten + (List.map + (fun (id1,rawtyp1) -> + List.map + (fun (id2,rawtyp2) -> + let typ = merge_one_constructor shift rawtyp1 rawtyp2 in + let newcstror_id = merge_constructor_id id1 id2 shift in + let _ = prstr "\n**************\n" in + newcstror_id , typ) + typcstr2) + typcstr1) + +(** [merge_inductive_body lnk shift avoid oib1 oib2] merges two + inductive bodies [oib1] and [oib2], linking with [lnk], params + info in [shift], avoiding identifiers in [avoid]. *) +let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) + (oib2:one_inductive_body) = + (* building rawconstr type of constructors *) + let mkrawcor nme avoid typ = + (* first replace rel 1 by a varname *) + let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in + Detyping.detype false (Idset.elements avoid) [] substindtyp in + let lcstr1: rawconstr list = + Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in + (* add to avoid all indentifiers of lcstr1 *) + let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in + let lcstr2 = + Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in + let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in + + let params1 = + try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) + with _ -> [] in + let params2 = + try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) + with _ -> [] in + + let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in + let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in + + cstror_suffix_init(); + params1,params2,merge_constructors shift avoid3 lcstr1 lcstr2 + + +(** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual + inductive bodies [mib1] and [mib2] linking vars with + [lnk]. [shift] information on parameters of the new inductive. + For the moment, inductives are supposed to be non mutual. +*) +let rec merge_mutual_inductive_body + (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) = + (* Mutual not treated, we take first ind body of each. *) + merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0) + + +let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *) + Flags.with_option Flags.raw_print (Constrextern.extern_rawtype Idset.empty) x + +let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = + let params = prms2 @ prms1 in + let resparams = + List.fold_left + (fun acc (nme,tp) -> + let _ = prstr "param :" in + let _ = prNamedRConstr (string_of_name nme) tp in + let _ = prstr " ; " in + let typ = rawterm_to_constr_expr tp in + LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc) + [] params in + let concl = Constrextern.extern_constr false (Global.env()) concl in + let arity,_ = + List.fold_left + (fun (acc,env) (nm,_,c) -> + let typ = Constrextern.extern_constr false env c in + let newenv = Environ.push_rel (nm,None,c) env in + CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv) + (concl,Global.env()) + (shift.funresprms2 @ shift.funresprms1 + @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in + resparams,arity + + + +(** [rawterm_list_to_inductive_expr ident rawlist] returns the + induct_expr corresponding to the the list of constructor types + [rawlist], named ident. + FIXME: params et cstr_expr (arity) *) +let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift + (rawlist:(identifier * rawconstr) list) = + let lident = dummy_loc, shift.ident in + let bindlist , cstr_expr = (* params , arities *) + merge_rec_params_and_arity prms1 prms2 shift mkSet in + let lcstor_expr : (bool * (lident * constr_expr)) list = + List.map (* zeta_normalize t ? *) + (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t)) + rawlist in + lident , bindlist , Some cstr_expr , lcstor_expr + + + +let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = + match rdecl with + | (nme,None,t) -> + let traw = Detyping.detype false [] [] t in + RProd (dummy_loc,nme,Explicit,traw,t2) + | (_,Some _,_) -> assert false + + + + +let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = + match rdecl with + | (nme,None,t) -> + let traw = Detyping.detype false [] [] t in + RProd (dummy_loc,nme,Explicit,traw,t2) + | (_,Some _,_) -> assert false + + +(** [merge_inductive ind1 ind2 lnk] merges two graphs, linking + variables specified in [lnk]. Graphs are not supposed to be mutual + inductives for the moment. *) +let merge_inductive (ind1: inductive) (ind2: inductive) + (lnk1: linked_var array) (lnk2: linked_var array) id = + let env = Global.env() in + let mib1,_ = Inductive.lookup_mind_specif env ind1 in + let mib2,_ = Inductive.lookup_mind_specif env ind2 in + let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *) + (* compute params that become ordinary args (because linked to ord. args) *) + let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in + let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in + let _ = prstr "\nrawlist : " in + let _ = + List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in + let _ = prstr "\nend rawlist\n" in +(* FIX: retransformer en constr ici + let shift_prm = + { shift_prm with + recprms1=prms1; + recprms1=prms1; + } in *) + let indexpr = rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in + (* Declare inductive *) + let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in + let mie,impls = Command.interp_mutual_inductive indl [] true (* means: not coinductive *) in + (* Declare the mutual inductive block with its associated schemes *) + ignore (Command.declare_mutual_inductive_with_eliminations Declare.UserVerbose mie impls) + + +(* Find infos on identifier id. *) +let find_Function_infos_safe (id:identifier): Indfun_common.function_info = + let kn_of_id x = + let f_ref = Libnames.Ident (dummy_loc,x) in + locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref) + locate_constant f_ref in + try find_Function_infos (kn_of_id id) + with Not_found -> + errorlabstrm "indfun" (Nameops.pr_id id ++ str " has no functional scheme") + +(** [merge id1 id2 args1 args2 id] builds and declares a new inductive + type called [id], representing the merged graphs of both graphs + [ind1] and [ind2]. identifiers occuring in both arrays [args1] and + [args2] are considered linked (i.e. are the same variable) in the + new graph. + + Warning: For the moment, repetitions of an id in [args1] or + [args2] are not supported. *) +let merge (id1:identifier) (id2:identifier) (args1:identifier array) + (args2:identifier array) id : unit = + let finfo1 = find_Function_infos_safe id1 in + let finfo2 = find_Function_infos_safe id2 in + (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *) + (* We add one arg (functional arg of the graph) *) + let lnk1 = Array.make (Array.length args1 + 1) Unlinked in + let lnk2' = (* args2 may be linked to args1 members. FIXME: same + as above: vars may be linked inside args2?? *) + Array.mapi + (fun i c -> + match array_find_i (fun i x -> x=c) args1 with + | Some j -> Linked j + | None -> Unlinked) + args2 in + (* We add one arg (functional arg of the graph) *) + let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in + (* setting functional results *) + let _ = lnk1.(Array.length lnk1 - 1) <- Funres in + let _ = lnk2.(Array.length lnk2 - 1) <- Funres in + merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id + + +let remove_last_arg c = + let (x,y) = decompose_prod c in + let xnolast = List.rev (List.tl (List.rev x)) in + compose_prod xnolast y + +let rec remove_n_fst_list n l = if n=0 then l else remove_n_fst_list (n-1) (List.tl l) +let remove_n_last_list n l = List.rev (remove_n_fst_list n (List.rev l)) + +let remove_last_n_arg n c = + let (x,y) = decompose_prod c in + let xnolast = remove_n_last_list n x in + compose_prod xnolast y + +(* [funify_branches relinfo nfuns branch] returns the branch [branch] + of the relinfo [relinfo] modified to fit in a functional principle. + Things to do: + - remove indargs from rel applications + - replace *variables only* corresponding to function (recursive) + results by the actual function application. *) +let funify_branches relinfo nfuns branch = + let mut_induct, induct = + match relinfo.indref with + | None -> assert false + | Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind + | _ -> assert false in + let is_dom c = + match kind_of_term c with + | Ind((u,_)) | Construct((u,_),_) -> u = mut_induct + | _ -> false in + let _dom_i c = + assert (is_dom c); + match kind_of_term c with + | Ind((u,i)) | Construct((u,_),i) -> i + | _ -> assert false in + let _is_pred c shift = + match kind_of_term c with + | Rel i -> let reali = i-shift in (reali>=0 && reali false in + (* FIXME: *) + (Anonymous,Some mkProp,mkProp) + + +let relprinctype_to_funprinctype relprinctype nfuns = + let relinfo = compute_elim_sig relprinctype in + assert (not relinfo.farg_in_concl); + assert (relinfo.indarg_in_concl); + (* first remove indarg and indarg_in_concl *) + let relinfo_noindarg = { relinfo with + indarg_in_concl = false; indarg = None; + concl = remove_last_arg (pop relinfo.concl); } in + (* the nfuns last induction arguments are functional ones: remove them *) + let relinfo_argsok = { relinfo_noindarg with + nargs = relinfo_noindarg.nargs - nfuns; + (* args is in reverse order, so remove fst *) + args = remove_n_fst_list nfuns relinfo_noindarg.args; + concl = popn nfuns relinfo_noindarg.concl + } in + let new_branches = + List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in + let relinfo_branches = { relinfo_argsok with branches = new_branches } in + relinfo_branches + +(* @article{ bundy93rippling, + author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill", + title = "Rippling: A Heuristic for Guiding Inductive Proofs", + journal = "Artificial Intelligence", + volume = "62", + number = "2", + pages = "185-253", + year = "1993", + url = "citeseer.ist.psu.edu/bundy93rippling.html" } + + *) +(* +*** Local Variables: *** +*** compile-command: "make -C ../.. plugins/funind/merge.cmo" *** +*** indent-tabs-mode: nil *** +*** End: *** +*) diff --git a/plugins/funind/rawterm_to_relation.ml b/plugins/funind/rawterm_to_relation.ml new file mode 100644 index 00000000..3c3a36f0 --- /dev/null +++ b/plugins/funind/rawterm_to_relation.ml @@ -0,0 +1,1419 @@ +open Printer +open Pp +open Names +open Term +open Rawterm +open Libnames +open Indfun_common +open Util +open Rawtermops + +let observe strm = + if do_observe () + then Pp.msgnl strm + else () +let observennl strm = + if do_observe () + then Pp.msg strm + else () + + +type binder_type = + | Lambda of name + | Prod of name + | LetIn of name + +type raw_context = (binder_type*rawconstr) list + +(* + compose_raw_context [(bt_1,n_1,t_1);......] rt returns + b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the + binders corresponding to the bt_i's +*) +let compose_raw_context = + let compose_binder (bt,t) acc = + match bt with + | Lambda n -> mkRLambda(n,t,acc) + | Prod n -> mkRProd(n,t,acc) + | LetIn n -> mkRLetIn(n,t,acc) + in + List.fold_right compose_binder + + +(* + The main part deals with building a list of raw constructor expressions + from the rhs of a fixpoint equation. +*) + +type 'a build_entry_pre_return = + { + context : raw_context; (* the binding context of the result *) + value : 'a; (* The value *) + } + +type 'a build_entry_return = + { + result : 'a build_entry_pre_return list; + to_avoid : identifier list + } + +(* + [combine_results combine_fun res1 res2] combine two results [res1] and [res2] + w.r.t. [combine_fun]. + + Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...] + and [res2_1,....] and we need to produce + [combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........] +*) + +let combine_results + (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> + 'c build_entry_pre_return + ) + (res1: 'a build_entry_return) + (res2 : 'b build_entry_return) + : 'c build_entry_return + = + let pre_result = List.map + ( fun res1 -> (* for each result in arg_res *) + List.map (* we add it in each args_res *) + (fun res2 -> + combine_fun res1 res2 + ) + res2.result + ) + res1.result + in (* and then we flatten the map *) + { + result = List.concat pre_result; + to_avoid = list_union res1.to_avoid res2.to_avoid + } + + +(* + The combination function for an argument with a list of argument +*) + +let combine_args arg args = + { + context = arg.context@args.context; + (* Note that the binding context of [arg] MUST be placed before the one of + [args] in order to preserve possible type dependencies + *) + value = arg.value::args.value; + } + + +let ids_of_binder = function + | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> [] + | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id] + +let rec change_vars_in_binder mapping = function + [] -> [] + | (bt,t)::l -> + let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in + (bt,change_vars mapping t):: + (if idmap_is_empty new_mapping + then l + else change_vars_in_binder new_mapping l + ) + +let rec replace_var_by_term_in_binder x_id term = function + | [] -> [] + | (bt,t)::l -> + (bt,replace_var_by_term x_id term t):: + if List.mem x_id (ids_of_binder bt) + then l + else replace_var_by_term_in_binder x_id term l + +let add_bt_names bt = List.append (ids_of_binder bt) + +let apply_args ctxt body args = + let need_convert_id avoid id = + List.exists (is_free_in id) args || List.mem id avoid + in + let need_convert avoid bt = + List.exists (need_convert_id avoid) (ids_of_binder bt) + in + let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = + match na with + | Name id when List.mem id avoid -> + let new_id = Namegen.next_ident_away id avoid in + Name new_id,Idmap.add id new_id mapping,new_id::avoid + | _ -> na,mapping,avoid + in + let next_bt_away bt (avoid:identifier list) = + match bt with + | LetIn na -> + let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + LetIn new_na,mapping,new_avoid + | Prod na -> + let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + Prod new_na,mapping,new_avoid + | Lambda na -> + let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + Lambda new_na,mapping,new_avoid + in + let rec do_apply avoid ctxt body args = + match ctxt,args with + | _,[] -> (* No more args *) + (ctxt,body) + | [],_ -> (* no more fun *) + let f,args' = raw_decompose_app body in + (ctxt,mkRApp(f,args'@args)) + | (Lambda Anonymous,t)::ctxt',arg::args' -> + do_apply avoid ctxt' body args' + | (Lambda (Name id),t)::ctxt',arg::args' -> + let new_avoid,new_ctxt',new_body,new_id = + if need_convert_id avoid id + then + let new_avoid = id::avoid in + let new_id = Namegen.next_ident_away id new_avoid in + let new_avoid' = new_id :: new_avoid in + let mapping = Idmap.add id new_id Idmap.empty in + let new_ctxt' = change_vars_in_binder mapping ctxt' in + let new_body = change_vars mapping body in + new_avoid',new_ctxt',new_body,new_id + else + id::avoid,ctxt',body,id + in + let new_body = replace_var_by_term new_id arg new_body in + let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in + do_apply avoid new_ctxt' new_body args' + | (bt,t)::ctxt',_ -> + let new_avoid,new_ctxt',new_body,new_bt = + let new_avoid = add_bt_names bt avoid in + if need_convert avoid bt + then + let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in + ( + new_avoid, + change_vars_in_binder mapping ctxt', + change_vars mapping body, + new_bt + ) + else new_avoid,ctxt',body,bt + in + let new_ctxt',new_body = + do_apply new_avoid new_ctxt' new_body args + in + (new_bt,t)::new_ctxt',new_body + in + do_apply [] ctxt body args + + +let combine_app f args = + let new_ctxt,new_value = apply_args f.context f.value args.value in + { + (* Note that the binding context of [args] MUST be placed before the one of + the applied value in order to preserve possible type dependencies + *) + context = args.context@new_ctxt; + value = new_value; + } + +let combine_lam n t b = + { + context = []; + value = mkRLambda(n, compose_raw_context t.context t.value, + compose_raw_context b.context b.value ) + } + + + +let combine_prod n t b = + { context = t.context@((Prod n,t.value)::b.context); value = b.value} + +let combine_letin n t b = + { context = t.context@((LetIn n,t.value)::b.context); value = b.value} + + +let mk_result ctxt value avoid = + { + result = + [{context = ctxt; + value = value}] + ; + to_avoid = avoid + } +(************************************************* + Some functions to deal with overlapping patterns +**************************************************) + +let coq_True_ref = + lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True") + +let coq_False_ref = + lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False") + +(* + [make_discr_match_el \[e1,...en\]] builds match e1,...,en with + (the list of expresions on which we will do the matching) + *) +let make_discr_match_el = + List.map (fun e -> (e,(Anonymous,None))) + +(* + [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. + that is. + match ?????? with \\ + | pat_1 => False \\ + | pat_{i-1} => False \\ + | pat_i => True \\ + | pat_{i+1} => False \\ + \vdots + | pat_n => False + end +*) +let make_discr_match_brl i = + list_map_i + (fun j (_,idl,patl,_) -> + if j=i + then (dummy_loc,idl,patl, mkRRef (Lazy.force coq_True_ref)) + else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref)) + ) + 0 +(* + [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff + brl_{i} is the first branch matched by [el] + + Used when we want to simulate the coq pattern matching algorithm +*) +let make_discr_match brl = + fun el i -> + mkRCases(None, + make_discr_match_el el, + make_discr_match_brl i brl) + +let pr_name = function + | Name id -> Ppconstr.pr_id id + | Anonymous -> str "_" + +(**********************************************************************) +(* functions used to build case expression from lettuple and if ones *) +(**********************************************************************) + +(* [build_constructors_of_type] construct the array of pattern of its inductive argument*) +let build_constructors_of_type ind' argl = + let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in + let npar = mib.Declarations.mind_nparams in + Array.mapi (fun i _ -> + let construct = ind',i+1 in + let constructref = ConstructRef(construct) in + let _implicit_positions_of_cst = + Impargs.implicits_of_global constructref + in + let cst_narg = + Inductiveops.mis_constructor_nargs_env + (Global.env ()) + construct + in + let argl = + if argl = [] + then + Array.to_list + (Array.init (cst_narg - npar) (fun _ -> mkRHole ()) + ) + else argl + in + let pat_as_term = + mkRApp(mkRRef (ConstructRef(ind',i+1)),argl) + in + cases_pattern_of_rawconstr Anonymous pat_as_term + ) + ind.Declarations.mind_consnames + +(* [find_type_of] very naive attempts to discover the type of an if or a letin *) +let rec find_type_of nb b = + let f,_ = raw_decompose_app b in + match f with + | RRef(_,ref) -> + begin + let ind_type = + match ref with + | VarRef _ | ConstRef _ -> + let constr_of_ref = constr_of_global ref in + let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in + let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in + let ret_type,_ = decompose_app ret_type in + if not (isInd ret_type) then + begin +(* Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *) + raise (Invalid_argument "not an inductive") + end; + destInd ret_type + | IndRef ind -> ind + | ConstructRef c -> fst c + in + let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in + if not (Array.length ind_type_info.Declarations.mind_consnames = nb ) + then raise (Invalid_argument "find_type_of : not a valid inductive"); + ind_type + end + | RCast(_,b,_) -> find_type_of nb b + | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *) + | _ -> raise (Invalid_argument "not a ref") + + + + +(******************) +(* Main functions *) +(******************) + + + +let raw_push_named (na,raw_value,raw_typ) env = + match na with + | Anonymous -> env + | Name id -> + let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in + let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in + Environ.push_named (id,value,typ) env + + +let add_pat_variables pat typ env : Environ.env = + let rec add_pat_variables env pat typ : Environ.env = + observe (str "new rel env := " ++ Printer.pr_rel_context_of env); + + match pat with + | PatVar(_,na) -> Environ.push_rel (na,None,typ) env + | PatCstr(_,c,patl,na) -> + let Inductiveops.IndType(indf,indargs) = + try Inductiveops.find_rectype env Evd.empty typ + with Not_found -> assert false + in + let constructors = Inductiveops.get_constructors env indf in + let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in + let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) + in + let new_env = add_pat_variables env pat typ in + let res = + fst ( + Sign.fold_rel_context + (fun (na,v,t) (env,ctxt) -> + match na with + | Anonymous -> assert false + | Name id -> + let new_t = substl ctxt t in + let new_v = Option.map (substl ctxt) v in + observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ + str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ + str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ + Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ + Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) + ); + (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt) + ) + (Environ.rel_context new_env) + ~init:(env,[]) + ) + in + observe (str "new var env := " ++ Printer.pr_named_context_of res); + res + + + + +let rec pattern_to_term_and_type env typ = function + | PatVar(loc,Anonymous) -> assert false + | PatVar(loc,Name id) -> + mkRVar id + | PatCstr(loc,constr,patternl,_) -> + let cst_narg = + Inductiveops.mis_constructor_nargs_env + (Global.env ()) + constr + in + let Inductiveops.IndType(indf,indargs) = + try Inductiveops.find_rectype env Evd.empty typ + with Not_found -> assert false + in + let constructors = Inductiveops.get_constructors env indf in + let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in + let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + let _,cstl = Inductiveops.dest_ind_family indf in + let csta = Array.of_list cstl in + let implicit_args = + Array.to_list + (Array.init + (cst_narg - List.length patternl) + (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i)) + ) + in + let patl_as_term = + List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl + in + mkRApp(mkRRef(ConstructRef constr), + implicit_args@patl_as_term + ) + +(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) + of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the + corresponding graphs. + + + The idea to transform a term [t] into a list of constructors [lc] is the following: + \begin{itemize} + \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding + to [body] and add (bind x. _) to each elements of [lc] + \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) + then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], + then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], + [g c1 ... cn] is an element of [lc] + \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then + compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], + then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn] + create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc] + \item if the term is a cast just treat its body part + \item + if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case + and concatenate them (informally, each branch of a match produces a new constructor) + \end{itemize} + + WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed. + We must wait to have complete all the current calculi to set the recursive calls. + At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by + a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. + We in fact not create a constructor list since then end of each constructor has not the expected form + but only the value of the function +*) + + +let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = + observe (str " Entering : " ++ Printer.pr_rawconstr rt); + match rt with + | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> + (* do nothing (except changing type of course) *) + mk_result [] rt avoid + | RApp(_,_,_) -> + let f,args = raw_decompose_app rt in + let args_res : (rawconstr list) build_entry_return = + List.fold_right (* create the arguments lists of constructors and combine them *) + (fun arg ctxt_argsl -> + let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in + combine_results combine_args arg_res ctxt_argsl + ) + args + (mk_result [] [] avoid) + in + begin + match f with + | RLambda _ -> + let rec aux t l = + match l with + | [] -> t + | u::l -> + match t with + | RLambda(loc,na,_,nat,b) -> + RLetIn(dummy_loc,na,u,aux b l) + | _ -> + RApp(dummy_loc,t,l) + in + build_entry_lc env funnames avoid (aux f args) + | RVar(_,id) when Idset.mem id funnames -> + (* if we have [f t1 ... tn] with [f]$\in$[fnames] + then we create a fresh variable [res], + add [res] and its "value" (i.e. [res v1 ... vn]) to each + pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and + a pseudo value "v1 ... vn". + The "value" of this branch is then simply [res] + *) + let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in + let rt_typ = Typing.type_of env Evd.empty rt_as_constr in + let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in + let res = fresh_id args_res.to_avoid "res" in + let new_avoid = res::args_res.to_avoid in + let res_rt = mkRVar res in + let new_result = + List.map + (fun arg_res -> + let new_hyps = + [Prod (Name res),res_raw_type; + Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)] + in + {context = arg_res.context@new_hyps; value = res_rt } + ) + args_res.result + in + { result = new_result; to_avoid = new_avoid } + | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ -> + (* if have [g t1 ... tn] with [g] not appearing in [funnames] + then + foreach [ctxt,v1 ... vn] in [args_res] we return + [ctxt, g v1 .... vn] + *) + { + args_res with + result = + List.map + (fun args_res -> + {args_res with value = mkRApp(f,args_res.value)}) + args_res.result + } + | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *) + | RLetIn(_,n,t,b) -> + (* if we have [(let x := v in b) t1 ... tn] , + we discard our work and compute the list of constructor for + [let x = v in (b t1 ... tn)] up to alpha conversion + *) + let new_n,new_b,new_avoid = + match n with + | Name id when List.exists (is_free_in id) args -> + (* need to alpha-convert the name *) + let new_id = Namegen.next_ident_away id avoid in + let new_avoid = id:: avoid in + let new_b = + replace_var_by_term + id + (RVar(dummy_loc,id)) + b + in + (Name new_id,new_b,new_avoid) + | _ -> n,b,avoid + in + build_entry_lc + env + funnames + avoid + (mkRLetIn(new_n,t,mkRApp(new_b,args))) + | RCases _ | RIf _ | RLetTuple _ -> + (* we have [(match e1, ...., en with ..... end) t1 tn] + we first compute the result from the case and + then combine each of them with each of args one + *) + let f_res = build_entry_lc env funnames args_res.to_avoid f in + combine_results combine_app f_res args_res + | RDynamic _ ->error "Not handled RDynamic" + | RCast(_,b,_) -> + (* for an applied cast we just trash the cast part + and restart the work. + + WARNING: We need to restart since [b] itself should be an application term + *) + build_entry_lc env funnames avoid (mkRApp(b,args)) + | RRec _ -> error "Not handled RRec" + | RProd _ -> error "Cannot apply a type" + end (* end of the application treatement *) + + | RLambda(_,n,_,t,b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) + let t_res = build_entry_lc env funnames avoid t in + let new_n = + match n with + | Name _ -> n + | Anonymous -> Name (Indfun_common.fresh_id [] "_x") + in + let new_env = raw_push_named (new_n,None,t) env in + let b_res = build_entry_lc new_env funnames avoid b in + combine_results (combine_lam new_n) t_res b_res + | RProd(_,n,_,t,b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) + let t_res = build_entry_lc env funnames avoid t in + let new_env = raw_push_named (n,None,t) env in + let b_res = build_entry_lc new_env funnames avoid b in + combine_results (combine_prod n) t_res b_res + | RLetIn(_,n,v,b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the value [t] + and combine the two result + *) + let v_res = build_entry_lc env funnames avoid v in + let v_as_constr = Pretyping.Default.understand Evd.empty env v in + let v_type = Typing.type_of env Evd.empty v_as_constr in + let new_env = + match n with + Anonymous -> env + | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env + in + let b_res = build_entry_lc new_env funnames avoid b in + combine_results (combine_letin n) v_res b_res + | RCases(_,_,_,el,brl) -> + (* we create the discrimination function + and treat the case itself + *) + let make_discr = make_discr_match brl in + build_entry_lc_from_case env funnames make_discr el brl avoid + | RIf(_,b,(na,e_option),lhs,rhs) -> + let b_as_constr = Pretyping.Default.understand Evd.empty env b in + let b_typ = Typing.type_of env Evd.empty b_as_constr in + let (ind,_) = + try Inductiveops.find_inductive env Evd.empty b_typ + with Not_found -> + errorlabstrm "" (str "Cannot find the inductive associated to " ++ + Printer.pr_rawconstr b ++ str " in " ++ + Printer.pr_rawconstr rt ++ str ". try again with a cast") + in + let case_pats = build_constructors_of_type ind [] in + assert (Array.length case_pats = 2); + let brl = + list_map_i + (fun i x -> (dummy_loc,[],[case_pats.(i)],x)) + 0 + [lhs;rhs] + in + let match_expr = + mkRCases(None,[(b,(Anonymous,None))],brl) + in + (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *) + build_entry_lc env funnames avoid match_expr + | RLetTuple(_,nal,_,b,e) -> + begin + let nal_as_rawconstr = + List.map + (function + Name id -> mkRVar id + | Anonymous -> mkRHole () + ) + nal + in + let b_as_constr = Pretyping.Default.understand Evd.empty env b in + let b_typ = Typing.type_of env Evd.empty b_as_constr in + let (ind,_) = + try Inductiveops.find_inductive env Evd.empty b_typ + with Not_found -> + errorlabstrm "" (str "Cannot find the inductive associated to " ++ + Printer.pr_rawconstr b ++ str " in " ++ + Printer.pr_rawconstr rt ++ str ". try again with a cast") + in + let case_pats = build_constructors_of_type ind nal_as_rawconstr in + assert (Array.length case_pats = 1); + let br = + (dummy_loc,[],[case_pats.(0)],e) + in + let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in + build_entry_lc env funnames avoid match_expr + + end + | RRec _ -> error "Not handled RRec" + | RCast(_,b,_) -> + build_entry_lc env funnames avoid b + | RDynamic _ -> error "Not handled RDynamic" +and build_entry_lc_from_case env funname make_discr + (el:tomatch_tuples) + (brl:Rawterm.cases_clauses) avoid : + rawconstr build_entry_return = + match el with + | [] -> assert false (* this case correspond to match with .... !*) + | el -> + (* this case correspond to + match el with brl end + we first compute the list of lists corresponding to [el] and + combine them . + Then for each elemeent of the combinations, + we compute the result we compute one list per branch in [brl] and + finally we just concatenate those list + *) + let case_resl = + List.fold_right + (fun (case_arg,_) ctxt_argsl -> + let arg_res = build_entry_lc env funname avoid case_arg in + combine_results combine_args arg_res ctxt_argsl + ) + el + (mk_result [] [] avoid) + in + let types = + List.map (fun (case_arg,_) -> + let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in + Typing.type_of env Evd.empty case_arg_as_constr + ) el + in + (****** The next works only if the match is not dependent ****) + let results = + List.map + (fun ca -> + let res = build_entry_lc_from_case_term + env types + funname (make_discr) + [] brl + case_resl.to_avoid + ca + in + res + ) + case_resl.result + in + { + result = List.concat (List.map (fun r -> r.result) results); + to_avoid = + List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results + } + +and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid + matched_expr = + match brl with + | [] -> (* computed_branches *) {result = [];to_avoid = avoid} + | br::brl' -> + (* alpha convertion to prevent name clashes *) + let _,idl,patl,return = alpha_br avoid br in + let new_avoid = idl@avoid in (* for now we can no more use idl as an indentifier *) + (* building a list of precondition stating that we are not in this branch + (will be used in the following recursive calls) + *) + let new_env = List.fold_right2 add_pat_variables patl types env in + let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = + List.map2 + (fun pat typ -> + fun avoid pat'_as_term -> + let renamed_pat,_,_ = alpha_pat avoid pat in + let pat_ids = get_pattern_id renamed_pat in + let env_with_pat_ids = add_pat_variables pat typ new_env in + List.fold_right + (fun id acc -> + let typ_of_id = + Typing.type_of env_with_pat_ids Evd.empty (mkVar id) + in + let raw_typ_of_id = + Detyping.detype false [] + (Termops.names_of_rel_context env_with_pat_ids) typ_of_id + in + mkRProd (Name id,raw_typ_of_id,acc)) + pat_ids + (raw_make_neq pat'_as_term (pattern_to_term renamed_pat)) + ) + patl + types + in + (* Checking if we can be in this branch + (will be used in the following recursive calls) + *) + let unify_with_those_patterns : (cases_pattern -> bool*bool) list = + List.map + (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') + patl + in + (* + we first compute the other branch result (in ordrer to keep the order of the matching + as much as possible) + *) + let brl'_res = + build_entry_lc_from_case_term + env + types + funname + make_discr + ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) + brl' + avoid + matched_expr + in + (* We now create the precondition of this branch i.e. + 1- the list of variable appearing in the different patterns of this branch and + the list of equation stating than el = patl (List.flatten ...) + 2- If there exists a previous branch which pattern unify with the one of this branch + then a discrimination precond stating that we are not in a previous branch (if List.exists ...) + *) + let those_pattern_preconds = + (List.flatten + ( + list_map3 + (fun pat e typ_as_constr -> + let this_pat_ids = ids_of_pat pat in + let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in + let pat_as_term = pattern_to_term pat in + List.fold_right + (fun id acc -> + if Idset.mem id this_pat_ids + then (Prod (Name id), + let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in + let raw_typ_of_id = + Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id + in + raw_typ_of_id + )::acc + else acc + ) + idl + [(Prod Anonymous,raw_make_eq ~typ pat_as_term e)] + ) + patl + matched_expr.value + types + ) + ) + @ + (if List.exists (function (unifl,_) -> + let (unif,_) = + List.split (List.map2 (fun x y -> x y) unifl patl) + in + List.for_all (fun x -> x) unif) patterns_to_prevent + then + let i = List.length patterns_to_prevent in + let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in + [(Prod Anonymous,make_discr pats_as_constr i )] + else + [] + ) + in + (* We compute the result of the value returned by the branch*) + let return_res = build_entry_lc new_env funname new_avoid return in + (* and combine it with the preconds computed for this branch *) + let this_branch_res = + List.map + (fun res -> + { context = matched_expr.context@those_pattern_preconds@res.context ; + value = res.value} + ) + return_res.result + in + { brl'_res with result = this_branch_res@brl'_res.result } + + +let is_res id = + try + String.sub (string_of_id id) 0 3 = "res" + with Invalid_argument _ -> false + + +exception Continue +(* + The second phase which reconstruct the real type of the constructor. + rebuild the raw constructors expression. + eliminates some meaningless equalities, applies some rewrites...... +*) +let rec rebuild_cons env nb_args relname args crossed_types depth rt = + observe (str "rebuilding : " ++ pr_rawconstr rt); + + match rt with + | RProd(_,n,k,t,b) -> + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t::crossed_types in + begin + match t with + | RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id -> + begin + match args' with + | (RVar(_,this_relname))::args' -> + (*i The next call to mk_rel_id is + valid since we are constructing the graph + Ensures by: obvious + i*) + + let new_t = + mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt]) + in + let t' = Pretyping.Default.understand Evd.empty env new_t in + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = + rebuild_cons new_env + nb_args relname + args new_crossed_types + (depth + 1) b + in + mkRProd(n,new_t,new_b), + Idset.filter not_free_in_t id_to_exclude + | _ -> (* the first args is the name of the function! *) + assert false + end + | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt]) + when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous + -> + begin + try + observe (str "computing new type for eq : " ++ pr_rawconstr rt); + let t' = + try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue + in + let is_in_b = is_free_in id b in + let _keep_eq = + not (List.exists (is_free_in id) args) || is_in_b || + List.exists (is_free_in id) crossed_types + in + let new_args = List.map (replace_var_by_term id rt) args in + let subst_b = + if is_in_b then b else replace_var_by_term id rt b + in + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = + rebuild_cons + new_env + nb_args relname + new_args new_crossed_types + (depth + 1) subst_b + in + mkRProd(n,t,new_b),id_to_exclude + with Continue -> + let jmeq = Libnames.IndRef (destInd (jmeq ())) in + let ty' = Pretyping.Default.understand Evd.empty env ty in + let ind,args' = Inductive.find_inductive env ty' in + let mib,_ = Global.lookup_inductive ind in + let nparam = mib.Declarations.mind_nparams in + let params,arg' = + ((Util.list_chop nparam args')) + in + let rt_typ = + RApp(Util.dummy_loc, + RRef (Util.dummy_loc,Libnames.IndRef ind), + (List.map + (fun p -> Detyping.detype false [] + (Termops.names_of_rel_context env) + p) params)@(Array.to_list + (Array.make + (List.length args' - nparam) + (mkRHole ())))) + in + let eq' = + RApp(loc1,RRef(loc2,jmeq),[ty;RVar(loc3,id);rt_typ;rt]) + in + observe (str "computing new type for jmeq : " ++ pr_rawconstr eq'); + let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in + observe (str " computing new type for jmeq : done") ; + let new_args = + match kind_of_term eq'_as_constr with + | App(_,[|_;_;ty;_|]) -> + let ty = Array.to_list (snd (destApp ty)) in + let ty' = snd (Util.list_chop nparam ty) in + List.fold_left2 + (fun acc var_as_constr arg -> + if isRel var_as_constr + then + let (na,_,_) = + Environ.lookup_rel (destRel var_as_constr) env + in + match na with + | Anonymous -> acc + | Name id' -> + (id',Detyping.detype false [] + (Termops.names_of_rel_context env) + arg)::acc + else if isVar var_as_constr + then (destVar var_as_constr,Detyping.detype false [] + (Termops.names_of_rel_context env) + arg)::acc + else acc + ) + [] + arg' + ty' + | _ -> assert false + in + let is_in_b = is_free_in id b in + let _keep_eq = + not (List.exists (is_free_in id) args) || is_in_b || + List.exists (is_free_in id) crossed_types + in + let new_args = + List.fold_left + (fun args (id,rt) -> + List.map (replace_var_by_term id rt) args + ) + args + ((id,rt)::new_args) + in + let subst_b = + if is_in_b then b else replace_var_by_term id rt b + in + let new_env = + let t' = Pretyping.Default.understand Evd.empty env eq' in + Environ.push_rel (n,None,t') env + in + let new_b,id_to_exclude = + rebuild_cons + new_env + nb_args relname + new_args new_crossed_types + (depth + 1) subst_b + in + mkRProd(n,eq',new_b),id_to_exclude + end + (* J.F:. keep this comment it explain how to remove some meaningless equalities + if keep_eq then + mkRProd(n,t,new_b),id_to_exclude + else new_b, Idset.add id id_to_exclude + *) + | _ -> + observe (str "computing new type for prod : " ++ pr_rawconstr rt); + let t' = Pretyping.Default.understand Evd.empty env t in + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = + rebuild_cons new_env + nb_args relname + args new_crossed_types + (depth + 1) b + in + match n with + | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> + new_b,Idset.remove id + (Idset.filter not_free_in_t id_to_exclude) + | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude + end + | RLambda(_,n,k,t,b) -> + begin + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t :: crossed_types in + observe (str "computing new type for lambda : " ++ pr_rawconstr rt); + let t' = Pretyping.Default.understand Evd.empty env t in + match n with + | Name id -> + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = + rebuild_cons new_env + nb_args relname + (args@[mkRVar id])new_crossed_types + (depth + 1 ) b + in + if Idset.mem id id_to_exclude && depth >= nb_args + then + new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude) + else + RProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude + | _ -> anomaly "Should not have an anonymous function here" + (* We have renamed all the anonymous functions during alpha_renaming phase *) + + end + | RLetIn(_,n,t,b) -> + begin + let not_free_in_t id = not (is_free_in id t) in + let t' = Pretyping.Default.understand Evd.empty env t in + let type_t' = Typing.type_of env Evd.empty t' in + let new_env = Environ.push_rel (n,Some t',type_t') env in + let new_b,id_to_exclude = + rebuild_cons new_env + nb_args relname + args (t::crossed_types) + (depth + 1 ) b in + match n with + | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> + new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) + | _ -> RLetIn(dummy_loc,n,t,new_b), + Idset.filter not_free_in_t id_to_exclude + end + | RLetTuple(_,nal,(na,rto),t,b) -> + assert (rto=None); + begin + let not_free_in_t id = not (is_free_in id t) in + let new_t,id_to_exclude' = + rebuild_cons env + nb_args + relname + args (crossed_types) + depth t + in + let t' = Pretyping.Default.understand Evd.empty env new_t in + let new_env = Environ.push_rel (na,None,t') env in + let new_b,id_to_exclude = + rebuild_cons new_env + nb_args relname + args (t::crossed_types) + (depth + 1) b + in +(* match n with *) +(* | Name id when Idset.mem id id_to_exclude -> *) +(* new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *) +(* | _ -> *) + RLetTuple(dummy_loc,nal,(na,None),t,new_b), + Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude') + + end + + | _ -> mkRApp(mkRVar relname,args@[rt]),Idset.empty + + +(* debuging wrapper *) +let rebuild_cons env nb_args relname args crossed_types rt = +(* observennl (str "rebuild_cons : rt := "++ pr_rawconstr rt ++ *) +(* str "nb_args := " ++ str (string_of_int nb_args)); *) + let res = + rebuild_cons env nb_args relname args crossed_types 0 rt + in +(* observe (str " leads to "++ pr_rawconstr (fst res)); *) + res + + +(* naive implementation of parameter detection. + + A parameter is an argument which is only preceded by parameters and whose + calls are all syntaxically equal. + + TODO: Find a valid way to deal with implicit arguments here! +*) +let rec compute_cst_params relnames params = function + | RRef _ | RVar _ | REvar _ | RPatVar _ -> params + | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames -> + compute_cst_params_from_app [] (params,rtl) + | RApp(_,f,args) -> + List.fold_left (compute_cst_params relnames) params (f::args) + | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) -> + let t_params = compute_cst_params relnames params t in + compute_cst_params relnames t_params b + | RCases _ -> + params (* If there is still cases at this point they can only be + discriminitation ones *) + | RSort _ -> params + | RHole _ -> params + | RIf _ | RRec _ | RCast _ | RDynamic _ -> + raise (UserError("compute_cst_params", str "Not handled case")) +and compute_cst_params_from_app acc (params,rtl) = + match params,rtl with + | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) + | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl' + when id_ord id id' == 0 && not is_defined -> + compute_cst_params_from_app (param::acc) (params',rtl') + | _ -> List.rev acc + +let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts = + let rels_params = + Array.mapi + (fun i args -> + List.fold_left + (fun params (_,cst) -> compute_cst_params relnames params cst) + args + csts.(i) + ) + args + in + let l = ref [] in + let _ = + try + list_iter_i + (fun i ((n,nt,is_defined) as param) -> + if array_for_all + (fun l -> + let (n',nt',is_defined') = List.nth l i in + n = n' && Topconstr.eq_rawconstr nt nt' && is_defined = is_defined') + rels_params + then + l := param::!l + ) + rels_params.(0) + with _ -> + () + in + List.rev !l + +let rec rebuild_return_type rt = + match rt with + | Topconstr.CProdN(loc,n,t') -> + Topconstr.CProdN(loc,n,rebuild_return_type t') + | Topconstr.CArrow(loc,t,t') -> + Topconstr.CArrow(loc,t,rebuild_return_type t') + | Topconstr.CLetIn(loc,na,t,t') -> + Topconstr.CLetIn(loc,na,t,rebuild_return_type t') + | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None)) + + +let do_build_inductive + funnames (funsargs: (Names.name * rawconstr * bool) list list) + returned_types + (rtl:rawconstr list) = + let _time1 = System.get_time () in +(* Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *) + let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in + let funnames = Array.of_list funnames in + let funsargs = Array.of_list funsargs in + let returned_types = Array.of_list returned_types in + (* alpha_renaming of the body to prevent variable capture during manipulation *) + let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in + let rta = Array.of_list rtl_alpha in + (*i The next call to mk_rel_id is valid since we are constructing the graph + Ensures by: obvious + i*) + let relnames = Array.map mk_rel_id funnames in + let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in + (* Construction of the pseudo constructors *) + let env = + Array.fold_right + (fun id env -> + Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id)) env + ) + funnames + (Global.env ()) + in + let resa = Array.map (build_entry_lc env funnames_as_set []) rta in + let env_with_graphs = + let rel_arity i funargs = (* Reduilding arities (with parameters) *) + let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = + funargs + in + List.fold_right + (fun (n,t,is_defined) acc -> + if is_defined + then + Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t, + acc) + else + Topconstr.CProdN + (dummy_loc, + [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t], + acc + ) + ) + rel_first_args + (rebuild_return_type returned_types.(i)) + in + (* We need to lift back our work topconstr but only with all information + We mimick a Set Printing All. + Then save the graphs and reset Printing options to their primitive values + *) + let rel_arities = Array.mapi rel_arity funsargs in + Util.array_fold_left2 (fun env rel_name rel_ar -> + Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities + in + (* and of the real constructors*) + let constr i res = + List.map + (function result (* (args',concl') *) -> + let rt = compose_raw_context result.context result.value in + let nb_args = List.length funsargs.(i) in + (* with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *) + fst ( + rebuild_cons env_with_graphs nb_args relnames.(i) + [] + [] + rt + ) + ) + res.result + in + (* adding names to constructors *) + let next_constructor_id = ref (-1) in + let mk_constructor_id i = + incr next_constructor_id; + (*i The next call to mk_rel_id is valid since we are constructing the graph + Ensures by: obvious + i*) + id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) + in + let rel_constructors i rt : (identifier*rawconstr) list = + next_constructor_id := (-1); + List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) + in + let rel_constructors = Array.mapi rel_constructors resa in + (* Computing the set of parameters if asked *) + let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in + let nrel_params = List.length rels_params in + let rel_constructors = (* Taking into account the parameters in constructors *) + Array.map (List.map + (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) + rel_constructors + in + let rel_arity i funargs = (* Reduilding arities (with parameters) *) + let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = + (snd (list_chop nrel_params funargs)) + in + List.fold_right + (fun (n,t,is_defined) acc -> + if is_defined + then + Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t, + acc) + else + Topconstr.CProdN + (dummy_loc, + [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t], + acc + ) + ) + rel_first_args + (rebuild_return_type returned_types.(i)) + in + (* We need to lift back our work topconstr but only with all information + We mimick a Set Printing All. + Then save the graphs and reset Printing options to their primitive values + *) + let rel_arities = Array.mapi rel_arity funsargs in + let rel_params = + List.map + (fun (n,t,is_defined) -> + if is_defined + then + Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t) + else + Topconstr.LocalRawAssum + ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t) + ) + rels_params + in + let ext_rels_constructors = + Array.map (List.map + (fun (id,t) -> + false,((dummy_loc,id), + Flags.with_option + Flags.raw_print + (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t) + ) + )) + (rel_constructors) + in + let rel_ind i ext_rel_constructors = + ((dummy_loc,relnames.(i)), + rel_params, + Some rel_arities.(i), + ext_rel_constructors),[] + in + let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in + let rel_inds = Array.to_list ext_rel_constructors in +(* let _ = *) +(* Pp.msgnl (\* observe *\) ( *) +(* str "Inductive" ++ spc () ++ *) +(* prlist_with_sep *) +(* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) +(* (function ((_,id),_,params,ar,constr) -> *) +(* Ppconstr.pr_id id ++ spc () ++ *) +(* Ppconstr.pr_binders params ++ spc () ++ *) +(* str ":" ++ spc () ++ *) +(* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) +(* prlist_with_sep *) +(* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) +(* (function (_,((_,id),t)) -> *) +(* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) +(* Ppconstr.pr_lconstr_expr t) *) +(* constr *) +(* ) *) +(* rel_inds *) +(* ) *) +(* in *) + let _time2 = System.get_time () in + try + with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds)) true + with + | UserError(s,msg) as e -> + let _time3 = System.get_time () in +(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + rel_inds + in + let msg = + str "while trying to define"++ spc () ++ + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) + ++ fnl () ++ + msg + in + observe (msg); + raise e + | e -> + let _time3 = System.get_time () in +(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + rel_inds + in + let msg = + str "while trying to define"++ spc () ++ + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) + ++ fnl () ++ + Cerrors.explain_exn e + in + observe msg; + raise e + + + +let build_inductive funnames funsargs returned_types rtl = + try + do_build_inductive funnames funsargs returned_types rtl + with e -> raise (Building_graph e) + + diff --git a/plugins/funind/rawterm_to_relation.mli b/plugins/funind/rawterm_to_relation.mli new file mode 100644 index 00000000..a314050f --- /dev/null +++ b/plugins/funind/rawterm_to_relation.mli @@ -0,0 +1,16 @@ + + + +(* + [build_inductive parametrize funnames funargs returned_types bodies] + constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments + and returning [returned_types] using bodies [bodies] +*) + +val build_inductive : + Names.identifier list -> (* The list of function name *) + (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *) + Topconstr.constr_expr list -> (* The list of function returned type *) + Rawterm.rawconstr list -> (* the list of body *) + unit + diff --git a/plugins/funind/rawtermops.ml b/plugins/funind/rawtermops.ml new file mode 100644 index 00000000..e31f1452 --- /dev/null +++ b/plugins/funind/rawtermops.ml @@ -0,0 +1,718 @@ +open Pp +open Rawterm +open Util +open Names +(* Ocaml 3.06 Map.S does not handle is_empty *) +let idmap_is_empty m = m = Idmap.empty + +(* + Some basic functions to rebuild rawconstr + In each of them the location is Util.dummy_loc +*) +let mkRRef ref = RRef(dummy_loc,ref) +let mkRVar id = RVar(dummy_loc,id) +let mkRApp(rt,rtl) = RApp(dummy_loc,rt,rtl) +let mkRLambda(n,t,b) = RLambda(dummy_loc,n,Explicit,t,b) +let mkRProd(n,t,b) = RProd(dummy_loc,n,Explicit,t,b) +let mkRLetIn(n,t,b) = RLetIn(dummy_loc,n,t,b) +let mkRCases(rto,l,brl) = RCases(dummy_loc,Term.RegularStyle,rto,l,brl) +let mkRSort s = RSort(dummy_loc,s) +let mkRHole () = RHole(dummy_loc,Evd.BinderType Anonymous) +let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t)) + +(* + Some basic functions to decompose rawconstrs + These are analogous to the ones constrs +*) +let raw_decompose_prod = + let rec raw_decompose_prod args = function + | RProd(_,n,k,t,b) -> + raw_decompose_prod ((n,t)::args) b + | rt -> args,rt + in + raw_decompose_prod [] + +let raw_decompose_prod_or_letin = + let rec raw_decompose_prod args = function + | RProd(_,n,k,t,b) -> + raw_decompose_prod ((n,None,Some t)::args) b + | RLetIn(_,n,t,b) -> + raw_decompose_prod ((n,Some t,None)::args) b + | rt -> args,rt + in + raw_decompose_prod [] + +let raw_compose_prod = + List.fold_left (fun b (n,t) -> mkRProd(n,t,b)) + +let raw_compose_prod_or_letin = + List.fold_left ( + fun concl decl -> + match decl with + | (n,None,Some t) -> mkRProd(n,t,concl) + | (n,Some bdy,None) -> mkRLetIn(n,bdy,concl) + | _ -> assert false) + +let raw_decompose_prod_n n = + let rec raw_decompose_prod i args c = + if i<=0 then args,c + else + match c with + | RProd(_,n,_,t,b) -> + raw_decompose_prod (i-1) ((n,t)::args) b + | rt -> args,rt + in + raw_decompose_prod n [] + + +let raw_decompose_prod_or_letin_n n = + let rec raw_decompose_prod i args c = + if i<=0 then args,c + else + match c with + | RProd(_,n,_,t,b) -> + raw_decompose_prod (i-1) ((n,None,Some t)::args) b + | RLetIn(_,n,t,b) -> + raw_decompose_prod (i-1) ((n,Some t,None)::args) b + | rt -> args,rt + in + raw_decompose_prod n [] + + +let raw_decompose_app = + let rec decompose_rapp acc rt = +(* msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *) + match rt with + | RApp(_,rt,rtl) -> + decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt + | rt -> rt,List.rev acc + in + decompose_rapp [] + + + + +(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) +let raw_make_eq ?(typ= mkRHole ()) t1 t2 = + mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) + +(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) +let raw_make_neq t1 t2 = + mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2]) + +(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) +let raw_make_or t1 t2 = mkRApp (mkRRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) + +(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding + to [P1 \/ ( .... \/ Pn)] +*) +let rec raw_make_or_list = function + | [] -> raise (Invalid_argument "mk_or") + | [e] -> e + | e::l -> raw_make_or e (raw_make_or_list l) + + +let remove_name_from_mapping mapping na = + match na with + | Anonymous -> mapping + | Name id -> Idmap.remove id mapping + +let change_vars = + let rec change_vars mapping rt = + match rt with + | RRef _ -> rt + | RVar(loc,id) -> + let new_id = + try + Idmap.find id mapping + with Not_found -> id + in + RVar(loc,new_id) + | REvar _ -> rt + | RPatVar _ -> rt + | RApp(loc,rt',rtl) -> + RApp(loc, + change_vars mapping rt', + List.map (change_vars mapping) rtl + ) + | RLambda(loc,name,k,t,b) -> + RLambda(loc, + name, + k, + change_vars mapping t, + change_vars (remove_name_from_mapping mapping name) b + ) + | RProd(loc,name,k,t,b) -> + RProd(loc, + name, + k, + change_vars mapping t, + change_vars (remove_name_from_mapping mapping name) b + ) + | RLetIn(loc,name,def,b) -> + RLetIn(loc, + name, + change_vars mapping def, + change_vars (remove_name_from_mapping mapping name) b + ) + | RLetTuple(loc,nal,(na,rto),b,e) -> + let new_mapping = List.fold_left remove_name_from_mapping mapping nal in + RLetTuple(loc, + nal, + (na, Option.map (change_vars mapping) rto), + change_vars mapping b, + change_vars new_mapping e + ) + | RCases(loc,sty,infos,el,brl) -> + RCases(loc,sty, + infos, + List.map (fun (e,x) -> (change_vars mapping e,x)) el, + List.map (change_vars_br mapping) brl + ) + | RIf(loc,b,(na,e_option),lhs,rhs) -> + RIf(loc, + change_vars mapping b, + (na,Option.map (change_vars mapping) e_option), + change_vars mapping lhs, + change_vars mapping rhs + ) + | RRec _ -> error "Local (co)fixes are not supported" + | RSort _ -> rt + | RHole _ -> rt + | RCast(loc,b,CastConv (k,t)) -> + RCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t)) + | RCast(loc,b,CastCoerce) -> + RCast(loc,change_vars mapping b,CastCoerce) + | RDynamic _ -> error "Not handled RDynamic" + and change_vars_br mapping ((loc,idl,patl,res) as br) = + let new_mapping = List.fold_right Idmap.remove idl mapping in + if idmap_is_empty new_mapping + then br + else (loc,idl,patl,change_vars new_mapping res) + in + change_vars + + + +let rec alpha_pat excluded pat = + match pat with + | PatVar(loc,Anonymous) -> + let new_id = Indfun_common.fresh_id excluded "_x" in + PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty + | PatVar(loc,Name id) -> + if List.mem id excluded + then + let new_id = Namegen.next_ident_away id excluded in + PatVar(loc,Name new_id),(new_id::excluded), + (Idmap.add id new_id Idmap.empty) + else pat,excluded,Idmap.empty + | PatCstr(loc,constr,patl,na) -> + let new_na,new_excluded,map = + match na with + | Name id when List.mem id excluded -> + let new_id = Namegen.next_ident_away id excluded in + Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty + | _ -> na,excluded,Idmap.empty + in + let new_patl,new_excluded,new_map = + List.fold_left + (fun (patl,excluded,map) pat -> + let new_pat,new_excluded,new_map = alpha_pat excluded pat in + (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map) + ) + ([],new_excluded,map) + patl + in + PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map + +let alpha_patl excluded patl = + let patl,new_excluded,map = + List.fold_left + (fun (patl,excluded,map) pat -> + let new_pat,new_excluded,new_map = alpha_pat excluded pat in + new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map) + ) + ([],excluded,Idmap.empty) + patl + in + (List.rev patl,new_excluded,map) + + + + +let raw_get_pattern_id pat acc = + let rec get_pattern_id pat = + match pat with + | PatVar(loc,Anonymous) -> assert false + | PatVar(loc,Name id) -> + [id] + | PatCstr(loc,constr,patternl,_) -> + List.fold_right + (fun pat idl -> + let idl' = get_pattern_id pat in + idl'@idl + ) + patternl + [] + in + (get_pattern_id pat)@acc + +let get_pattern_id pat = raw_get_pattern_id pat [] + +let rec alpha_rt excluded rt = + let new_rt = + match rt with + | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt + | RLambda(loc,Anonymous,k,t,b) -> + let new_id = Namegen.next_ident_away (id_of_string "_x") excluded in + let new_excluded = new_id :: excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + RLambda(loc,Name new_id,k,new_t,new_b) + | RProd(loc,Anonymous,k,t,b) -> + let new_t = alpha_rt excluded t in + let new_b = alpha_rt excluded b in + RProd(loc,Anonymous,k,new_t,new_b) + | RLetIn(loc,Anonymous,t,b) -> + let new_t = alpha_rt excluded t in + let new_b = alpha_rt excluded b in + RLetIn(loc,Anonymous,new_t,new_b) + | RLambda(loc,Name id,k,t,b) -> + let new_id = Namegen.next_ident_away id excluded in + let t,b = + if new_id = id + then t,b + else + let replace = change_vars (Idmap.add id new_id Idmap.empty) in + (t,replace b) + in + let new_excluded = new_id::excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + RLambda(loc,Name new_id,k,new_t,new_b) + | RProd(loc,Name id,k,t,b) -> + let new_id = Namegen.next_ident_away id excluded in + let new_excluded = new_id::excluded in + let t,b = + if new_id = id + then t,b + else + let replace = change_vars (Idmap.add id new_id Idmap.empty) in + (t,replace b) + in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + RProd(loc,Name new_id,k,new_t,new_b) + | RLetIn(loc,Name id,t,b) -> + let new_id = Namegen.next_ident_away id excluded in + let t,b = + if new_id = id + then t,b + else + let replace = change_vars (Idmap.add id new_id Idmap.empty) in + (t,replace b) + in + let new_excluded = new_id::excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + RLetIn(loc,Name new_id,new_t,new_b) + + + | RLetTuple(loc,nal,(na,rto),t,b) -> + let rev_new_nal,new_excluded,mapping = + List.fold_left + (fun (nal,excluded,mapping) na -> + match na with + | Anonymous -> (na::nal,excluded,mapping) + | Name id -> + let new_id = Namegen.next_ident_away id excluded in + if new_id = id + then + na::nal,id::excluded,mapping + else + (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping) + ) + ([],excluded,Idmap.empty) + nal + in + let new_nal = List.rev rev_new_nal in + let new_rto,new_t,new_b = + if idmap_is_empty mapping + then rto,t,b + else let replace = change_vars mapping in + (Option.map replace rto, t,replace b) + in + let new_t = alpha_rt new_excluded new_t in + let new_b = alpha_rt new_excluded new_b in + let new_rto = Option.map (alpha_rt new_excluded) new_rto in + RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) + | RCases(loc,sty,infos,el,brl) -> + let new_el = + List.map (function (rt,i) -> alpha_rt excluded rt, i) el + in + RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) + | RIf(loc,b,(na,e_o),lhs,rhs) -> + RIf(loc,alpha_rt excluded b, + (na,Option.map (alpha_rt excluded) e_o), + alpha_rt excluded lhs, + alpha_rt excluded rhs + ) + | RRec _ -> error "Not handled RRec" + | RSort _ -> rt + | RHole _ -> rt + | RCast (loc,b,CastConv (k,t)) -> + RCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t)) + | RCast (loc,b,CastCoerce) -> + RCast(loc,alpha_rt excluded b,CastCoerce) + | RDynamic _ -> error "Not handled RDynamic" + | RApp(loc,f,args) -> + RApp(loc, + alpha_rt excluded f, + List.map (alpha_rt excluded) args + ) + in + new_rt + +and alpha_br excluded (loc,ids,patl,res) = + let new_patl,new_excluded,mapping = alpha_patl excluded patl in + let new_ids = List.fold_right raw_get_pattern_id new_patl [] in + let new_excluded = new_ids@excluded in + let renamed_res = change_vars mapping res in + let new_res = alpha_rt new_excluded renamed_res in + (loc,new_ids,new_patl,new_res) + +(* + [is_free_in id rt] checks if [id] is a free variable in [rt] +*) +let is_free_in id = + let rec is_free_in = function + | RRef _ -> false + | RVar(_,id') -> id_ord id' id == 0 + | REvar _ -> false + | RPatVar _ -> false + | RApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) + | RLambda(_,n,_,t,b) | RProd(_,n,_,t,b) | RLetIn(_,n,t,b) -> + let check_in_b = + match n with + | Name id' -> id_ord id' id <> 0 + | _ -> true + in + is_free_in t || (check_in_b && is_free_in b) + | RCases(_,_,_,el,brl) -> + (List.exists (fun (e,_) -> is_free_in e) el) || + List.exists is_free_in_br brl + | RLetTuple(_,nal,_,b,t) -> + let check_in_nal = + not (List.exists (function Name id' -> id'= id | _ -> false) nal) + in + is_free_in t || (check_in_nal && is_free_in b) + + | RIf(_,cond,_,br1,br2) -> + is_free_in cond || is_free_in br1 || is_free_in br2 + | RRec _ -> raise (UserError("",str "Not handled RRec")) + | RSort _ -> false + | RHole _ -> false + | RCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t + | RCast (_,b,CastCoerce) -> is_free_in b + | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) + and is_free_in_br (_,ids,_,rt) = + (not (List.mem id ids)) && is_free_in rt + in + is_free_in + + + +let rec pattern_to_term = function + | PatVar(loc,Anonymous) -> assert false + | PatVar(loc,Name id) -> + mkRVar id + | PatCstr(loc,constr,patternl,_) -> + let cst_narg = + Inductiveops.mis_constructor_nargs_env + (Global.env ()) + constr + in + let implicit_args = + Array.to_list + (Array.init + (cst_narg - List.length patternl) + (fun _ -> mkRHole ()) + ) + in + let patl_as_term = + List.map pattern_to_term patternl + in + mkRApp(mkRRef(Libnames.ConstructRef constr), + implicit_args@patl_as_term + ) + + + +let replace_var_by_term x_id term = + let rec replace_var_by_pattern rt = + match rt with + | RRef _ -> rt + | RVar(_,id) when id_ord id x_id == 0 -> term + | RVar _ -> rt + | REvar _ -> rt + | RPatVar _ -> rt + | RApp(loc,rt',rtl) -> + RApp(loc, + replace_var_by_pattern rt', + List.map replace_var_by_pattern rtl + ) + | RLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt + | RLambda(loc,name,k,t,b) -> + RLambda(loc, + name, + k, + replace_var_by_pattern t, + replace_var_by_pattern b + ) + | RProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt + | RProd(loc,name,k,t,b) -> + RProd(loc, + name, + k, + replace_var_by_pattern t, + replace_var_by_pattern b + ) + | RLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt + | RLetIn(loc,name,def,b) -> + RLetIn(loc, + name, + replace_var_by_pattern def, + replace_var_by_pattern b + ) + | RLetTuple(_,nal,_,_,_) + when List.exists (function Name id -> id = x_id | _ -> false) nal -> + rt + | RLetTuple(loc,nal,(na,rto),def,b) -> + RLetTuple(loc, + nal, + (na,Option.map replace_var_by_pattern rto), + replace_var_by_pattern def, + replace_var_by_pattern b + ) + | RCases(loc,sty,infos,el,brl) -> + RCases(loc,sty, + infos, + List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, + List.map replace_var_by_pattern_br brl + ) + | RIf(loc,b,(na,e_option),lhs,rhs) -> + RIf(loc, replace_var_by_pattern b, + (na,Option.map replace_var_by_pattern e_option), + replace_var_by_pattern lhs, + replace_var_by_pattern rhs + ) + | RRec _ -> raise (UserError("",str "Not handled RRec")) + | RSort _ -> rt + | RHole _ -> rt + | RCast(loc,b,CastConv(k,t)) -> + RCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t)) + | RCast(loc,b,CastCoerce) -> + RCast(loc,replace_var_by_pattern b,CastCoerce) + | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) + and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = + if List.exists (fun id -> id_ord id x_id == 0) idl + then br + else (loc,idl,patl,replace_var_by_pattern res) + in + replace_var_by_pattern + + + + +(* checking unifiability of patterns *) +exception NotUnifiable + +let rec are_unifiable_aux = function + | [] -> () + | eq::eqs -> + match eq with + | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs + | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> + if constructor2 <> constructor1 + then raise NotUnifiable + else + let eqs' = + try ((List.combine cpl1 cpl2)@eqs) + with _ -> anomaly "are_unifiable_aux" + in + are_unifiable_aux eqs' + +let are_unifiable pat1 pat2 = + try + are_unifiable_aux [pat1,pat2]; + true + with NotUnifiable -> false + + +let rec eq_cases_pattern_aux = function + | [] -> () + | eq::eqs -> + match eq with + | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs + | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> + if constructor2 <> constructor1 + then raise NotUnifiable + else + let eqs' = + try ((List.combine cpl1 cpl2)@eqs) + with _ -> anomaly "eq_cases_pattern_aux" + in + eq_cases_pattern_aux eqs' + | _ -> raise NotUnifiable + +let eq_cases_pattern pat1 pat2 = + try + eq_cases_pattern_aux [pat1,pat2]; + true + with NotUnifiable -> false + + + +let ids_of_pat = + let rec ids_of_pat ids = function + | PatVar(_,Anonymous) -> ids + | PatVar(_,Name id) -> Idset.add id ids + | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl + in + ids_of_pat Idset.empty + +let id_of_name = function + | Names.Anonymous -> id_of_string "x" + | Names.Name x -> x + +(* TODO: finish Rec caes *) +let ids_of_rawterm c = + let rec ids_of_rawterm acc c = + let idof = id_of_name in + match c with + | RVar (_,id) -> id::acc + | RApp (loc,g,args) -> + ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc + | RLambda (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc + | RProd (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc + | RLetIn (loc,na,b,c) -> idof na :: ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc + | RCast (loc,c,CastConv(k,t)) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc + | RCast (loc,c,CastCoerce) -> ids_of_rawterm [] c @ acc + | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc + | RLetTuple (_,nal,(na,po),b,c) -> + List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc + | RCases (loc,sty,rtntypopt,tml,brchl) -> + List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_rawterm [] c) brchl) + | RRec _ -> failwith "Fix inside a constructor branch" + | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> [] + in + (* build the set *) + List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c) + + + + + +let zeta_normalize = + let rec zeta_normalize_term rt = + match rt with + | RRef _ -> rt + | RVar _ -> rt + | REvar _ -> rt + | RPatVar _ -> rt + | RApp(loc,rt',rtl) -> + RApp(loc, + zeta_normalize_term rt', + List.map zeta_normalize_term rtl + ) + | RLambda(loc,name,k,t,b) -> + RLambda(loc, + name, + k, + zeta_normalize_term t, + zeta_normalize_term b + ) + | RProd(loc,name,k,t,b) -> + RProd(loc, + name, + k, + zeta_normalize_term t, + zeta_normalize_term b + ) + | RLetIn(_,Name id,def,b) -> + zeta_normalize_term (replace_var_by_term id def b) + | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b + | RLetTuple(loc,nal,(na,rto),def,b) -> + RLetTuple(loc, + nal, + (na,Option.map zeta_normalize_term rto), + zeta_normalize_term def, + zeta_normalize_term b + ) + | RCases(loc,sty,infos,el,brl) -> + RCases(loc,sty, + infos, + List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, + List.map zeta_normalize_br brl + ) + | RIf(loc,b,(na,e_option),lhs,rhs) -> + RIf(loc, zeta_normalize_term b, + (na,Option.map zeta_normalize_term e_option), + zeta_normalize_term lhs, + zeta_normalize_term rhs + ) + | RRec _ -> raise (UserError("",str "Not handled RRec")) + | RSort _ -> rt + | RHole _ -> rt + | RCast(loc,b,CastConv(k,t)) -> + RCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t)) + | RCast(loc,b,CastCoerce) -> + RCast(loc,zeta_normalize_term b,CastCoerce) + | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) + and zeta_normalize_br (loc,idl,patl,res) = + (loc,idl,patl,zeta_normalize_term res) + in + zeta_normalize_term + + + + +let expand_as = + + let rec add_as map pat = + match pat with + | PatVar _ -> map + | PatCstr(_,_,patl,Name id) -> + Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl) + | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl + in + let rec expand_as map rt = + match rt with + | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt + | RVar(_,id) -> + begin + try + Idmap.find id map + with Not_found -> rt + end + | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args) + | RLambda(loc,na,k,t,b) -> RLambda(loc,na,k,expand_as map t, expand_as map b) + | RProd(loc,na,k,t,b) -> RProd(loc,na,k,expand_as map t, expand_as map b) + | RLetIn(loc,na,v,b) -> RLetIn(loc,na, expand_as map v,expand_as map b) + | RLetTuple(loc,nal,(na,po),v,b) -> + RLetTuple(loc,nal,(na,Option.map (expand_as map) po), + expand_as map v, expand_as map b) + | RIf(loc,e,(na,po),br1,br2) -> + RIf(loc,expand_as map e,(na,Option.map (expand_as map) po), + expand_as map br1, expand_as map br2) + | RRec _ -> error "Not handled RRec" + | RDynamic _ -> error "Not handled RDynamic" + | RCast(loc,b,CastConv(kind,t)) -> RCast(loc,expand_as map b,CastConv(kind,expand_as map t)) + | RCast(loc,b,CastCoerce) -> RCast(loc,expand_as map b,CastCoerce) + | RCases(loc,sty,po,el,brl) -> + RCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, + List.map (expand_as_br map) brl) + and expand_as_br map (loc,idl,cpl,rt) = + (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) + in + expand_as Idmap.empty diff --git a/plugins/funind/rawtermops.mli b/plugins/funind/rawtermops.mli new file mode 100644 index 00000000..455e7c89 --- /dev/null +++ b/plugins/funind/rawtermops.mli @@ -0,0 +1,126 @@ +open Rawterm + +(* Ocaml 3.06 Map.S does not handle is_empty *) +val idmap_is_empty : 'a Names.Idmap.t -> bool + + +(* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) +val get_pattern_id : cases_pattern -> Names.identifier list + +(* [pattern_to_term pat] returns a rawconstr corresponding to [pat]. + [pat] must not contain occurences of anonymous pattern +*) +val pattern_to_term : cases_pattern -> rawconstr + +(* + Some basic functions to rebuild rawconstr + In each of them the location is Util.dummy_loc +*) +val mkRRef : Libnames.global_reference -> rawconstr +val mkRVar : Names.identifier -> rawconstr +val mkRApp : rawconstr*(rawconstr list) -> rawconstr +val mkRLambda : Names.name*rawconstr*rawconstr -> rawconstr +val mkRProd : Names.name*rawconstr*rawconstr -> rawconstr +val mkRLetIn : Names.name*rawconstr*rawconstr -> rawconstr +val mkRCases : rawconstr option * tomatch_tuples * cases_clauses -> rawconstr +val mkRSort : rawsort -> rawconstr +val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *) +val mkRCast : rawconstr* rawconstr -> rawconstr +(* + Some basic functions to decompose rawconstrs + These are analogous to the ones constrs +*) +val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr +val raw_decompose_prod_or_letin : + rawconstr -> (Names.name*rawconstr option*rawconstr option) list * rawconstr +val raw_decompose_prod_n : int -> rawconstr -> (Names.name*rawconstr) list * rawconstr +val raw_decompose_prod_or_letin_n : int -> rawconstr -> + (Names.name*rawconstr option*rawconstr option) list * rawconstr +val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list -> rawconstr +val raw_compose_prod_or_letin: rawconstr -> + (Names.name*rawconstr option*rawconstr option) list -> rawconstr +val raw_decompose_app : rawconstr -> rawconstr*(rawconstr list) + + +(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) +val raw_make_eq : ?typ:rawconstr -> rawconstr -> rawconstr -> rawconstr +(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) +val raw_make_neq : rawconstr -> rawconstr -> rawconstr +(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) +val raw_make_or : rawconstr -> rawconstr -> rawconstr + +(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding + to [P1 \/ ( .... \/ Pn)] +*) +val raw_make_or_list : rawconstr list -> rawconstr + + +(* alpha_conversion functions *) + + + +(* Replace the var mapped in the rawconstr/context *) +val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr + + + +(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. + the result does not share variables with [avoid]. This function create + a fresh variable for each occurence of the anonymous pattern. + + Also returns a mapping from old variables to new ones and the concatenation of + [avoid] with the variables appearing in the result. +*) + val alpha_pat : + Names.Idmap.key list -> + Rawterm.cases_pattern -> + Rawterm.cases_pattern * Names.Idmap.key list * + Names.identifier Names.Idmap.t + +(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt + conventions and does not share bound variables with avoid +*) +val alpha_rt : Names.identifier list -> rawconstr -> rawconstr + +(* same as alpha_rt but for case branches *) +val alpha_br : Names.identifier list -> + Util.loc * Names.identifier list * Rawterm.cases_pattern list * + Rawterm.rawconstr -> + Util.loc * Names.identifier list * Rawterm.cases_pattern list * + Rawterm.rawconstr + + +(* Reduction function *) +val replace_var_by_term : + Names.identifier -> + Rawterm.rawconstr -> Rawterm.rawconstr -> Rawterm.rawconstr + + + +(* + [is_free_in id rt] checks if [id] is a free variable in [rt] +*) +val is_free_in : Names.identifier -> rawconstr -> bool + + +val are_unifiable : cases_pattern -> cases_pattern -> bool +val eq_cases_pattern : cases_pattern -> cases_pattern -> bool + + + +(* + ids_of_pat : cases_pattern -> Idset.t + returns the set of variables appearing in a pattern +*) +val ids_of_pat : cases_pattern -> Names.Idset.t + +(* TODO: finish this function (Fix not treated) *) +val ids_of_rawterm: rawconstr -> Names.Idset.t + +(* + removing let_in construction in a rawterm +*) +val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr + + +val expand_as : rawconstr -> rawconstr diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml new file mode 100644 index 00000000..3b0b8628 --- /dev/null +++ b/plugins/funind/recdef.ml @@ -0,0 +1,1473 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* next_global_ident_away id (acc@ids)::acc) + idl + [] + +let pf_get_new_id id g = + List.hd (pf_get_new_ids [id] g) + +let h_intros l = + tclMAP h_intro l + +let debug_queue = Queue.create () + + +let rec print_debug_queue e = + let lmsg,goal = Queue.pop debug_queue in + if Queue.is_empty debug_queue + then + msgnl (lmsg ++ (str " raised exception " ++ Cerrors.explain_exn e) ++ str " on goal " ++ goal) + else + begin + print_debug_queue e; + msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal); + end + + +let do_observe_tac s tac g = + let goal = Printer.pr_goal (sig_it g) in + let lmsg = (str "recdef ") ++ (str s) in + Queue.add (lmsg,goal) debug_queue; + try + let v = tac g in + ignore(Queue.pop debug_queue); + v + with e -> + if not (Queue.is_empty debug_queue) + then + print_debug_queue e; + raise e + +(*let do_observe_tac s tac g = + let goal = begin (Printer.pr_goal (sig_it g)) end in + try let v = tac g in msgnl (goal ++ fnl () ++ (str "recdef ") ++ + (str s)++(str " ")++(str "finished")); v + with e -> + msgnl (str "observation "++str s++str " raised exception " ++ + Cerrors.explain_exn e ++ str " on goal " ++ goal ); + raise e;; +*) + +let observe_tac s tac g = + if Tacinterp.get_debug () <> Tactic_debug.DebugOff + then do_observe_tac s tac g + else tac g + +let hyp_ids = List.map id_of_string + ["x";"v";"k";"def";"p";"h";"n";"h'"; "anonymous"; "teq"; "rec_res"; + "hspec";"heq"; "hrec"; "hex"; "teq"; "pmax";"hle"];; + +let rec nthtl = function + l, 0 -> l | _::tl, n -> nthtl (tl, n-1) | [], _ -> [];; + +let hyp_id n l = List.nth l n;; + +let (x_id:identifier) = hyp_id 0 hyp_ids;; +let (v_id:identifier) = hyp_id 1 hyp_ids;; +let (k_id:identifier) = hyp_id 2 hyp_ids;; +let (def_id:identifier) = hyp_id 3 hyp_ids;; +let (p_id:identifier) = hyp_id 4 hyp_ids;; +let (h_id:identifier) = hyp_id 5 hyp_ids;; +let (n_id:identifier) = hyp_id 6 hyp_ids;; +let (h'_id:identifier) = hyp_id 7 hyp_ids;; +let (ano_id:identifier) = hyp_id 8 hyp_ids;; +let (rec_res_id:identifier) = hyp_id 10 hyp_ids;; +let (hspec_id:identifier) = hyp_id 11 hyp_ids;; +let (heq_id:identifier) = hyp_id 12 hyp_ids;; +let (hrec_id:identifier) = hyp_id 13 hyp_ids;; +let (hex_id:identifier) = hyp_id 14 hyp_ids;; +let (teq_id:identifier) = hyp_id 15 hyp_ids;; +let (pmax_id:identifier) = hyp_id 16 hyp_ids;; +let (hle_id:identifier) = hyp_id 17 hyp_ids;; + +let message s = if Flags.is_verbose () then msgnl(str s);; + +let def_of_const t = + match (kind_of_term t) with + Const sp -> + (try (match (Global.lookup_constant sp) with + {const_body=Some c} -> Declarations.force c + |_ -> assert false) + with _ -> + anomaly ("Cannot find definition of constant "^ + (string_of_id (id_of_label (con_label sp)))) + ) + |_ -> assert false + +let type_of_const t = + match (kind_of_term t) with + Const sp -> Typeops.type_of_constant (Global.env()) sp + |_ -> assert false + +let arg_type t = + match kind_of_term (def_of_const t) with + Lambda(a,b,c) -> b + | _ -> assert false;; + +let evaluable_of_global_reference r = + match r with + ConstRef sp -> EvalConstRef sp + | VarRef id -> EvalVarRef id + | _ -> assert false;; + + +let rank_for_arg_list h = + let predicate a b = + try List.for_all2 eq_constr a b with + Invalid_argument _ -> false in + let rec rank_aux i = function + | [] -> None + | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in + rank_aux 0;; + +let rec (find_call_occs : int -> constr -> constr -> + (constr list -> constr) * constr list list) = + fun nb_lam f expr -> + match (kind_of_term expr) with + App (g, args) when g = f -> + (fun l -> List.hd l), [Array.to_list args] + | App (g, args) -> + let (largs: constr list) = Array.to_list args in + let rec find_aux = function + [] -> (fun x -> []), [] + | a::upper_tl -> + (match find_aux upper_tl with + (cf, ((arg1::args) as args_for_upper_tl)) -> + (match find_call_occs nb_lam f a with + cf2, (_ :: _ as other_args) -> + let rec avoid_duplicates args = + match args with + | [] -> (fun _ -> []), [] + | h::tl -> + let recomb_tl, args_for_tl = + avoid_duplicates tl in + match rank_for_arg_list h args_for_upper_tl with + | None -> + (fun l -> List.hd l::recomb_tl(List.tl l)), + h::args_for_tl + | Some i -> + (fun l -> List.nth l (i+List.length args_for_tl):: + recomb_tl l), + args_for_tl + in + let recombine, other_args' = + avoid_duplicates other_args in + let len1 = List.length other_args' in + (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))), + other_args'@args_for_upper_tl + | _, [] -> (fun x -> a::cf x), args_for_upper_tl) + | _, [] -> + (match find_call_occs nb_lam f a with + cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args) + | _, [] -> (fun x -> a::upper_tl), [])) in + begin + match (find_aux largs) with + cf, [] -> (fun l -> mkApp(g, args)), [] + | cf, args -> + (fun l -> mkApp (g, Array.of_list (cf l))), args + end + | Rel(v) -> if v > nb_lam then error "find_call_occs : Rel" else ((fun l -> expr),[]) + | Var(id) -> (fun l -> expr), [] + | Meta(_) -> error "find_call_occs : Meta" + | Evar(_) -> error "find_call_occs : Evar" + | Sort(_) -> (fun l -> expr), [] + | Cast(b,_,_) -> find_call_occs nb_lam f b + | Prod(_,_,_) -> error "find_call_occs : Prod" + | Lambda(na,t,b) -> + begin + match find_call_occs (succ nb_lam) f b with + | _, [] -> (* Lambda are authorized as long as they do not contain + recursives calls *) + (fun l -> expr),[] + | _ -> error "find_call_occs : Lambda" + end + | LetIn(na,v,t,b) -> + begin + match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with + | (_,[]),(_,[]) -> + ((fun l -> expr), []) + | (_,[]),(cf,(_::_ as l)) -> + ((fun l -> mkLetIn(na,v,t,cf l)),l) + | (cf,(_::_ as l)),(_,[]) -> + ((fun l -> mkLetIn(na,cf l,t,b)), l) + | _ -> error "find_call_occs : LetIn" + end + | Const(_) -> (fun l -> expr), [] + | Ind(_) -> (fun l -> expr), [] + | Construct (_, _) -> (fun l -> expr), [] + | Case(i,t,a,r) -> + (match find_call_occs nb_lam f a with + cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args) + | _ -> (fun l -> expr),[]) + | Fix(_) -> error "find_call_occs : Fix" + | CoFix(_) -> error "find_call_occs : CoFix";; + +let coq_constant s = + Coqlib.gen_constant_in_modules "RecursiveDefinition" + (Coqlib.init_modules @ Coqlib.arith_modules) s;; + +let coq_base_constant s = + Coqlib.gen_constant_in_modules "RecursiveDefinition" + (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s;; + +let constant sl s = + constr_of_global + (locate (make_qualid(Names.make_dirpath + (List.map id_of_string (List.rev sl))) + (id_of_string s)));; + +let find_reference sl s = + (locate (make_qualid(Names.make_dirpath + (List.map id_of_string (List.rev sl))) + (id_of_string s)));; + +let delayed_force f = f () + +let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") +let le_lt_n_Sm = function () -> (coq_base_constant "le_lt_n_Sm") + +let le_trans = function () -> (coq_base_constant "le_trans") +let le_lt_trans = function () -> (coq_base_constant "le_lt_trans") +let lt_S_n = function () -> (coq_base_constant "lt_S_n") +let le_n = function () -> (coq_base_constant "le_n") +let refl_equal = function () -> (coq_base_constant "eq_refl") +let eq = function () -> (coq_base_constant "eq") +let ex = function () -> (coq_base_constant "ex") +let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig") +let coq_sig = function () -> (coq_base_constant "sig") +let coq_O = function () -> (coq_base_constant "O") +let coq_S = function () -> (coq_base_constant "S") + +let gt_antirefl = function () -> (coq_constant "gt_irrefl") +let lt_n_O = function () -> (coq_base_constant "lt_n_O") +let lt_n_Sn = function () -> (coq_base_constant "lt_n_Sn") + +let f_equal = function () -> (coq_constant "f_equal") +let well_founded_induction = function () -> (coq_constant "well_founded_induction") +let well_founded = function () -> (coq_constant "well_founded") +let acc_rel = function () -> (coq_constant "Acc") +let acc_inv_id = function () -> (coq_constant "Acc_inv") +let well_founded_ltof = function () -> (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof") +let iter_ref = function () -> (try find_reference ["Recdef"] "iter" with Not_found -> error "module Recdef not loaded") +let max_ref = function () -> (find_reference ["Recdef"] "max") +let iter = function () -> (constr_of_global (delayed_force iter_ref)) +let max_constr = function () -> (constr_of_global (delayed_force max_ref)) + +let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") +let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj" + +(* These are specific to experiments in nat with lt as well_founded_relation, *) +(* but this should be made more general. *) +let nat = function () -> (coq_base_constant "nat") +let lt = function () -> (coq_base_constant "lt") + +(* This is simply an implementation of the case_eq tactic. this code + should be replaced with the tactic defined in Ltac in Init/Tactics.v *) +let mkCaseEq a : tactic = + (fun g -> + let type_of_a = pf_type_of g a in + tclTHENLIST + [h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; + (fun g2 -> + change_in_concl None + (pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2)) + g2); + simplest_case a] g);; + +(* This is like the previous one except that it also rewrite on all + hypotheses except the ones given in the first argument. All the + modified hypotheses are generalized in the process and should be + introduced back later; the result is the pair of the tactic and the + list of hypotheses that have been generalized and cleared. *) +let mkDestructEq : + identifier list -> constr -> goal sigma -> tactic * identifier list = + fun not_on_hyp expr g -> + let hyps = pf_hyps g in + let to_revert = + Util.map_succeed + (fun (id,_,t) -> + if List.mem id not_on_hyp || not (Termops.occur_term expr t) + then failwith "is_expr_context"; + id) hyps in + let to_revert_constr = List.rev_map mkVar to_revert in + let type_of_expr = pf_type_of g expr in + let new_hyps = mkApp(delayed_force refl_equal, [|type_of_expr; expr|]):: + to_revert_constr in + tclTHENLIST + [h_generalize new_hyps; + (fun g2 -> + change_in_concl None + (pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2); + simplest_case expr], to_revert + +let rec mk_intros_and_continue thin_intros (extra_eqn:bool) + cont_function (eqs:constr list) nb_lam (expr:constr) g = + observe_tac "mk_intros_and_continue" ( + let finalize () = if extra_eqn then + let teq = pf_get_new_id teq_id g in + tclTHENLIST + [ h_intro teq; + thin thin_intros; + h_intros thin_intros; + + tclMAP + (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences (* deps proofs also: *) true teq eq false)) + (List.rev eqs); + (fun g1 -> + let ty_teq = pf_type_of g1 (mkVar teq) in + let teq_lhs,teq_rhs = + let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in + args.(1),args.(2) + in + cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1 + ) + ] + + else + tclTHENSEQ[ + thin thin_intros; + h_intros thin_intros; + cont_function eqs expr + ] + in + if nb_lam = 0 + then finalize () + else + match kind_of_term expr with + | Lambda (n, _, b) -> + let n1 = + match n with + Name x -> x + | Anonymous -> ano_id + in + let new_n = pf_get_new_id n1 g in + tclTHEN (h_intro new_n) + (mk_intros_and_continue thin_intros extra_eqn cont_function eqs + (pred nb_lam) (subst1 (mkVar new_n) b)) + | _ -> + assert false) g +(* finalize () *) +let const_of_ref = function + ConstRef kn -> kn + | _ -> anomaly "ConstRef expected" + +let simpl_iter clause = + reduce + (Lazy + {rBeta=true;rIota=true;rZeta= true; rDelta=false; + rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) +(* (Simpl (Some ([],mkConst (const_of_ref (delayed_force iter_ref))))) *) + clause + +(* The boolean value is_mes expresses that the termination is expressed + using a measure function instead of a well-founded relation. *) +let tclUSER tac is_mes l g = + let clear_tac = + match l with + | None -> h_clear true [] + | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l) + in + tclTHENSEQ + [ + clear_tac; + if is_mes + then tclTHEN + (unfold_in_concl [(all_occurrences, evaluable_of_global_reference + (delayed_force ltof_ref))]) + tac + else tac + ] + g + + +let list_rewrite (rev:bool) (eqs: constr list) = + tclREPEAT + (List.fold_right + (fun eq i -> tclORELSE (rewriteLR eq) i) + (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; + +let base_leaf_terminate (func:global_reference) eqs expr = +(* let _ = msgnl (str "entering base_leaf") in *) + (fun g -> + let k',h = + match pf_get_new_ids [k_id;h_id] g with + [k';h] -> k',h + | _ -> assert false + in + tclTHENLIST + [observe_tac "first split" (split (ImplicitBindings [expr])); + observe_tac "second split" + (split (ImplicitBindings [delayed_force coq_O])); + observe_tac "intro k" (h_intro k'); + observe_tac "case on k" + (tclTHENS (simplest_case (mkVar k')) + [(tclTHEN (h_intro h) + (tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl, + [| delayed_force coq_O |]))) + default_auto)); tclIDTAC ]); + intros; + simpl_iter onConcl; + unfold_constr func; + list_rewrite true eqs; + default_auto] g);; + +(* La fonction est donnee en premier argument a la + fonctionnelle suivie d'autres Lambdas et de Case ... + Pour recuperer la fonction f a partir de la + fonctionnelle *) + +let get_f foncl = + match (kind_of_term (def_of_const foncl)) with + Lambda (Name f, _, _) -> f + |_ -> error "la fonctionnelle est mal definie";; + + +let rec compute_le_proofs = function + [] -> assumption + | a::tl -> + tclORELSE assumption + (tclTHENS + (fun g -> + let le_trans = delayed_force le_trans in + let t_le_trans = compute_renamed_type g le_trans in + let m_id = + let _,_,t = destProd t_le_trans in + let na,_,_ = destProd t in + Nameops.out_name na + in + apply_with_bindings + (le_trans, + ExplicitBindings[dummy_loc,NamedHyp m_id,a]) + g) + [compute_le_proofs tl; + tclORELSE (apply (delayed_force le_n)) assumption]) + +let make_lt_proof pmax le_proof = + tclTHENS + (fun g -> + let le_lt_trans = delayed_force le_lt_trans in + let t_le_lt_trans = compute_renamed_type g le_lt_trans in + let m_id = + let _,_,t = destProd t_le_lt_trans in + let na,_,_ = destProd t in + Nameops.out_name na + in + apply_with_bindings + (le_lt_trans, + ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g) + [observe_tac "compute_le_proofs" (compute_le_proofs le_proof); + tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];; + +let rec list_cond_rewrite k def pmax cond_eqs le_proofs = + match cond_eqs with + [] -> tclIDTAC + | eq::eqs -> + (fun g -> + let t_eq = compute_renamed_type g (mkVar eq) in + let k_id,def_id = + let k_na,_,t = destProd t_eq in + let _,_,t = destProd t in + let def_na,_,_ = destProd t in + Nameops.out_name k_na,Nameops.out_name def_na + in + tclTHENS + (general_rewrite_bindings false all_occurrences + (* dep proofs also: *) true + (mkVar eq, + ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k; + dummy_loc, NamedHyp def_id, mkVar def]) false) + [list_cond_rewrite k def pmax eqs le_proofs; + observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g + ) + +let rec introduce_all_equalities func eqs values specs bound le_proofs + cond_eqs = + match specs with + [] -> + fun g -> + let ids = pf_ids_of_hyps g in + let s_max = mkApp(delayed_force coq_S, [|bound|]) in + let k = next_ident_away_in_goal k_id ids in + let ids = k::ids in + let h' = next_ident_away_in_goal (h'_id) ids in + let ids = h'::ids in + let def = next_ident_away_in_goal def_id ids in + tclTHENLIST + [observe_tac "introduce_all_equalities_final split" (split (ImplicitBindings [s_max])); + observe_tac "introduce_all_equalities_final intro k" (h_intro k); + tclTHENS + (observe_tac "introduce_all_equalities_final case k" (simplest_case (mkVar k))) + [ + tclTHENLIST[h_intro h'; + simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|])); + default_full_auto]; + tclIDTAC + ]; + observe_tac "clearing k " (clear [k]); + observe_tac "intros k h' def" (h_intros [k;h';def]); + observe_tac "simple_iter" (simpl_iter onConcl); + observe_tac "unfold functional" + (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]); + observe_tac "rewriting equations" + (list_rewrite true eqs); + observe_tac ("cond rewrite "^(string_of_id k)) (list_cond_rewrite k def bound cond_eqs le_proofs); + observe_tac "refl equal" (apply (delayed_force refl_equal))] g + | spec1::specs -> + fun g -> + let ids = ids_of_named_context (pf_hyps g) in + let p = next_ident_away_in_goal p_id ids in + let ids = p::ids in + let pmax = next_ident_away_in_goal pmax_id ids in + let ids = pmax::ids in + let hle1 = next_ident_away_in_goal hle_id ids in + let ids = hle1::ids in + let hle2 = next_ident_away_in_goal hle_id ids in + let ids = hle2::ids in + let heq = next_ident_away_in_goal heq_id ids in + tclTHENLIST + [simplest_elim (mkVar spec1); + list_rewrite true eqs; + h_intros [p; heq]; + simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|])); + h_intros [pmax; hle1; hle2]; + introduce_all_equalities func eqs values specs + (mkVar pmax) ((mkVar pmax)::le_proofs) + (heq::cond_eqs)] g;; + +let string_match s = + if String.length s < 3 then failwith "string_match"; + try + for i = 0 to 3 do + if String.get s i <> String.get "Acc_" i then failwith "string_match" + done; + with Invalid_argument _ -> failwith "string_match" + +let retrieve_acc_var g = + (* Julien: I don't like this version .... *) + let hyps = pf_ids_of_hyps g in + map_succeed + (fun id -> string_match (string_of_id id);id) + hyps + +let rec introduce_all_values concl_tac is_mes acc_inv func context_fn + eqs hrec args values specs = + (match args with + [] -> + tclTHENLIST + [observe_tac "split" (split(ImplicitBindings + [context_fn (List.map mkVar (List.rev values))])); + observe_tac "introduce_all_equalities" (introduce_all_equalities func eqs + (List.rev values) (List.rev specs) (delayed_force coq_O) [] [])] + | arg::args -> + (fun g -> + let ids = ids_of_named_context (pf_hyps g) in + let rec_res = next_ident_away_in_goal rec_res_id ids in + let ids = rec_res::ids in + let hspec = next_ident_away_in_goal hspec_id ids in + let tac = + observe_tac "introduce_all_values" ( + introduce_all_values concl_tac is_mes acc_inv func context_fn eqs + hrec args + (rec_res::values)(hspec::specs)) in + (tclTHENS + (observe_tac "elim h_rec" + (simplest_elim (mkApp(mkVar hrec, Array.of_list arg))) + ) + [tclTHENLIST [h_intros [rec_res; hspec]; + tac]; + (tclTHENS + (observe_tac "acc_inv" (apply (Lazy.force acc_inv))) + [(* tclTHEN (tclTRY(list_rewrite true eqs)) *) + (observe_tac "h_assumption" h_assumption) + ; + tclTHENLIST + [ + tclTRY(list_rewrite true eqs); + observe_tac "user proof" + (fun g -> + tclUSER + concl_tac + is_mes + (Some (hrec::hspec::(retrieve_acc_var g)@specs)) + g + ) + ] + ] + ) + ]) g) + + ) + + +let rec_leaf_terminate f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr = + match find_call_occs 0 f_constr expr with + | context_fn, args -> + observe_tac "introduce_all_values" + (introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args [] []) + +let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier) + (f_constr:constr) (func:global_reference) base_leaf rec_leaf = + let rec proveterminate (eqs:constr list) (expr:constr) = + try + (* let _ = msgnl (str "entering proveterminate") in *) + let v = + match (kind_of_term expr) with + Case (ci, t, a, l) -> + (match find_call_occs 0 f_constr a with + _,[] -> + (fun g -> + let destruct_tac, rev_to_thin_intro = + mkDestructEq rec_arg_id a g in + tclTHENS destruct_tac + (list_map_i + (fun i -> mk_intros_and_continue + (List.rev rev_to_thin_intro) + true + proveterminate + eqs + ci.ci_cstr_nargs.(i)) + 0 (Array.to_list l)) g) + | _, _::_ -> + (match find_call_occs 0 f_constr expr with + _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr) + | _, _:: _ -> + observe_tac "rec_leaf" + (rec_leaf is_mes acc_inv hrec func eqs expr))) + | _ -> + (match find_call_occs 0 f_constr expr with + _,[] -> + (try observe_tac "base_leaf" (base_leaf func eqs expr) + with e -> (msgerrnl (str "failure in base case");raise e )) + | _, _::_ -> + observe_tac "rec_leaf" + (rec_leaf is_mes acc_inv hrec func eqs expr)) in + v + with e -> begin msgerrnl(str "failure in proveterminate"); raise e end + in + proveterminate + +let hyp_terminates nb_args func = + let a_arrow_b = arg_type (constr_of_global func) in + let rev_args,b = decompose_prod_n nb_args a_arrow_b in + let left = + mkApp(delayed_force iter, + Array.of_list + (lift 5 a_arrow_b:: mkRel 3:: + constr_of_global func::mkRel 1:: + List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args) + ) + ) + in + let right = mkRel 5 in + let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in + let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in + let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in + let nb_iter = + mkApp(delayed_force ex, + [|delayed_force nat; + (mkLambda + (Name + p_id, + delayed_force nat, + (mkProd (Name k_id, delayed_force nat, + mkArrow cond result))))|])in + let value = mkApp(delayed_force coq_sig, + [|b; + (mkLambda (Name v_id, b, nb_iter))|]) in + compose_prod rev_args value + + + +let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = + if is_mes + then tclCOMPLETE (h_simplest_apply (delayed_force well_founded_ltof)) + else tclUSER concl_tac is_mes names_to_suppress + +let termination_proof_header is_mes input_type ids args_id relation + rec_arg_num rec_arg_id tac wf_tac : tactic = + begin + fun g -> + let nargs = List.length args_id in + let pre_rec_args = + List.rev_map + mkVar (fst (list_chop (rec_arg_num - 1) args_id)) + in + let relation = substl pre_rec_args relation in + let input_type = substl pre_rec_args input_type in + let wf_thm = next_ident_away_in_goal (id_of_string ("wf_R")) ids in + let wf_rec_arg = + next_ident_away_in_goal + (id_of_string ("Acc_"^(string_of_id rec_arg_id))) + (wf_thm::ids) + in + let hrec = next_ident_away_in_goal hrec_id + (wf_rec_arg::wf_thm::ids) in + let acc_inv = + lazy ( + mkApp ( + delayed_force acc_inv_id, + [|input_type;relation;mkVar rec_arg_id|] + ) + ) + in + tclTHEN + (h_intros args_id) + (tclTHENS + (observe_tac + "first assert" + (assert_tac + (Name wf_rec_arg) + (mkApp (delayed_force acc_rel, + [|input_type;relation;mkVar rec_arg_id|]) + ) + ) + ) + [ + (* accesibility proof *) + tclTHENS + (observe_tac + "second assert" + (assert_tac + (Name wf_thm) + (mkApp (delayed_force well_founded,[|input_type;relation|])) + ) + ) + [ + (* interactive proof that the relation is well_founded *) + observe_tac "wf_tac" (wf_tac is_mes (Some args_id)); + (* this gives the accessibility argument *) + observe_tac + "apply wf_thm" + (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|])) + ) + ] + ; + (* rest of the proof *) + tclTHENSEQ + [observe_tac "generalize" + (onNLastHypsId (nargs+1) + (tclMAP (fun id -> + tclTHEN (h_generalize [mkVar id]) (h_clear false [id])) + )) + ; + observe_tac "h_fix" (h_fix (Some hrec) (nargs+1)); + h_intros args_id; + h_intro wf_rec_arg; + observe_tac "tac" (tac wf_rec_arg hrec acc_inv) + ] + ] + ) g + end + + + +let rec instantiate_lambda t l = + match l with + | [] -> t + | a::l -> + let (bound_name, _, body) = destLambda t in + instantiate_lambda (subst1 a body) l +;; + + +let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = + begin + fun g -> + let ids = ids_of_named_context (pf_hyps g) in + let func_body = (def_of_const (constr_of_global func)) in + let (f_name, _, body1) = destLambda func_body in + let f_id = + match f_name with + | Name f_id -> next_ident_away_in_goal f_id ids + | Anonymous -> anomaly "Anonymous function" + in + let n_names_types,_ = decompose_lam_n nb_args body1 in + let n_ids,ids = + List.fold_left + (fun (n_ids,ids) (n_name,_) -> + match n_name with + | Name id -> + let n_id = next_ident_away_in_goal id ids in + n_id::n_ids,n_id::ids + | _ -> anomaly "anonymous argument" + ) + ([],(f_id::ids)) + n_names_types + in + let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in + let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in + termination_proof_header + is_mes + input_type + ids + n_ids + relation + rec_arg_num + rec_arg_id + (fun rec_arg_id hrec acc_inv g -> + (proveterminate + [rec_arg_id] + is_mes + acc_inv + hrec + (mkVar f_id) + func + base_leaf_terminate + (rec_leaf_terminate (mkVar f_id) concl_tac) + [] + expr + ) + g + ) + (tclUSER_if_not_mes concl_tac) + g + end + +let get_current_subgoals_types () = + let pts = get_pftreestate () in + let _,subs = extract_open_pftreestate pts in + List.map snd ((* List.sort (fun (x,_) (y,_) -> x -y ) *)subs ) + +let build_and_l l = + let and_constr = Coqlib.build_coq_and () in + let conj_constr = coq_conj () in + let mk_and p1 p2 = + Term.mkApp(and_constr,[|p1;p2|]) in + let rec f = function + | [] -> failwith "empty list of subgoals!" + | [p] -> p,tclIDTAC,1 + | p1::pl -> + let c,tac,nb = f pl in + mk_and p1 c, + tclTHENS + (apply (constr_of_global conj_constr)) + [tclIDTAC; + tac + ],nb+1 + in f l + + +let is_rec_res id = + let rec_res_name = string_of_id rec_res_id in + let id_name = string_of_id id in + try + String.sub id_name 0 (String.length rec_res_name) = rec_res_name + with _ -> false + +let clear_goals = + let rec clear_goal t = + match kind_of_term t with + | Prod(Name id as na,t',b) -> + let b' = clear_goal b in + if noccurn 1 b' && (is_rec_res id) + then pop b' + else if b' == b then t + else mkProd(na,t',b') + | _ -> map_constr clear_goal t + in + List.map clear_goal + + +let build_new_goal_type () = + let sub_gls_types = get_current_subgoals_types () in + (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) + let sub_gls_types = clear_goals sub_gls_types in + (* Pp.msgnl (str "sub_gls_types2 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) + let res = build_and_l sub_gls_types in + res + +let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = + (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) + let current_proof_name = get_current_proof_name () in + let name = match goal_name with + | Some s -> s + | None -> + try (add_suffix current_proof_name "_subproof") + with _ -> anomaly "open_new_goal with an unamed theorem" + in + let sign = Global.named_context () in + let sign = clear_proofs sign in + let na = next_global_ident_away name [] in + if occur_existential gls_type then + Util.error "\"abstract\" cannot handle existentials"; + let hook _ _ = + let opacity = + let na_ref = Libnames.Ident (dummy_loc,na) in + let na_global = Nametab.global na_ref in + match na_global with + ConstRef c -> + let cb = Global.lookup_constant c in + if cb.Declarations.const_opaque then true + else begin match cb.const_body with None -> true | _ -> false end + | _ -> anomaly "equation_lemma: not a constant" + in + let lemma = mkConst (Lib.make_con na) in + ref_ := Some lemma ; + let lid = ref [] in + let h_num = ref (-1) in + Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None); + build_proof + ( fun gls -> + let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in + tclTHENSEQ + [ + h_generalize [lemma]; + h_intro hid; + (fun g -> + let ids = pf_ids_of_hyps g in + tclTHEN + (Elim.h_decompose_and (mkVar hid)) + (fun g -> + let ids' = pf_ids_of_hyps g in + lid := List.rev (list_subtract ids' ids); + if !lid = [] then lid := [hid]; + tclIDTAC g + ) + g + ); + ] gls) + (fun g -> + match kind_of_term (pf_concl g) with + | App(f,_) when eq_constr f (well_founded ()) -> + Auto.h_auto None [] (Some []) g + | _ -> + incr h_num; + (observe_tac "finishing using" + ( + tclCOMPLETE( + tclFIRST[ + tclTHEN + (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) + e_assumption; + Eauto.eauto_with_bases + false + (true,5) + [delayed_force refl_equal] + [Auto.Hint_db.empty empty_transparent_state false] + ] + ) + ) + ) + g) +; + Lemmas.save_named opacity; + in + start_proof + na + (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) + sign + gls_type + hook ; + if Indfun_common.is_strict_tcc () + then + by (tclIDTAC) + else + begin + by ( + fun g -> + tclTHEN + (decompose_and_tac) + (tclORELSE + (tclFIRST + (List.map + (fun c -> + tclTHENSEQ + [intros; + h_simplest_apply (interp_constr Evd.empty (Global.env()) c); + tclCOMPLETE Auto.default_auto + ] + ) + using_lemmas) + ) tclIDTAC) + g) + end; + try + by tclIDTAC; (* raises UserError _ if the proof is complete *) + if Flags.is_verbose () then (pp (Printer.pr_open_subgoals())) + with UserError _ -> + defined () + +;; + + +let com_terminate + tcc_lemma_name + tcc_lemma_ref + is_mes + fonctional_ref + input_type + relation + rec_arg_num + thm_name using_lemmas + nb_args + hook = + let start_proof (tac_start:tactic) (tac_end:tactic) = + let (evmap, env) = Lemmas.get_current_context() in + start_proof thm_name + (Global, Proof Lemma) (Environ.named_context_val env) + (hyp_terminates nb_args fonctional_ref) hook; + + by (observe_tac "starting_tac" tac_start); + by (observe_tac "whole_start" (whole_start tac_end nb_args is_mes fonctional_ref + input_type relation rec_arg_num )) + in + start_proof tclIDTAC tclIDTAC; + try + let new_goal_type = build_new_goal_type () in + open_new_goal start_proof using_lemmas tcc_lemma_ref + (Some tcc_lemma_name) + (new_goal_type); + + with Failure "empty list of subgoals!" -> + (* a non recursive function declared with measure ! *) + defined () + + + + +let ind_of_ref = function + | IndRef (ind,i) -> (ind,i) + | _ -> anomaly "IndRef expected" + +let (value_f:constr list -> global_reference -> constr) = + fun al fterm -> + let d0 = dummy_loc in + let rev_x_id_l = + ( + List.fold_left + (fun x_id_l _ -> + let x_id = next_ident_away_in_goal x_id x_id_l in + x_id::x_id_l + ) + [] + al + ) + in + let fun_body = + RCases + (d0,RegularStyle,None, + [RApp(d0, RRef(d0,fterm), List.rev_map (fun x_id -> RVar(d0, x_id)) rev_x_id_l), + (Anonymous,None)], + [d0, [v_id], [PatCstr(d0,(ind_of_ref + (delayed_force coq_sig_ref),1), + [PatVar(d0, Name v_id); + PatVar(d0, Anonymous)], + Anonymous)], + RVar(d0,v_id)]) + in + let value = + List.fold_left2 + (fun acc x_id a -> + RLambda + (d0, Name x_id, Explicit, RDynamic(d0, constr_in a), + acc + ) + ) + fun_body + rev_x_id_l + (List.rev al) + in + understand Evd.empty (Global.env()) value;; + +let (declare_fun : identifier -> logical_kind -> constr -> global_reference) = + fun f_id kind value -> + let ce = {const_entry_body = value; + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = true} in + ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; + +let (declare_f : identifier -> logical_kind -> constr list -> global_reference -> global_reference) = + fun f_id kind input_type fterm_ref -> + declare_fun f_id kind (value_f input_type fterm_ref);; + +let rec n_x_id ids n = + if n = 0 then [] + else let x = next_ident_away_in_goal x_id ids in + x::n_x_id (x::ids) (n-1);; + +let start_equation (f:global_reference) (term_f:global_reference) + (cont_tactic:identifier list -> tactic) g = + let ids = pf_ids_of_hyps g in + let terminate_constr = constr_of_global term_f in + let nargs = nb_prod (type_of_const terminate_constr) in + let x = n_x_id ids nargs in + tclTHENLIST [ + h_intros x; + unfold_in_concl [(all_occurrences, evaluable_of_global_reference f)]; + observe_tac "simplest_case" + (simplest_case (mkApp (terminate_constr, + Array.of_list (List.map mkVar x)))); + observe_tac "prove_eq" (cont_tactic x)] g;; + +let base_leaf_eq func eqs f_id g = + let ids = pf_ids_of_hyps g in + let k = next_ident_away_in_goal k_id ids in + let p = next_ident_away_in_goal p_id (k::ids) in + let v = next_ident_away_in_goal v_id (p::k::ids) in + let heq = next_ident_away_in_goal heq_id (v::p::k::ids) in + let heq1 = next_ident_away_in_goal heq_id (heq::v::p::k::ids) in + let hex = next_ident_away_in_goal hex_id (heq1::heq::v::p::k::ids) in + tclTHENLIST [ + h_intros [v; hex]; + simplest_elim (mkVar hex); + h_intros [p;heq1]; + tclTRY + (rewriteRL + (mkApp(mkVar heq1, + [|mkApp (delayed_force coq_S, [|mkVar p|]); + mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|]))); + simpl_iter onConcl; + tclTRY (unfold_in_concl [((true,[1]), evaluable_of_global_reference func)]); + observe_tac "list_revrite" (list_rewrite true eqs); + apply (delayed_force refl_equal)] g;; + +let f_S t = mkApp(delayed_force coq_S, [|t|]);; + + +let rec introduce_all_values_eq cont_tac functional termine + f p heq1 pmax bounds le_proofs eqs ids = + function + [] -> + let heq2 = next_ident_away_in_goal heq_id ids in + tclTHENLIST + [pose_proof (Name heq2) + (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|])); + simpl_iter (onHyp heq2); + unfold_in_hyp [((true,[1]), evaluable_of_global_reference + (global_of_constr functional))] + (heq2, InHyp); + tclTHENS + (fun gls -> + let t_eq = compute_renamed_type gls (mkVar heq2) in + let def_id = + let _,_,t = destProd t_eq in let def_na,_,_ = destProd t in + Nameops.out_name def_na + in + observe_tac "rewrite heq" (general_rewrite_bindings false all_occurrences + (* dep proofs also: *) true (mkVar heq2, + ExplicitBindings[dummy_loc,NamedHyp def_id, + f]) false) gls) + [tclTHENLIST + [observe_tac "list_rewrite" (list_rewrite true eqs); + cont_tac pmax le_proofs]; + tclTHENLIST[apply (delayed_force le_lt_SS); + compute_le_proofs le_proofs]]] + | arg::args -> + let v' = next_ident_away_in_goal v_id ids in + let ids = v'::ids in + let hex' = next_ident_away_in_goal hex_id ids in + let ids = hex'::ids in + let p' = next_ident_away_in_goal p_id ids in + let ids = p'::ids in + let new_pmax = next_ident_away_in_goal pmax_id ids in + let ids = pmax::ids in + let hle1 = next_ident_away_in_goal hle_id ids in + let ids = hle1::ids in + let hle2 = next_ident_away_in_goal hle_id ids in + let ids = hle2::ids in + let heq = next_ident_away_in_goal heq_id ids in + let ids = heq::ids in + let heq2 = next_ident_away_in_goal heq_id ids in + let ids = heq2::ids in + tclTHENLIST + [mkCaseEq(mkApp(termine, Array.of_list arg)); + h_intros [v'; hex']; + simplest_elim(mkVar hex'); + h_intros [p']; + simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax; + mkVar p'|])); + h_intros [new_pmax;hle1;hle2]; + introduce_all_values_eq + (fun pmax' le_proofs'-> + tclTHENLIST + [cont_tac pmax' le_proofs'; + h_intros [heq;heq2]; + observe_tac ("rewriteRL " ^ (string_of_id heq2)) + (tclTRY (rewriteLR (mkVar heq2))); + tclTRY (tclTHENS + ( fun g -> + let t_eq = compute_renamed_type g (mkVar heq) in + let k_id,def_id = + let k_na,_,t = destProd t_eq in + let _,_,t = destProd t in + let def_na,_,_ = destProd t in + Nameops.out_name k_na,Nameops.out_name def_na + in + let c_b = (mkVar heq, + ExplicitBindings + [dummy_loc, NamedHyp k_id, + f_S(mkVar pmax'); + dummy_loc, NamedHyp def_id, f]) + in + observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false all_occurrences (* dep proofs also: *) true + c_b false)) + g + ) + [tclIDTAC; + tclTHENLIST + [apply (delayed_force le_lt_n_Sm); + compute_le_proofs le_proofs']])]) + functional termine f p heq1 new_pmax + (p'::bounds)((mkVar pmax)::le_proofs) eqs + (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args] + + +let rec_leaf_eq termine f ids functional eqs expr fn args = + let p = next_ident_away_in_goal p_id ids in + let ids = p::ids in + let v = next_ident_away_in_goal v_id ids in + let ids = v::ids in + let hex = next_ident_away_in_goal hex_id ids in + let ids = hex::ids in + let heq1 = next_ident_away_in_goal heq_id ids in + let ids = heq1::ids in + let hle1 = next_ident_away_in_goal hle_id ids in + let ids = hle1::ids in + tclTHENLIST + [observe_tac "intros v hex" (h_intros [v;hex]); + simplest_elim (mkVar hex); + h_intros [p;heq1]; + h_generalize [mkApp(delayed_force le_n,[|mkVar p|])]; + h_intros [hle1]; + observe_tac "introduce_all_values_eq" (introduce_all_values_eq + (fun _ _ -> tclIDTAC) + functional termine f p heq1 p [] [] eqs ids args); + observe_tac "failing here" (apply (delayed_force refl_equal))] + +let rec prove_eq (termine:constr) (f:constr)(functional:global_reference) + (eqs:constr list) (expr:constr) = +(* tclTRY *) + observe_tac "prove_eq" (match kind_of_term expr with + Case(ci,t,a,l) -> + (match find_call_occs 0 f a with + _,[] -> + (fun g -> + let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in + tclTHENS + destruct_tac + (list_map_i + (fun i -> mk_intros_and_continue + (List.rev rev_to_thin_intro) true + (prove_eq termine f functional) + eqs ci.ci_cstr_nargs.(i)) + 0 (Array.to_list l)) g) + | _,_::_ -> + (match find_call_occs 0 f expr with + _,[] -> observe_tac "base_leaf_eq(1)" (base_leaf_eq functional eqs f) + | fn,args -> + fun g -> + let ids = ids_of_named_context (pf_hyps g) in + observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids + (constr_of_global functional) + eqs expr fn args) g)) + | _ -> + (match find_call_occs 0 f expr with + _,[] -> observe_tac "base_leaf_eq(2)" ( base_leaf_eq functional eqs f) + | fn,args -> + fun g -> + let ids = ids_of_named_context (pf_hyps g) in + observe_tac "rec_leaf_eq" (rec_leaf_eq + termine f ids (constr_of_global functional) + eqs expr fn args) g));; + +let (com_eqn : identifier -> + global_reference -> global_reference -> global_reference + -> constr -> unit) = + fun eq_name functional_ref f_ref terminate_ref equation_lemma_type -> + let opacity = + match terminate_ref with + | ConstRef c -> + let cb = Global.lookup_constant c in + if cb.Declarations.const_opaque then true + else begin match cb.const_body with None -> true | _ -> false end + | _ -> anomaly "terminate_lemma: not a constant" + in + let (evmap, env) = Lemmas.get_current_context() in + let f_constr = (constr_of_global f_ref) in + let equation_lemma_type = subst1 f_constr equation_lemma_type in + (start_proof eq_name (Global, Proof Lemma) + (Environ.named_context_val env) equation_lemma_type (fun _ _ -> ()); + by + (start_equation f_ref terminate_ref + (fun x -> + prove_eq + (constr_of_global terminate_ref) + f_constr + functional_ref + [] + (instantiate_lambda + (def_of_const (constr_of_global functional_ref)) + (f_constr::List.map mkVar x) + ) + ) + ); +(* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) +(* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) + Flags.silently (fun () -> Lemmas.save_named opacity) () ; +(* Pp.msgnl (str "eqn finished"); *) + + );; + +let nf_zeta env = + Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + env + Evd.empty + +let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) + let clos_norm_flags flgs env sigma t = + Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in + clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty + + +let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq + generate_induction_principle using_lemmas : unit = + let function_type = interp_constr Evd.empty (Global.env()) type_of_f in + let env = push_named (function_name,None,function_type) (Global.env()) in +(* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) + let equation_lemma_type = + nf_betaiotazeta + (interp_gen (OfType None) Evd.empty env ~impls:rec_impls eq) + in +(* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) + let res_vars,eq' = decompose_prod equation_lemma_type in + let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in + let eq' = nf_zeta env_eq' eq' in + let res = +(* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) +(* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) +(* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) + match kind_of_term eq' with + | App(e,[|_;_;eq_fix|]) -> + mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars eq_fix)) + | _ -> failwith "Recursive Definition (res not eq)" + in + let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in + let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in + let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in + let equation_id = add_suffix function_name "_equation" in + let functional_id = add_suffix function_name "_F" in + let term_id = add_suffix function_name "_terminate" in + let functional_ref = declare_fun functional_id (IsDefinition Definition) res in + let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in + let relation = + interp_constr + Evd.empty + env_with_pre_rec_args + r + in + let tcc_lemma_name = add_suffix function_name "_tcc" in + let tcc_lemma_constr = ref None in + (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) + let hook _ _ = + let term_ref = Nametab.locate (qualid_of_ident term_id) in + let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in +(* message "start second proof"; *) + let stop = ref false in + begin + try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) + with e -> + begin + if Tacinterp.get_debug () <> Tactic_debug.DebugOff + then pperrnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e) + else anomaly "Cannot create equation Lemma" + ; +(* ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); *) + stop := true; + end + end; + if not !stop + then + let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in + let f_ref = destConst (constr_of_global f_ref) + and functional_ref = destConst (constr_of_global functional_ref) + and eq_ref = destConst (constr_of_global eq_ref) in + generate_induction_principle f_ref tcc_lemma_constr + functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; + if Flags.is_verbose () + then msgnl (h 1 (Ppconstr.pr_id function_name ++ + spc () ++ str"is defined" )++ fnl () ++ + h 1 (Ppconstr.pr_id equation_id ++ + spc () ++ str"is defined" ) + ) + in + try + com_terminate + tcc_lemma_name + tcc_lemma_constr + is_mes functional_ref + rec_arg_type + relation rec_arg_num + term_id + using_lemmas + (List.length res_vars) + hook + with e -> + begin + ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); +(* anomaly "Cannot create termination Lemma" *) + raise e + end + + + diff --git a/plugins/funind/recdef_plugin.mllib b/plugins/funind/recdef_plugin.mllib new file mode 100644 index 00000000..31818c39 --- /dev/null +++ b/plugins/funind/recdef_plugin.mllib @@ -0,0 +1,11 @@ +Indfun_common +Rawtermops +Recdef +Rawterm_to_relation +Functional_principles_proofs +Functional_principles_types +Invfun +Indfun +Merge +G_indfun +Recdef_plugin_mod diff --git a/plugins/funind/vo.itarget b/plugins/funind/vo.itarget new file mode 100644 index 00000000..33c96830 --- /dev/null +++ b/plugins/funind/vo.itarget @@ -0,0 +1 @@ +Recdef.vo diff --git a/plugins/micromega/CheckerMaker.v b/plugins/micromega/CheckerMaker.v new file mode 100644 index 00000000..93b4d213 --- /dev/null +++ b/plugins/micromega/CheckerMaker.v @@ -0,0 +1,129 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Formula -> Prop. + +Variable Formula' : Type. + +Variable eval' : Env -> Formula' -> Prop. + +Variable normalise : Formula -> Formula'. + +Variable negate : Formula -> Formula'. + +Hypothesis normalise_sound : + forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t). + +Hypothesis negate_correct : + forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)). + +Variable Witness : Type. + +Variable check_formulas' : list Formula' -> Witness -> bool. + +Hypothesis check_formulas'_sound : + forall (l : list Formula') (w : Witness), + check_formulas' l w = true -> + forall env : Env, make_impl (eval' env) l False. + +Definition normalise_list : list Formula -> list Formula' := map normalise. +Definition negate_list : list Formula -> list Formula' := map negate. + +Definition check_formulas (l : list Formula) (w : Witness) : bool := + check_formulas' (map normalise l) w. + +(* Contraposition of normalise_sound for lists *) +Lemma normalise_sound_contr : forall (env : Env) (l : list Formula), + make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False. +Proof. +intros env l; induction l as [| t l IH]; simpl in *. +trivial. +intros H1 H2. apply IH. apply H1. now apply normalise_sound. +Qed. + +Theorem check_formulas_sound : + forall (l : list Formula) (w : Witness), + check_formulas l w = true -> forall env : Env, make_impl (eval env) l False. +Proof. +unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *. +pose proof (check_formulas'_sound H env) as H1; now simpl in H1. +intro H1. apply normalise_sound in H1. +pose proof (check_formulas'_sound H env) as H2; simpl in H2. +apply H2 in H1. now apply normalise_sound_contr. +Qed. + +(* In check_conj_formulas', t2 is supposed to be a list of negations of +formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then +check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is +inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that +A1 /\ A2 -> B1 /\ B2. *) + +Fixpoint check_conj_formulas' + (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool := +match t2 with +| nil => true +| t':: rt2 => + match wits with + | nil => false + | w :: rwits => + match check_formulas' (t':: t1) w with + | true => check_conj_formulas' t1 rwits rt2 + | false => false + end + end +end. + +(* checks whether the conjunction of t1 implies the conjunction of t2 *) + +Definition check_conj_formulas + (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool := + check_conj_formulas' (normalise_list t1) wits (negate_list t2). + +Theorem check_conj_formulas_sound : + forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness), + check_conj_formulas t1 wits t2 = true -> + forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2). +Proof. +intro t1; induction t2 as [| a2 t2' IH]. +intros; apply make_impl_true. +intros wits H env. +unfold check_conj_formulas in H; simpl in H. +destruct wits as [| w ws]; simpl in H. discriminate. +case_eq (check_formulas' (negate a2 :: normalise_list t1) w); +intro H1; rewrite H1 in H; [| discriminate]. +assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by +now apply check_formulas'_sound with (w := w). clear H1. +pose proof (IH ws H env) as H1. simpl in H2. +assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False) +by auto using normalise_sound_contr. clear H2. +rewrite <- make_conj_impl in *. +rewrite make_conj_cons. intro H2. split. +apply <- negate_correct. intro; now elim H3. exact (H1 H2). +Qed. + +End CheckerMaker. diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v new file mode 100644 index 00000000..231004bc --- /dev/null +++ b/plugins/micromega/Env.v @@ -0,0 +1,182 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* D. + + Definition jump (j:positive) (e:Env) := fun x => e (Pplus x j). + + Definition nth (n:positive) (e : Env ) := e n. + + Definition hd (x:D) (e: Env) := nth xH e. + + Definition tail (e: Env) := jump xH e. + + Lemma psucc : forall p, (match p with + | xI y' => xO (Psucc y') + | xO y' => xI y' + | 1%positive => 2%positive + end) = (p+1)%positive. + Proof. + destruct p. + auto with zarith. + rewrite xI_succ_xO. + auto with zarith. + reflexivity. + Qed. + + Lemma jump_Pplus : forall i j l, + forall x, jump (i + j) l x = jump i (jump j l) x. + Proof. + unfold jump. + intros. + rewrite Pplus_assoc. + reflexivity. + Qed. + + Lemma jump_simpl : forall p l, + forall x, jump p l x = + match p with + | xH => tail l x + | xO p => jump p (jump p l) x + | xI p => jump p (jump p (tail l)) x + end. + Proof. + destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus. + (* xI p = p + p + 1 *) + rewrite xI_succ_xO. + rewrite Pplus_diag. + rewrite <- Pplus_one_succ_r. + reflexivity. + (* xO p = p + p *) + rewrite Pplus_diag. + reflexivity. + reflexivity. + Qed. + + Ltac jump_s := + repeat + match goal with + | |- context [jump xH ?e] => rewrite (jump_simpl xH) + | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p)) + | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p)) + end. + + Lemma jump_tl : forall j l, forall x, tail (jump j l) x = jump j (tail l) x. + Proof. + unfold tail. + intros. + repeat rewrite <- jump_Pplus. + rewrite Pplus_comm. + reflexivity. + Qed. + + Lemma jump_Psucc : forall j l, + forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x). + Proof. + intros. + rewrite <- jump_Pplus. + rewrite Pplus_one_succ_r. + rewrite Pplus_comm. + reflexivity. + Qed. + + Lemma jump_Pdouble_minus_one : forall i l, + forall x, (jump (Pdouble_minus_one i) (tail l)) x = (jump i (jump i l)) x. + Proof. + unfold tail. + intros. + repeat rewrite <- jump_Pplus. + rewrite <- Pplus_one_succ_r. + rewrite Psucc_o_double_minus_one_eq_xO. + rewrite Pplus_diag. + reflexivity. + Qed. + + Lemma jump_x0_tail : forall p l, forall x, jump (xO p) (tail l) x = jump (xI p) l x. + Proof. + intros. + unfold jump. + unfold tail. + unfold jump. + rewrite <- Pplus_assoc. + simpl. + reflexivity. + Qed. + + Lemma nth_spec : forall p l x, + nth p l = + match p with + | xH => hd x l + | xO p => nth p (jump p l) + | xI p => nth p (jump p (tail l)) + end. + Proof. + unfold nth. + destruct p. + intros. + unfold jump, tail. + unfold jump. + rewrite Pplus_diag. + rewrite xI_succ_xO. + simpl. + reflexivity. + unfold jump. + rewrite Pplus_diag. + reflexivity. + unfold hd. + unfold nth. + reflexivity. + Qed. + + + Lemma nth_jump : forall p l x, nth p (tail l) = hd x (jump p l). + Proof. + unfold tail. + unfold hd. + unfold jump. + unfold nth. + intros. + rewrite Pplus_comm. + reflexivity. + Qed. + + Lemma nth_Pdouble_minus_one : + forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). + Proof. + intros. + unfold tail. + unfold nth, jump. + rewrite Pplus_diag. + rewrite <- Psucc_o_double_minus_one_eq_xO. + rewrite Pplus_one_succ_r. + reflexivity. + Qed. + +End S. + diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v new file mode 100644 index 00000000..e58f8e68 --- /dev/null +++ b/plugins/micromega/EnvRing.v @@ -0,0 +1,1403 @@ +(************************************************************************) +(* V * The Coq Proof Assistant / The Coq Development Team *) +(* R->R) (ropp : R->R). + Variable req : R -> R -> Prop. + + (* Ring properties *) + Variable Rsth : Setoid_Theory R req. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. + + (* Coefficients *) + Variable C: Type. + Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). + Variable ceqb : C->C->bool. + Variable phi : C -> R. + Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req + cO cI cadd cmul csub copp ceqb phi. + + (* Power coefficients *) + Variable Cpow : Set. + Variable Cp_phi : N -> Cpow. + Variable rpow : R -> Cpow -> R. + Variable pow_th : power_theory rI rmul req Cp_phi rpow. + + + (* R notations *) + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). + Notation "x == y" := (req x y). + + (* C notations *) + Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). + Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). + Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). + + (* Usefull tactics *) + Add Setoid R req Rsth as R_set1. + Ltac rrefl := gen_reflexivity Rsth. + Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. + Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac rsimpl := gen_srewrite Rsth Reqe ARth. + Ltac add_push := gen_add_push radd Rsth Reqe ARth. + Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. + + (* Definition of multivariable polynomials with coefficients in C : + Type [Pol] represents [X1 ... Xn]. + The representation is Horner's where a [n] variable polynomial + (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients + are polynomials with [n-1] variables (C[X2..Xn]). + There are several optimisations to make the repr compacter: + - [Pc c] is the constant polynomial of value c + == c*X1^0*..*Xn^0 + - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. + variable indices are shifted of j in Q. + == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} + - [PX P i Q] is an optimised Horner form of P*X^i + Q + with P not the null polynomial + == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} + + In addition: + - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden + since they can be represented by the simpler form (PX P (i+j) Q) + - (Pinj i (Pinj j P)) is (Pinj (i+j) P) + - (Pinj i (Pc c)) is (Pc c) + *) + + Inductive Pol : Type := + | Pc : C -> Pol + | Pinj : positive -> Pol -> Pol + | PX : Pol -> positive -> Pol -> Pol. + + Definition P0 := Pc cO. + Definition P1 := Pc cI. + + Fixpoint Peq (P P' : Pol) {struct P'} : bool := + match P, P' with + | Pc c, Pc c' => c ?=! c' + | Pinj j Q, Pinj j' Q' => + match Pcompare j j' Eq with + | Eq => Peq Q Q' + | _ => false + end + | PX P i Q, PX P' i' Q' => + match Pcompare i i' Eq with + | Eq => if Peq P P' then Peq Q Q' else false + | _ => false + end + | _, _ => false + end. + + Notation " P ?== P' " := (Peq P P'). + + Definition mkPinj j P := + match P with + | Pc _ => P + | Pinj j' Q => Pinj ((j + j'):positive) Q + | _ => Pinj j P + end. + + Definition mkPinj_pred j P:= + match j with + | xH => P + | xO j => Pinj (Pdouble_minus_one j) P + | xI j => Pinj (xO j) P + end. + + Definition mkPX P i Q := + match P with + | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q + | Pinj _ _ => PX P i Q + | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q + end. + + Definition mkXi i := PX P1 i P0. + + Definition mkX := mkXi 1. + + (** Opposite of addition *) + + Fixpoint Popp (P:Pol) : Pol := + match P with + | Pc c => Pc (-! c) + | Pinj j Q => Pinj j (Popp Q) + | PX P i Q => PX (Popp P) i (Popp Q) + end. + + Notation "-- P" := (Popp P). + + (** Addition et subtraction *) + + Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol := + match P with + | Pc c1 => Pc (c1 +! c) + | Pinj j Q => Pinj j (PaddC Q c) + | PX P i Q => PX P i (PaddC Q c) + end. + + Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol := + match P with + | Pc c1 => Pc (c1 -! c) + | Pinj j Q => Pinj j (PsubC Q c) + | PX P i Q => PX P i (PsubC Q c) + end. + + Section PopI. + + Variable Pop : Pol -> Pol -> Pol. + Variable Q : Pol. + + Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol := + match P with + | Pc c => mkPinj j (PaddC Q c) + | Pinj j' Q' => + match ZPminus j' j with + | Zpos k => mkPinj j (Pop (Pinj k Q') Q) + | Z0 => mkPinj j (Pop Q' Q) + | Zneg k => mkPinj j' (PaddI k Q') + end + | PX P i Q' => + match j with + | xH => PX P i (Pop Q' Q) + | xO j => PX P i (PaddI (Pdouble_minus_one j) Q') + | xI j => PX P i (PaddI (xO j) Q') + end + end. + + Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol := + match P with + | Pc c => mkPinj j (PaddC (--Q) c) + | Pinj j' Q' => + match ZPminus j' j with + | Zpos k => mkPinj j (Pop (Pinj k Q') Q) + | Z0 => mkPinj j (Pop Q' Q) + | Zneg k => mkPinj j' (PsubI k Q') + end + | PX P i Q' => + match j with + | xH => PX P i (Pop Q' Q) + | xO j => PX P i (PsubI (Pdouble_minus_one j) Q') + | xI j => PX P i (PsubI (xO j) Q') + end + end. + + Variable P' : Pol. + + Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol := + match P with + | Pc c => PX P' i' P + | Pinj j Q' => + match j with + | xH => PX P' i' Q' + | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q') + | xI j => PX P' i' (Pinj (xO j) Q') + end + | PX P i Q' => + match ZPminus i i' with + | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' + | Z0 => mkPX (Pop P P') i Q' + | Zneg k => mkPX (PaddX k P) i Q' + end + end. + + Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol := + match P with + | Pc c => PX (--P') i' P + | Pinj j Q' => + match j with + | xH => PX (--P') i' Q' + | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q') + | xI j => PX (--P') i' (Pinj (xO j) Q') + end + | PX P i Q' => + match ZPminus i i' with + | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' + | Z0 => mkPX (Pop P P') i Q' + | Zneg k => mkPX (PsubX k P) i Q' + end + end. + + + End PopI. + + Fixpoint Padd (P P': Pol) {struct P'} : Pol := + match P' with + | Pc c' => PaddC P c' + | Pinj j' Q' => PaddI Padd Q' j' P + | PX P' i' Q' => + match P with + | Pc c => PX P' i' (PaddC Q' c) + | Pinj j Q => + match j with + | xH => PX P' i' (Padd Q Q') + | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q') + | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') + end + | PX P i Q => + match ZPminus i i' with + | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') + | Z0 => mkPX (Padd P P') i (Padd Q Q') + | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') + end + end + end. + Notation "P ++ P'" := (Padd P P'). + + Fixpoint Psub (P P': Pol) {struct P'} : Pol := + match P' with + | Pc c' => PsubC P c' + | Pinj j' Q' => PsubI Psub Q' j' P + | PX P' i' Q' => + match P with + | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) + | Pinj j Q => + match j with + | xH => PX (--P') i' (Psub Q Q') + | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q') + | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') + end + | PX P i Q => + match ZPminus i i' with + | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') + | Z0 => mkPX (Psub P P') i (Psub Q Q') + | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') + end + end + end. + Notation "P -- P'" := (Psub P P'). + + (** Multiplication *) + + Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := + match P with + | Pc c' => Pc (c' *! c) + | Pinj j Q => mkPinj j (PmulC_aux Q c) + | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) + end. + + Definition PmulC P c := + if c ?=! cO then P0 else + if c ?=! cI then P else PmulC_aux P c. + + Section PmulI. + Variable Pmul : Pol -> Pol -> Pol. + Variable Q : Pol. + Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol := + match P with + | Pc c => mkPinj j (PmulC Q c) + | Pinj j' Q' => + match ZPminus j' j with + | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) + | Z0 => mkPinj j (Pmul Q' Q) + | Zneg k => mkPinj j' (PmulI k Q') + end + | PX P' i' Q' => + match j with + | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) + | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q') + | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') + end + end. + + End PmulI. +(* A symmetric version of the multiplication *) + + Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := + match P'' with + | Pc c => PmulC P c + | Pinj j' Q' => PmulI Pmul Q' j' P + | PX P' i' Q' => + match P with + | Pc c => PmulC P'' c + | Pinj j Q => + let QQ' := + match j with + | xH => Pmul Q Q' + | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q' + | xI j => Pmul (Pinj (xO j) Q) Q' + end in + mkPX (Pmul P P') i' QQ' + | PX P i Q=> + let QQ' := Pmul Q Q' in + let PQ' := PmulI Pmul Q' xH P in + let QP' := Pmul (mkPinj xH Q) P' in + let PP' := Pmul P P' in + (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' + end + end. + +(* Non symmetric *) +(* + Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol := + match P' with + | Pc c' => PmulC P c' + | Pinj j' Q' => PmulI Pmul_aux Q' j' P + | PX P' i' Q' => + (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P) + end. + + Definition Pmul P P' := + match P with + | Pc c => PmulC P' c + | Pinj j Q => PmulI Pmul_aux Q j P' + | PX P i Q => + (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P') + end. +*) + Notation "P ** P'" := (Pmul P P'). + + Fixpoint Psquare (P:Pol) : Pol := + match P with + | Pc c => Pc (c *! c) + | Pinj j Q => Pinj j (Psquare Q) + | PX P i Q => + let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in + let Q2 := Psquare Q in + let P2 := Psquare P in + mkPX (mkPX P2 i P0 ++ twoPQ) i Q2 + end. + + (** Monomial **) + + Inductive Mon: Set := + mon0: Mon + | zmon: positive -> Mon -> Mon + | vmon: positive -> Mon -> Mon. + + Fixpoint Mphi(l:Env R) (M: Mon) {struct M} : R := + match M with + mon0 => rI + | zmon j M1 => Mphi (jump j l) M1 + | vmon i M1 => + let x := hd 0 l in + let xi := pow_pos rmul x i in + (Mphi (tail l) M1) * xi + end. + + Definition mkZmon j M := + match M with mon0 => mon0 | _ => zmon j M end. + + Definition zmon_pred j M := + match j with xH => M | _ => mkZmon (Ppred j) M end. + + Definition mkVmon i M := + match M with + | mon0 => vmon i mon0 + | zmon j m => vmon i (zmon_pred j m) + | vmon i' m => vmon (i+i') m + end. + + Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol := + match P, M with + _, mon0 => (Pc cO, P) + | Pc _, _ => (P, Pc cO) + | Pinj j1 P1, zmon j2 M1 => + match (j1 ?= j2) Eq with + Eq => let (R,S) := MFactor P1 M1 in + (mkPinj j1 R, mkPinj j1 S) + | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in + (mkPinj j1 R, mkPinj j1 S) + | Gt => (P, Pc cO) + end + | Pinj _ _, vmon _ _ => (P, Pc cO) + | PX P1 i Q1, zmon j M1 => + let M2 := zmon_pred j M1 in + let (R1, S1) := MFactor P1 M in + let (R2, S2) := MFactor Q1 M2 in + (mkPX R1 i R2, mkPX S1 i S2) + | PX P1 i Q1, vmon j M1 => + match (i ?= j) Eq with + Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in + (mkPX R1 i Q1, S1) + | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in + (mkPX R1 i Q1, S1) + | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in + (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) + end + end. + + Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol := + let (Q1,R1) := MFactor P1 M1 in + match R1 with + (Pc c) => if c ?=! cO then None + else Some (Padd Q1 (Pmul P2 R1)) + | _ => Some (Padd Q1 (Pmul P2 R1)) + end. + + Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol := + match POneSubst P1 M1 P2 with + Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end + | _ => P1 + end. + + Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol := + match POneSubst P1 M1 P2 with + Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end + | _ => None + end. + + Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: + Pol := + match LM1 with + cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n + | _ => P1 + end. + + Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol := + match LM1 with + cons (M1,P2) LM2 => + match PNSubst P1 M1 P2 n with + Some P3 => Some (PSubstL1 P3 LM2 n) + | None => PSubstL P1 LM2 n + end + | _ => None + end. + + Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol := + match PSubstL P1 LM1 n with + Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end + | _ => P1 + end. + + (** Evaluation of a polynomial towards R *) + + Fixpoint Pphi(l:Env R) (P:Pol) {struct P} : R := + match P with + | Pc c => [c] + | Pinj j Q => Pphi (jump j l) Q + | PX P i Q => + let x := hd 0 l in + let xi := pow_pos rmul x i in + (Pphi l P) * xi + (Pphi (tail l) Q) + end. + + Reserved Notation "P @ l " (at level 10, no associativity). + Notation "P @ l " := (Pphi l P). + (** Proofs *) + Lemma ZPminus_spec : forall x y, + match ZPminus x y with + | Z0 => x = y + | Zpos k => x = (y + k)%positive + | Zneg k => y = (x + k)%positive + end. + Proof. + induction x;destruct y. + replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial. + assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. + replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial. + assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial. + apply Pplus_xI_double_minus_one. + simpl;trivial. + replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial. + assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial. + apply Pplus_xI_double_minus_one. + replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial. + assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. + replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO;trivial. + replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial. + replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO;trivial. + simpl;trivial. + Qed. + + Lemma Peq_ok : forall P P', + (P ?== P') = true -> forall l, P@l == P'@ l. + Proof. + induction P;destruct P';simpl;intros;try discriminate;trivial. + apply (morph_eq CRmorph);trivial. + assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); + try discriminate H. + rewrite (IHP P' H); rewrite H1;trivial;rrefl. + assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); + try discriminate H. + rewrite H1;trivial. clear H1. + assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2); + destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H] + |discriminate H]. + rewrite (H1 H);rewrite (H2 H);rrefl. + Qed. + + Lemma Pphi0 : forall l, P0@l == 0. + Proof. + intros;simpl;apply (morph0 CRmorph). + Qed. + +Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) -> + p @ e1 = p @ e2. +Proof. + induction p ; simpl. + reflexivity. + intros. + apply IHp. + intros. + unfold jump. + apply H. + intros. + rewrite (IHp1 e1 e2) ; auto. + rewrite (IHp2 (tail e1) (tail e2)) ; auto. + unfold hd. unfold nth. rewrite H. reflexivity. + unfold tail. unfold jump. intros ; apply H. +Qed. + +Lemma Pjump_Pplus : forall P i j l, P @ (jump (i + j) l ) = P @ (jump j (jump i l)). +Proof. + intros. apply env_morph. intros. rewrite <- jump_Pplus. + rewrite Pplus_comm. + reflexivity. +Qed. + +Lemma Pjump_xO_tail : forall P p l, + P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l). +Proof. + intros. + apply env_morph. + intros. + rewrite (@jump_simpl R (xI p)). + rewrite (@jump_simpl R (xO p)). + reflexivity. +Qed. + +Lemma Pjump_Pdouble_minus_one : forall P p l, + P @ (jump (Pdouble_minus_one p) (tail l)) = P @ (jump (xO p) l). +Proof. + intros. + apply env_morph. + intros. + rewrite jump_Pdouble_minus_one. + rewrite (@jump_simpl R (xO p)). + reflexivity. +Qed. + + + + Lemma Pphi1 : forall l, P1@l == 1. + Proof. + intros;simpl;apply (morph1 CRmorph). + Qed. + + Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l). + Proof. + intros j l p;destruct p;simpl;rsimpl. + rewrite Pjump_Pplus. + reflexivity. + Qed. + + Let pow_pos_Pplus := + pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc). + + Lemma mkPX_ok : forall l P i Q, + (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l). + Proof. + intros l P i Q;unfold mkPX. + destruct P;try (simpl;rrefl). + assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl. + rewrite (H (refl_equal true));rewrite (morph0 CRmorph). + rewrite mkPinj_ok;rsimpl;simpl;rrefl. + assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl. + rewrite (H (refl_equal true));trivial. + rewrite Pphi0. rewrite pow_pos_Pplus;rsimpl. + Qed. + + + Ltac Esimpl := + repeat (progress ( + match goal with + | |- context [P0@?l] => rewrite (Pphi0 l) + | |- context [P1@?l] => rewrite (Pphi1 l) + | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P) + | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q) + | |- context [[cO]] => rewrite (morph0 CRmorph) + | |- context [[cI]] => rewrite (morph1 CRmorph) + | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y) + | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y) + | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y) + | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x) + end)); + rsimpl; simpl. + + Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c]. + Proof. + induction P;simpl;intros;Esimpl;trivial. + rewrite IHP2;rsimpl. + Qed. + + Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c]. + Proof. + induction P;simpl;intros. + Esimpl. + rewrite IHP;rsimpl. + rewrite IHP2;rsimpl. + Qed. + + Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. + Proof. + induction P;simpl;intros;Esimpl;trivial. + rewrite IHP1;rewrite IHP2;rsimpl. + mul_push ([c]);rrefl. + Qed. + + Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. + Proof. + intros c P l; unfold PmulC. + assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO). + rewrite (H (refl_equal true));Esimpl. + assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). + rewrite (H1 (refl_equal true));Esimpl. + apply PmulC_aux_ok. + Qed. + + Lemma Popp_ok : forall P l, (--P)@l == - P@l. + Proof. + induction P;simpl;intros. + Esimpl. + apply IHP. + rewrite IHP1;rewrite IHP2;rsimpl. + Qed. + + Ltac Esimpl2 := + Esimpl; + repeat (progress ( + match goal with + | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l) + | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l) + | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) + | |- context [(--?P)@?l] => rewrite (Popp_ok P l) + end)); Esimpl. + + + + + Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l. + Proof. + induction P';simpl;intros;Esimpl2. + generalize P p l;clear P p l. + induction P;simpl;intros. + Esimpl2;apply (ARadd_comm ARth). + assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). + rewrite H;Esimpl. rewrite IHP';rrefl. + rewrite H;Esimpl. rewrite IHP';Esimpl. + rewrite Pjump_Pplus. rrefl. + rewrite H;Esimpl. rewrite IHP. + rewrite Pjump_Pplus. rrefl. + destruct p0;simpl. + rewrite IHP2;simpl. rsimpl. + rewrite Pjump_xO_tail. Esimpl. + rewrite IHP2;simpl. + rewrite Pjump_Pdouble_minus_one. + rsimpl. + rewrite IHP'. + rsimpl. + destruct P;simpl. + Esimpl2;add_push [c];rrefl. + destruct p0;simpl;Esimpl2. + rewrite IHP'2;simpl. + rewrite Pjump_xO_tail. + rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. + rewrite IHP'2;simpl. + rewrite Pjump_Pdouble_minus_one. rsimpl. + add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. + rewrite IHP'2;rsimpl. + unfold tail. + add_push (P @ (jump 1 l));rrefl. + assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. + rewrite IHP'1;rewrite IHP'2;rsimpl. + add_push (P3 @ (tail l));rewrite H;rrefl. + rewrite IHP'1;rewrite IHP'2;simpl;Esimpl. + rewrite H;rewrite Pplus_comm. + rewrite pow_pos_Pplus;rsimpl. + add_push (P3 @ (tail l));rrefl. + assert (forall P k l, + (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k). + induction P;simpl;intros;try apply (ARadd_comm ARth). + destruct p2; simpl; try apply (ARadd_comm ARth). + rewrite Pjump_xO_tail. + apply (ARadd_comm ARth). + rewrite Pjump_Pdouble_minus_one. + apply (ARadd_comm ARth). + assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2. + rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl. + rewrite IHP'1;simpl;Esimpl. + rewrite H1;rewrite Pplus_comm. + rewrite pow_pos_Pplus;simpl;Esimpl. + add_push (P5 @ (tail l0));rrefl. + rewrite IHP1;rewrite H1;rewrite Pplus_comm. + rewrite pow_pos_Pplus;simpl;rsimpl. + add_push (P5 @ (tail l0));rrefl. + rewrite H0;rsimpl. + add_push (P3 @ (tail l)). + rewrite H;rewrite Pplus_comm. + rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl. + add_push (P3 @ (tail l));rrefl. + Qed. + + Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. + Proof. + induction P';simpl;intros;Esimpl2;trivial. + generalize P p l;clear P p l. + induction P;simpl;intros. + Esimpl2;apply (ARadd_comm ARth). + assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). + rewrite H;Esimpl. rewrite IHP';rsimpl. + rewrite H;Esimpl. rewrite IHP';Esimpl. + rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl. + rewrite H;Esimpl. rewrite IHP. + rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl. + destruct p0;simpl. + rewrite IHP2;simpl; try rewrite Pjump_xO_tail ; rsimpl. + rewrite IHP2;simpl. + rewrite Pjump_Pdouble_minus_one;rsimpl. + unfold tail ; rsimpl. + rewrite IHP';rsimpl. + destruct P;simpl. + repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl. + destruct p0;simpl;Esimpl2. + rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial. + rewrite Pjump_xO_tail. + add_push (P @ ((jump (xI p0) l)));rrefl. + rewrite IHP'2;simpl;rewrite Pjump_Pdouble_minus_one;rsimpl. + add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl. + unfold tail. + rewrite IHP'2;rsimpl;add_push (P @ (jump 1 l));rrefl. + assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. + rewrite IHP'1; rewrite IHP'2;rsimpl. + add_push (P3 @ (tail l));rewrite H;rrefl. + rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl. + rewrite H;rewrite Pplus_comm. + rewrite pow_pos_Pplus;rsimpl. + add_push (P3 @ (tail l));rrefl. + assert (forall P k l, + (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k). + induction P;simpl;intros. + rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial. + destruct p2;simpl; rewrite Popp_ok;rsimpl. + rewrite Pjump_xO_tail. + apply (ARadd_comm ARth);trivial. + rewrite Pjump_Pdouble_minus_one. + apply (ARadd_comm ARth);trivial. + apply (ARadd_comm ARth);trivial. + assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl. + rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl. + rewrite IHP'1;rewrite H1;rewrite Pplus_comm. + rewrite pow_pos_Pplus;simpl;Esimpl. + add_push (P5 @ (tail l0));rrefl. + rewrite IHP1;rewrite H1;rewrite Pplus_comm. + rewrite pow_pos_Pplus;simpl;rsimpl. + add_push (P5 @ (tail l0));rrefl. + rewrite H0;rsimpl. + rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)). + rewrite H;rewrite Pplus_comm. + rewrite pow_pos_Pplus;rsimpl. + Qed. +(* Proof for the symmetric version *) + + Lemma PmulI_ok : + forall P', + (forall (P : Pol) (l : Env R), (Pmul P P') @ l == P @ l * P' @ l) -> + forall (P : Pol) (p : positive) (l : Env R), + (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). + Proof. + induction P;simpl;intros. + Esimpl2;apply (ARmul_comm ARth). + assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. + rewrite H1; rewrite H;rrefl. + rewrite H1; rewrite H. + rewrite Pjump_Pplus;simpl;rrefl. + rewrite H1. + rewrite Pjump_Pplus;rewrite IHP;rrefl. + destruct p0;Esimpl2. + rewrite IHP1;rewrite IHP2;rsimpl. + rewrite Pjump_xO_tail. + mul_push (pow_pos rmul (hd 0 l) p);rrefl. + rewrite IHP1;rewrite IHP2;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p); rewrite Pjump_Pdouble_minus_one. + rrefl. + rewrite IHP1;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p). + rewrite H;rrefl. + Qed. + +(* + Lemma PmulI_ok : + forall P', + (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) -> + forall (P : Pol) (p : positive) (l : list R), + (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l). + Proof. + induction P;simpl;intros. + Esimpl2;apply (ARmul_comm ARth). + assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. + rewrite H1; rewrite H;rrefl. + rewrite H1; rewrite H. + rewrite Pplus_comm. + rewrite jump_Pplus;simpl;rrefl. + rewrite H1;rewrite Pplus_comm. + rewrite jump_Pplus;rewrite IHP;rrefl. + destruct p0;Esimpl2. + rewrite IHP1;rewrite IHP2;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p);rrefl. + rewrite IHP1;rewrite IHP2;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. + rewrite IHP1;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p). + rewrite H;rrefl. + Qed. + + Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l. + Proof. + induction P';simpl;intros. + Esimpl2;trivial. + apply PmulI_ok;trivial. + rewrite Padd_ok;Esimpl2. + rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl. + Qed. +*) + +(* Proof for the symmetric version *) + Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. + Proof. + intros P P';generalize P;clear P;induction P';simpl;intros. + apply PmulC_ok. apply PmulI_ok;trivial. + destruct P. + rewrite (ARmul_comm ARth);Esimpl2;Esimpl2. + Esimpl2. rewrite IHP'1;Esimpl2. + assert (match p0 with + | xI j => Pinj (xO j) P ** P'2 + | xO j => Pinj (Pdouble_minus_one j) P ** P'2 + | 1 => P ** P'2 + end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)). + destruct p0;rewrite IHP'2;Esimpl. + rewrite Pjump_xO_tail. reflexivity. + rewrite Pjump_Pdouble_minus_one;Esimpl. + rewrite H;Esimpl. + rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2. + repeat (rewrite IHP'1 || rewrite IHP'2);simpl. + rewrite PmulI_ok;trivial. + unfold tail. + mul_push (P'1@l). simpl. mul_push (P'2 @ (jump 1 l)). Esimpl. + Qed. + +(* +Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. + Proof. + destruct P;simpl;intros. + Esimpl2;apply (ARmul_comm ARth). + rewrite (PmulI_ok P (Pmul_aux_ok P)). + apply (ARmul_comm ARth). + rewrite Padd_ok; Esimpl2. + rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial. + rewrite Pmul_aux_ok;mul_push (P' @ l). + rewrite (ARmul_comm ARth (P' @ l));rrefl. + Qed. +*) + + Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. + Proof. + induction P;simpl;intros;Esimpl2. + apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2. + rewrite IHP1;rewrite IHP2. + mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l). + rrefl. + Qed. + + Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) -> + Mphi env P = Mphi env' P. + Proof. + induction P ; simpl. + reflexivity. + intros. + apply IHP. + intros. + unfold jump. + apply H. + (**) + intros. + replace (Mphi (tail env) P) with (Mphi (tail env') P). + unfold hd. unfold nth. + rewrite H. + reflexivity. + apply IHP. + unfold tail,jump. + intros. symmetry. apply H. + Qed. + +Lemma Mjump_xO_tail : forall M p l, + Mphi (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M. +Proof. + intros. + apply Mphi_morph. + intros. + rewrite (@jump_simpl R (xI p)). + rewrite (@jump_simpl R (xO p)). + reflexivity. +Qed. + +Lemma Mjump_Pdouble_minus_one : forall M p l, + Mphi (jump (Pdouble_minus_one p) (tail l)) M = Mphi (jump (xO p) l) M. +Proof. + intros. + apply Mphi_morph. + intros. + rewrite jump_Pdouble_minus_one. + rewrite (@jump_simpl R (xO p)). + reflexivity. +Qed. + +Lemma Mjump_Pplus : forall M i j l, Mphi (jump (i + j) l ) M = Mphi (jump j (jump i l)) M. +Proof. + intros. apply Mphi_morph. intros. rewrite <- jump_Pplus. + rewrite Pplus_comm. + reflexivity. +Qed. + + + + Lemma mkZmon_ok: forall M j l, + Mphi l (mkZmon j M) == Mphi l (zmon j M). + intros M j l; case M; simpl; intros; rsimpl. + Qed. + + Lemma zmon_pred_ok : forall M j l, + Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M). + Proof. + destruct j; simpl;intros l; rsimpl. + rewrite mkZmon_ok;rsimpl. + simpl. + rewrite Mjump_xO_tail. + reflexivity. + rewrite mkZmon_ok;simpl. + rewrite Mjump_Pdouble_minus_one; rsimpl. + Qed. + + Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i. + Proof. + destruct M;simpl;intros;rsimpl. + rewrite zmon_pred_ok;simpl;rsimpl. + rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl. + Qed. + + + Lemma Mphi_ok: forall P M l, + let (Q,R) := MFactor P M in + P@l == Q@l + (Mphi l M) * (R@l). + Proof. + intros P; elim P; simpl; auto; clear P. + intros c M l; case M; simpl; auto; try intro p; try intro m; + try rewrite (morph0 CRmorph); rsimpl. + + intros i P Hrec M l; case M; simpl; clear M. + rewrite (morph0 CRmorph); rsimpl. + intros j M. + case_eq ((i ?= j) Eq); intros He; simpl. + rewrite (Pcompare_Eq_eq _ _ He). + generalize (Hrec M (jump j l)); case (MFactor P M); + simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. + generalize (Hrec (zmon (j -i) M) (jump i l)); + case (MFactor P (zmon (j -i) M)); simpl. + intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. + rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)). + rewrite Mjump_Pplus; auto. + rewrite (morph0 CRmorph); rsimpl. + intros P2 m; rewrite (morph0 CRmorph); rsimpl. + + intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto. + rewrite (morph0 CRmorph); rsimpl. + intros j M1. + generalize (Hrec1 (zmon j M1) l); + case (MFactor P2 (zmon j M1)). + intros R1 S1 H1. + generalize (Hrec2 (zmon_pred j M1) (tail l)); + case (MFactor Q2 (zmon_pred j M1)); simpl. + intros R2 S2 H2; rewrite H1; rewrite H2. + repeat rewrite mkPX_ok; simpl. + rsimpl. + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + rewrite zmon_pred_ok;rsimpl. + intros j M1. + case_eq ((i ?= j) Eq); intros He; simpl. + rewrite (Pcompare_Eq_eq _ _ He). + generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1)); + simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. + rewrite H; rewrite mkPX_ok; rsimpl. + repeat (rewrite <-(ARadd_assoc ARth)). + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + rewrite mkZmon_ok. + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + generalize (Hrec1 (vmon (j - i) M1) l); + case (MFactor P2 (vmon (j - i) M1)); + simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. + rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto. + rewrite mkPX_ok; rsimpl. + repeat (rewrite <-(ARadd_assoc ARth)). + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + apply rmul_ext; rsimpl. + rewrite <- pow_pos_Pplus. + rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. + generalize (Hrec1 (mkZmon 1 M1) l); + case (MFactor P2 (mkZmon 1 M1)); + simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. + rewrite H; rsimpl. + rewrite mkPX_ok; rsimpl. + repeat (rewrite <-(ARadd_assoc ARth)). + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + rewrite mkZmon_ok. + repeat (rewrite <-(ARmul_assoc ARth)). + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + rewrite mkPX_ok; simpl; rsimpl. + rewrite (morph0 CRmorph); rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + rewrite (ARmul_comm ARth (Q3@l)); rsimpl. + apply rmul_ext; rsimpl. + rewrite <- pow_pos_Pplus. + rewrite (Pplus_minus _ _ He); rsimpl. + Qed. + +(* Proof for the symmetric version *) + + Lemma POneSubst_ok: forall P1 M1 P2 P3 l, + POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. + Proof. + intros P2 M1 P3 P4 l; unfold POneSubst. + generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. + intros Q1 R1; case R1. + intros c H; rewrite H. + generalize (morph_eq CRmorph c cO); + case (c ?=! cO); simpl; auto. + intros H1 H2; rewrite H1; auto; rsimpl. + discriminate. + intros _ H1 H2; injection H1; intros; subst. + rewrite H2; rsimpl. + (* new version *) + rewrite Padd_ok; rewrite PmulC_ok; rsimpl. + intros i P5 H; rewrite H. + intros HH H1; injection HH; intros; subst; rsimpl. + rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. + intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. + assert (P4 = Q1 ++ P3 ** PX i P5 P6). + injection H2; intros; subst;trivial. + rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl. +Qed. +(* + Lemma POneSubst_ok: forall P1 M1 P2 P3 l, + POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. +Proof. + intros P2 M1 P3 P4 l; unfold POneSubst. + generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. + intros Q1 R1; case R1. + intros c H; rewrite H. + generalize (morph_eq CRmorph c cO); + case (c ?=! cO); simpl; auto. + intros H1 H2; rewrite H1; auto; rsimpl. + discriminate. + intros _ H1 H2; injection H1; intros; subst. + rewrite H2; rsimpl. + rewrite Padd_ok; rewrite Pmul_ok; rsimpl. + intros i P5 H; rewrite H. + intros HH H1; injection HH; intros; subst; rsimpl. + rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl. + intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. + injection H2; intros; subst; rsimpl. + rewrite Padd_ok. + rewrite Pmul_ok; rsimpl. + Qed. +*) + Lemma PNSubst1_ok: forall n P1 M1 P2 l, + Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. + Proof. + intros n; elim n; simpl; auto. + intros P2 M1 P3 l H. + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. + intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl. + intros n1 Hrec P2 M1 P3 l H. + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. + intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl. + Qed. + + Lemma PNSubst_ok: forall n P1 M1 P2 l P3, + PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. + Proof. + intros n P2 M1 P3 l P4; unfold PNSubst. + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + case (POneSubst P2 M1 P3); [idtac | intros; discriminate]. + intros P5 H1; case n; try (intros; discriminate). + intros n1 H2; injection H2; intros; subst. + rewrite <- PNSubst1_ok; auto. + Qed. + + Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) {struct LM1} : Prop := + match LM1 with + cons (M1,P2) LM2 => (Mphi l M1 == P2@l) /\ (MPcond LM2 l) + | _ => True + end. + + Lemma PSubstL1_ok: forall n LM1 P1 l, + MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. + Proof. + intros n LM1; elim LM1; simpl; auto. + intros; rsimpl. + intros (M2,P2) LM2 Hrec P3 l [H H1]. + rewrite <- Hrec; auto. + apply PNSubst1_ok; auto. + Qed. + + Lemma PSubstL_ok: forall n LM1 P1 P2 l, + PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. + Proof. + intros n LM1; elim LM1; simpl; auto. + intros; discriminate. + intros (M2,P2) LM2 Hrec P3 P4 l. + generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n). + intros P5 H0 H1 [H2 H3]; injection H1; intros; subst. + rewrite <- PSubstL1_ok; auto. + intros l1 H [H1 H2]; auto. + Qed. + + Lemma PNSubstL_ok: forall m n LM1 P1 l, + MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. + Proof. + intros m; elim m; simpl; auto. + intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); + case (PSubstL P2 LM1 n); intros; rsimpl; auto. + intros m1 Hrec n LM1 P2 l H. + generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); + case (PSubstL P2 LM1 n); intros; rsimpl; auto. + rewrite <- Hrec; auto. + Qed. + + (** Definition of polynomial expressions *) + + Inductive PExpr : Type := + | PEc : C -> PExpr + | PEX : positive -> PExpr + | PEadd : PExpr -> PExpr -> PExpr + | PEsub : PExpr -> PExpr -> PExpr + | PEmul : PExpr -> PExpr -> PExpr + | PEopp : PExpr -> PExpr + | PEpow : PExpr -> N -> PExpr. + + (** evaluation of polynomial expressions towards R *) + Definition mk_X j := mkPinj_pred j mkX. + + (** evaluation of polynomial expressions towards R *) + + Fixpoint PEeval (l:Env R) (pe:PExpr) {struct pe} : R := + match pe with + | PEc c => phi c + | PEX j => nth j l + | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) + | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) + | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) + | PEopp pe1 => - (PEeval l pe1) + | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) + end. + + (** Correctness proofs *) + + Lemma mkX_ok : forall p l, nth p l == (mk_X p) @ l. + Proof. + destruct p;simpl;intros;Esimpl;trivial. + rewrite nth_spec ; auto. + unfold hd. + rewrite <- nth_Pdouble_minus_one. + rewrite (nth_jump (Pdouble_minus_one p) l 1). + reflexivity. + Qed. + + Ltac Esimpl3 := + repeat match goal with + | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l) + | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l) + end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). + +(* Power using the chinise algorithm *) +(*Section POWER. + Variable subst_l : Pol -> Pol. + Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol := + match p with + | xH => P + | xO p => subst_l (Psquare (Ppow_pos P p)) + | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p))) + end. + + Definition Ppow_N P n := + match n with + | N0 => P1 + | Npos p => Ppow_pos P p + end. + + Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l. + Proof. + intros l subst_l_ok P. + induction p;simpl;intros;try rrefl;try rewrite subst_l_ok. + repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. + repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. + Qed. + + Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. + Proof. destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial. Qed. + + End POWER. *) + +Section POWER. + Variable subst_l : Pol -> Pol. + Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := + match p with + | xH => subst_l (Pmul res P) + | xO p => Ppow_pos (Ppow_pos res P p) P p + | xI p => subst_l (Pmul (Ppow_pos (Ppow_pos res P p) P p) P) + end. + + Definition Ppow_N P n := + match n with + | N0 => P1 + | Npos p => Ppow_pos P1 P p + end. + + Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. + Proof. + intros l subst_l_ok res P p. generalize res;clear res. + induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp. + rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl. + Qed. + + Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. + Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok. trivial. Esimpl. auto. Qed. + + End POWER. + + (** Normalization and rewriting *) + + Section NORM_SUBST_REC. + Variable n : nat. + Variable lmp:list (Mon*Pol). + Let subst_l P := PNSubstL P lmp n n. + Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). + Let Ppow_subst := Ppow_N subst_l. + + Fixpoint norm_aux (pe:PExpr) : Pol := + match pe with + | PEc c => Pc c + | PEX j => mk_X j + | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1) + | PEadd pe1 (PEopp pe2) => + Psub (norm_aux pe1) (norm_aux pe2) + | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) + | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) + | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) + | PEopp pe1 => Popp (norm_aux pe1) + | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n + end. + + Definition norm_subst pe := subst_l (norm_aux pe). + + (* + Fixpoint norm_subst (pe:PExpr) : Pol := + match pe with + | PEc c => Pc c + | PEX j => subst_l (mk_X j) + | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1) + | PEadd pe1 (PEopp pe2) => + Psub (norm_subst pe1) (norm_subst pe2) + | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2) + | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2) + | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) + | PEopp pe1 => Popp (norm_subst pe1) + | PEpow pe1 n => Ppow_subst (norm_subst pe1) n + end. + + Lemma norm_subst_spec : + forall l pe, MPcond lmp l -> + PEeval l pe == (norm_subst pe)@l. + Proof. + intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). + unfold subst_l;intros. + rewrite <- PNSubstL_ok;trivial. rrefl. + assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l). + intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl. + induction pe;simpl;Esimpl3. + rewrite subst_l_ok;apply mkX_ok. + rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. + rewrite IHpe1;rewrite IHpe2;rrefl. + rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl. + rewrite IHpe;rrefl. + unfold Ppow_subst. rewrite Ppow_N_ok. trivial. + rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. + induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; + repeat rewrite Pmul_ok;rrefl. + Qed. +*) + Lemma norm_aux_spec : + forall l pe, (*MPcond lmp l ->*) + PEeval l pe == (norm_aux pe)@l. + Proof. + intros. + induction pe;simpl;Esimpl3. + apply mkX_ok. + rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. + rewrite IHpe1;rewrite IHpe2;rrefl. + rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl. + rewrite IHpe;rrefl. + rewrite Ppow_N_ok by reflexivity. + rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. + induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; + repeat rewrite Pmul_ok;rrefl. + Qed. + + + End NORM_SUBST_REC. + + +End MakeRingPol. + diff --git a/plugins/micromega/LICENSE.sos b/plugins/micromega/LICENSE.sos new file mode 100644 index 00000000..5aadfa2a --- /dev/null +++ b/plugins/micromega/LICENSE.sos @@ -0,0 +1,29 @@ + HOL Light copyright notice, licence and disclaimer + + (c) University of Cambridge 1998 + (c) Copyright, John Harrison 1998-2006 + +HOL Light version 2.20, hereinafter referred to as "the software", is a +computer theorem proving system written by John Harrison. Much of the +software was developed at the University of Cambridge Computer Laboratory, +New Museums Site, Pembroke Street, Cambridge, CB2 3QG, England. The +software is copyright, University of Cambridge 1998 and John Harrison +1998-2006. + +Permission to use, copy, modify, and distribute the software and its +documentation for any purpose and without fee is hereby granted. In the +case of further distribution of the software the present text, including +copyright notice, licence and disclaimer of warranty, must be included in +full and unmodified form in any release. Distribution of derivative +software obtained by modifying the software, or incorporating it into +other software, is permitted, provided the inclusion of the software is +acknowledged and that any changes made to the software are clearly +documented. + +John Harrison and the University of Cambridge disclaim all warranties +with regard to the software, including all implied warranties of +merchantability and fitness. In no event shall John Harrison or the +University of Cambridge be liable for any special, indirect, +incidental or consequential damages or any damages whatsoever, +including, but not limited to, those arising from computer failure or +malfunction, work stoppage, loss of profit or loss of contracts. diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v new file mode 100644 index 00000000..1d7fbd56 --- /dev/null +++ b/plugins/micromega/MExtraction.v @@ -0,0 +1,48 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* "( * )" [ "(,)" ]. +Extract Inductive List.list => list [ "[]" "(::)" ]. +Extract Inductive bool => bool [ true false ]. +Extract Inductive sumbool => bool [ true false ]. +Extract Inductive option => option [ Some None ]. +Extract Inductive sumor => option [ Some None ]. +(** Then, in a ternary alternative { }+{ }+{ }, + - leftmost choice (Inleft Left) is (Some true), + - middle choice (Inleft Right) is (Some false), + - rightmost choice (Inright) is (None) *) + + +(** To preserve its laziness, andb is normally expansed. + Let's rather use the ocaml && *) +Extract Inlined Constant andb => "(&&)". + +Extraction "micromega.ml" + List.map simpl_cone (*map_cone indexes*) + denorm Qpower + n_of_Z Nnat.N_of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v new file mode 100644 index 00000000..803dd903 --- /dev/null +++ b/plugins/micromega/OrderedRing.v @@ -0,0 +1,458 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* R -> R) (ropp : R -> R). +Variable req rle rlt : R -> R -> Prop. +Notation "0" := rO. +Notation "1" := rI. +Notation "x + y" := (rplus x y). +Notation "x * y " := (rtimes x y). +Notation "x - y " := (rminus x y). +Notation "- x" := (ropp x). +Notation "x == y" := (req x y). +Notation "x ~= y" := (~ req x y). +Notation "x <= y" := (rle x y). +Notation "x < y" := (rlt x y). + +Record SOR : Type := mk_SOR_theory { + SORsetoid : Setoid_Theory R req; + SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; + SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2; + SORopp_wd : forall x1 x2, x1 == x2 -> -x1 == -x2; + SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2); + SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2); + SORrt : ring_theory rO rI rplus rtimes rminus ropp req; + SORle_refl : forall n : R, n <= n; + SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m; + SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p; + SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m; + SORlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n; + SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m; + SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m; + SORneq_0_1 : 0 ~= 1 +}. + +(* We cannot use Relation_Definitions.order.ord_antisym and +Relations_1.Antisymmetric because they refer to Leibniz equality *) + +End DEFINITIONS. + +Section STRICT_ORDERED_RING. + +Variable R : Type. +Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R). +Variable req rle rlt : R -> R -> Prop. + +Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. + +Notation "0" := rO. +Notation "1" := rI. +Notation "x + y" := (rplus x y). +Notation "x * y " := (rtimes x y). +Notation "x - y " := (rminus x y). +Notation "- x" := (ropp x). +Notation "x == y" := (req x y). +Notation "x ~= y" := (~ req x y). +Notation "x <= y" := (rle x y). +Notation "x < y" := (rlt x y). + + +Add Relation R req + reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ ) + symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ ) + transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ ) +as sor_setoid. + + +Add Morphism rplus with signature req ==> req ==> req as rplus_morph. +Proof. +exact sor.(SORplus_wd). +Qed. +Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. +Proof. +exact sor.(SORtimes_wd). +Qed. +Add Morphism ropp with signature req ==> req as ropp_morph. +Proof. +exact sor.(SORopp_wd). +Qed. +Add Morphism rle with signature req ==> req ==> iff as rle_morph. +Proof. +exact sor.(SORle_wd). +Qed. +Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. +Proof. +exact sor.(SORlt_wd). +Qed. + +Add Ring SOR : sor.(SORrt). + +Add Morphism rminus with signature req ==> req ==> req as rminus_morph. +Proof. +intros x1 x2 H1 y1 y2 H2. +rewrite (sor.(SORrt).(Rsub_def) x1 y1). +rewrite (sor.(SORrt).(Rsub_def) x2 y2). +rewrite H1; now rewrite H2. +Qed. + +Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n. +Proof. +intros n m H1 H2; rewrite H2 in H1; now apply H1. +Qed. + +(* Propeties of plus, minus and opp *) + +Theorem Rplus_0_l : forall n : R, 0 + n == n. +Proof. +intro; ring. +Qed. + +Theorem Rplus_0_r : forall n : R, n + 0 == n. +Proof. +intro; ring. +Qed. + +Theorem Rtimes_0_r : forall n : R, n * 0 == 0. +Proof. +intro; ring. +Qed. + +Theorem Rplus_comm : forall n m : R, n + m == m + n. +Proof. +intros; ring. +Qed. + +Theorem Rtimes_0_l : forall n : R, 0 * n == 0. +Proof. +intro; ring. +Qed. + +Theorem Rtimes_comm : forall n m : R, n * m == m * n. +Proof. +intros; ring. +Qed. + +Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m. +Proof. +intros n m. +split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H. +now rewrite Rplus_0_l. +rewrite H; ring. +Qed. + +Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m. +Proof. +intros n m p; split; intro H. +setoid_replace n with (- p + (p + n)) by ring. +setoid_replace m with (- p + (p + m)) by ring. now rewrite H. +now rewrite H. +Qed. + +(* Relations *) + +Theorem Rle_refl : forall n : R, n <= n. +Proof sor.(SORle_refl). + +Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m. +Proof sor.(SORle_antisymm). + +Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p. +Proof sor.(SORle_trans). + +Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n. +Proof sor.(SORlt_trichotomy). + +Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m. +Proof sor.(SORlt_le_neq). + +Theorem Rneq_0_1 : 0 ~= 1. +Proof sor.(SORneq_0_1). + +Theorem Req_em : forall n m : R, n == m \/ n ~= m. +Proof. +intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H. +right; now destruct H. +now left. +right; apply Rneq_symm; now destruct H. +Qed. + +Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m. +Proof. +intros n m; destruct (Req_em n m) as [H | H]. +split; auto. +split. intro H1; false_hyp H H1. auto. +Qed. + +Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m. +Proof. +intros n m; rewrite Rlt_le_neq. +split; [intro H | intros [[H1 H2] | H]]. +destruct (Req_em n m) as [H1 | H1]. now right. left; now split. +assumption. +rewrite H; apply Rle_refl. +Qed. + +Ltac le_less := rewrite Rle_lt_eq; left; try assumption. +Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption. +Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H]. + +Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p. +Proof. +intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split. +now apply Rle_trans with m. +intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4. +Qed. + +Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p. +Proof. +intros n m p H1 H2; le_elim H1. +now apply Rlt_trans with (m := m). now rewrite H1. +Qed. + +Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p. +Proof. +intros n m p H1 H2; le_elim H2. +now apply Rlt_trans with (m := m). now rewrite <- H2. +Qed. + +Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n. +Proof. +intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]]. +left; now le_less. left; now le_equal. now right. +Qed. + +Theorem Rlt_neq : forall n m : R, n < m -> n ~= m. +Proof. +intros n m; rewrite Rlt_le_neq; now intros [_ H]. +Qed. + +Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n. +Proof. +intros n m; split. +intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2). +intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. assumption. false_hyp H1 H. +Qed. + +Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n. +Proof. +intros n m; split. +intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2). +intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. false_hyp H1 H. assumption. +Qed. + +(* Plus, minus and order *) + +Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m. +Proof. +intros n m p; split. +apply sor.(SORplus_le_mono_l). +intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H. +setoid_replace (- p + (p + n)) with n in H by ring. +setoid_replace (- p + (p + m)) with m in H by ring. assumption. +Qed. + +Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p. +Proof. +intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p). +apply Rplus_le_mono_l. +Qed. + +Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m. +Proof. +intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l. +now rewrite <- Rplus_le_mono_l. +Qed. + +Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p. +Proof. +intros n m p. +rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l. +Qed. + +Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q. +Proof. +intros n m p q H1 H2. +apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l]. +Qed. + +Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q. +Proof. +intros n m p q H1 H2. +apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l]. +Qed. + +Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q. +Proof. +intros n m p q H1 H2. +apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l]. +Qed. + +Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q. +Proof. +intros n m p q H1 H2. +apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l]. +Qed. + +Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m. +Proof. +intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono. +Qed. + +Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m. +Proof. +intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono. +Qed. + +Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m. +Proof. +intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono. +Qed. + +Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m. +Proof. +intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono. +Qed. + +Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n. +Proof. +intros n m. rewrite (@Rplus_le_mono_r n m (- n)). +setoid_replace (n + - n) with 0 by ring. +now setoid_replace (m + - n) with (m - n) by ring. +Qed. + +Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n. +Proof. +intros n m. rewrite (@Rplus_lt_mono_r n m (- n)). +setoid_replace (n + - n) with 0 by ring. +now setoid_replace (m + - n) with (m - n) by ring. +Qed. + +Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n. +Proof. +intros n m. split; intro H. +apply -> (@Rplus_lt_mono_l n m (- n - m)) in H. +setoid_replace (- n - m + n) with (- m) in H by ring. +now setoid_replace (- n - m + m) with (- n) in H by ring. +apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H. +setoid_replace (n + m + - m) with n in H by ring. +now setoid_replace (n + m + - n) with m in H by ring. +Qed. + +Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0. +Proof. +intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring. +Qed. + +(* Times and order *) + +Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m. +Proof sor.(SORtimes_pos_pos). + +Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m. +Proof. +intros n m H1 H2. +le_elim H1. le_elim H2. +le_less; now apply Rtimes_pos_pos. +rewrite <- H2; rewrite Rtimes_0_r; le_equal. +rewrite <- H1; rewrite Rtimes_0_l; le_equal. +Qed. + +Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0. +Proof. +intros n m H1 H2. apply -> Ropp_pos_neg. +setoid_replace (- (n * m)) with (n * (- m)) by ring. +apply Rtimes_pos_pos. assumption. now apply <- Ropp_pos_neg. +Qed. + +Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m. +Proof. +intros n m H1 H2. +setoid_replace (n * m) with ((- n) * (- m)) by ring. +apply Rtimes_pos_pos; now apply <- Ropp_pos_neg. +Qed. + +Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n. +Proof. +intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]]. +le_less; now apply Rtimes_pos_pos. +rewrite <- H, Rtimes_0_l; le_equal. +le_less; now apply Rtimes_neg_neg. +Qed. + +Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0. +Proof. +intros n m [H1 H2]. +destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]]; +destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]]; +try (false_hyp H3 H1); try (false_hyp H4 H2). +apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg. +apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg. +apply Rlt_neq. now apply Rtimes_pos_neg. +apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos. +Qed. + +(* The following theorems are used to build a morphism from Z to R and +prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *) + +(* Surprisingly, multilication is needed to prove the following theorem *) + +Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n. +Proof. +intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg. +now setoid_replace (- - n) with n by ring. +Qed. + +Theorem Rlt_0_1 : 0 < 1. +Proof. +apply <- Rlt_le_neq. split. +setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg. +apply Rneq_0_1. +Qed. + +Theorem Rlt_succ_r : forall n : R, n < 1 + n. +Proof. +intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring. +apply -> Rplus_lt_mono_r. apply Rlt_0_1. +Qed. + +Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m. +Proof. +intros n m H; apply Rlt_trans with m. assumption. apply Rlt_succ_r. +Qed. + +(*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m. +Proof. +intros n m p H1 H2. apply <- Rlt_lt_minus. +setoid_replace (p * m - p * n) with (p * (m - n)) by ring. +apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus. +Qed.*) + +End STRICT_ORDERED_RING. + diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v new file mode 100644 index 00000000..444a590a --- /dev/null +++ b/plugins/micromega/Psatz.v @@ -0,0 +1,86 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + (sos_Z || psatz_Z d) ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity + | R => + (sos_R || psatz_R d) ; + (* If csdp is not installed, the previous step might not produce any + progress: the rest of the tactical will then fail. Hence the 'try'. *) + try (intros __wit __varmap __ff ; + change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; + apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity) + | Q => + (sos_Q || psatz_Q d) ; + (* If csdp is not installed, the previous step might not produce any + progress: the rest of the tactical will then fail. Hence the 'try'. *) + try (intros __wit __varmap __ff ; + change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; + apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity) + | _ => fail "Unsupported domain" + end in tac. + +Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. +Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1. + +Ltac psatzl dom := + let tac := lazymatch dom with + | Z => + psatzl_Z ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity + | Q => + psatzl_Q ; + (* If csdp is not installed, the previous step might not produce any + progress: the rest of the tactical will then fail. Hence the 'try'. *) + try (intros __wit __varmap __ff ; + change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; + apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity) + | R => + psatzl_R ; + (* If csdp is not installed, the previous step might not produce any + progress: the rest of the tactical will then fail. Hence the 'try'. *) + try (intros __wit __varmap __ff ; + change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; + apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity) + | _ => fail "Unsupported domain" + end in tac. + +Ltac lia := + xlia ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity. + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v new file mode 100644 index 00000000..1e909cbc --- /dev/null +++ b/plugins/micromega/QMicromega.v @@ -0,0 +1,197 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* x) (fun x => x) (pow_N 1 Qmult). +Proof. + constructor. + constructor ; intros ; try reflexivity. + apply Qeq_bool_eq; auto. + constructor. + reflexivity. + intros x y. + apply Qeq_bool_neq ; auto. + apply Qle_bool_imp_le. +Qed. + + +(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*) +Require Import EnvRing. + +Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := + match e with + | PEc c => c + | PEX j => env j + | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) + | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) + | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) + | PEopp pe1 => - (Qeval_expr env pe1) + | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n) + end. + +Lemma Qeval_expr_simpl : forall env e, + Qeval_expr env e = + match e with + | PEc c => c + | PEX j => env j + | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) + | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) + | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) + | PEopp pe1 => - (Qeval_expr env pe1) + | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n) + end. +Proof. + destruct e ; reflexivity. +Qed. + +Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult). + +Lemma QNpower : forall r n, r ^ Z_of_N n = pow_N 1 Qmult r n. +Proof. + destruct n ; reflexivity. +Qed. + + +Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e. +Proof. + induction e ; simpl ; subst ; try congruence. + reflexivity. + rewrite IHe. + apply QNpower. +Qed. + +Definition Qeval_op2 (o : Op2) : Q -> Q -> Prop := +match o with +| OpEq => Qeq +| OpNEq => fun x y => ~ x == y +| OpLe => Qle +| OpGe => fun x y => Qle y x +| OpLt => Qlt +| OpGt => fun x y => Qlt y x +end. + +Definition Qeval_formula (e:PolEnv Q) (ff : Formula Q) := + let (lhs,o,rhs) := ff in Qeval_op2 o (Qeval_expr e lhs) (Qeval_expr e rhs). + +Definition Qeval_formula' := + eval_formula Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult). + +Lemma Qeval_formula_compat : forall env f, Qeval_formula env f <-> Qeval_formula' env f. +Proof. + intros. + unfold Qeval_formula. + destruct f. + repeat rewrite Qeval_expr_compat. + unfold Qeval_formula'. + unfold Qeval_expr'. + split ; destruct Fop ; simpl; auto. +Qed. + + +Definition Qeval_nformula := + eval_nformula 0 Qplus Qmult Qeq Qle Qlt (fun x => x) . + +Definition Qeval_op1 (o : Op1) : Q -> Prop := +match o with +| Equal => fun x : Q => x == 0 +| NonEqual => fun x : Q => ~ x == 0 +| Strict => fun x : Q => 0 < x +| NonStrict => fun x : Q => 0 <= x +end. + + +Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). +Proof. + exact (fun env d =>eval_nformula_dec Qsor (fun x => x) env d). +Qed. + +Definition QWitness := Psatz Q. + +Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qeq_bool Qle_bool. + +Require Import List. + +Lemma QWeakChecker_sound : forall (l : list (NFormula Q)) (cm : QWitness), + QWeakChecker l cm = true -> + forall env, make_impl (Qeval_nformula env) l False. +Proof. + intros l cm H. + intro. + unfold Qeval_nformula. + apply (checker_nf_sound Qsor QSORaddon l cm). + unfold QWeakChecker in H. + exact H. +Qed. + +Require Import Tauto. + +Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. +Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. + +Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := + @tauto_checker (Formula Q) (NFormula Q) + Qnormalise + Qnegate QWitness QWeakChecker f w. + + + +Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f (Qeval_formula env) f. +Proof. + intros f w. + unfold QTautoChecker. + apply (tauto_checker_sound Qeval_formula Qeval_nformula). + apply Qeval_nformula_dec. + intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor QSORaddon). + intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor QSORaddon). + intros t w0. + apply QWeakChecker_sound. +Qed. + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v new file mode 100644 index 00000000..21f991ef --- /dev/null +++ b/plugins/micromega/RMicromega.v @@ -0,0 +1,182 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* IZR 0%Z + | Npos p => IZR (Zpos p) + end. + +Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp IZR Nnat.nat_of_N pow. + + +Definition Reval_op2 (o:Op2) : R -> R -> Prop := + match o with + | OpEq => @eq R + | OpNEq => fun x y => ~ x = y + | OpLe => Rle + | OpGe => Rge + | OpLt => Rlt + | OpGt => Rgt + end. + + +Definition Reval_formula (e: PolEnv R) (ff : Formula Z) := + let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs). + +Definition Reval_formula' := + eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow. + +Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f. +Proof. + intros. + unfold Reval_formula. + destruct f. + unfold Reval_formula'. + unfold Reval_expr. + split ; destruct Fop ; simpl ; auto. + apply Rge_le. + apply Rle_ge. +Qed. + +Definition Reval_nformula := + eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt IZR. + + +Lemma Reval_nformula_dec : forall env d, (Reval_nformula env d) \/ ~ (Reval_nformula env d). +Proof. + exact (fun env d =>eval_nformula_dec Rsor IZR env d). +Qed. + +Definition RWitness := Psatz Z. + +Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult Zeq_bool Zle_bool. + +Require Import List. + +Lemma RWeakChecker_sound : forall (l : list (NFormula Z)) (cm : RWitness), + RWeakChecker l cm = true -> + forall env, make_impl (Reval_nformula env) l False. +Proof. + intros l cm H. + intro. + unfold Reval_nformula. + apply (checker_nf_sound Rsor RZSORaddon l cm). + unfold RWeakChecker in H. + exact H. +Qed. + +Require Import Tauto. + +Definition Rnormalise := @cnf_normalise Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool. +Definition Rnegate := @cnf_negate Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool. + +Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness) : bool := + @tauto_checker (Formula Z) (NFormula Z) + Rnormalise Rnegate + RWitness RWeakChecker f w. + +Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f (Reval_formula env) f. +Proof. + intros f w. + unfold RTautoChecker. + apply (tauto_checker_sound Reval_formula Reval_nformula). + apply Reval_nformula_dec. + intros. rewrite Reval_formula_compat. + unfold Reval_formula'. now apply (cnf_normalise_correct Rsor RZSORaddon). + intros. rewrite Reval_formula_compat. unfold Reval_formula. now apply (cnf_negate_correct Rsor RZSORaddon). + intros t w0. + apply RWeakChecker_sound. +Qed. + + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v new file mode 100644 index 00000000..3b0de76b --- /dev/null +++ b/plugins/micromega/Refl.v @@ -0,0 +1,130 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ' '/\': basic properties *) + +Fixpoint make_impl (A : Type) (eval : A -> Prop) (l : list A) (goal : Prop) {struct l} : Prop := + match l with + | nil => goal + | cons e l => (eval e) -> (make_impl eval l goal) + end. + +Theorem make_impl_true : + forall (A : Type) (eval : A -> Prop) (l : list A), make_impl eval l True. +Proof. +induction l as [| a l IH]; simpl. +trivial. +intro; apply IH. +Qed. + +Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop := + match l with + | nil => True + | cons e nil => (eval e) + | cons e l2 => ((eval e) /\ (make_conj eval l2)) + end. + +Theorem make_conj_cons : forall (A : Type) (eval : A -> Prop) (a : A) (l : list A), + make_conj eval (a :: l) <-> eval a /\ make_conj eval l. +Proof. +intros; destruct l; simpl; tauto. +Qed. + + +Lemma make_conj_impl : forall (A : Type) (eval : A -> Prop) (l : list A) (g : Prop), + (make_conj eval l -> g) <-> make_impl eval l g. +Proof. + induction l. + simpl. + tauto. + simpl. + intros. + destruct l. + simpl. + tauto. + generalize (IHl g). + tauto. +Qed. + +Lemma make_conj_in : forall (A : Type) (eval : A -> Prop) (l : list A), + make_conj eval l -> (forall p, In p l -> eval p). +Proof. + induction l. + simpl. + tauto. + simpl. + intros. + destruct l. + simpl in H0. + destruct H0. + subst; auto. + tauto. + destruct H. + destruct H0. + subst;auto. + apply IHl; auto. +Qed. + + + +Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2. +Proof. + induction l1. + simpl. + tauto. + intros. + change ((a::l1) ++ l2) with (a :: (l1 ++ l2)). + rewrite make_conj_cons. + rewrite IHl1. + rewrite make_conj_cons. + tauto. +Qed. + +Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval (no_middle_eval : (eval t) \/ ~ (eval t)), + ~ make_conj eval (t ::a) -> ~ (eval t) \/ (~ make_conj eval a). +Proof. + intros. + simpl in H. + destruct a. + tauto. + tauto. +Qed. + +Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval + (no_middle_eval : forall d, eval d \/ ~ eval d) , + ~ make_conj eval (t ++ a) -> (~ make_conj eval t) \/ (~ make_conj eval a). +Proof. + induction t. + simpl. + tauto. + intros. + simpl ((a::t)++a0)in H. + destruct (@not_make_conj_cons _ _ _ _ (no_middle_eval a) H). + left ; red ; intros. + apply H0. + rewrite make_conj_cons in H1. + tauto. + destruct (IHt _ _ no_middle_eval H0). + left ; red ; intros. + apply H1. + rewrite make_conj_cons in H2. + tauto. + right ; auto. +Qed. diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v new file mode 100644 index 00000000..d556cd03 --- /dev/null +++ b/plugins/micromega/RingMicromega.v @@ -0,0 +1,884 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* R -> R. +Variable ropp : R -> R. +Variables req rle rlt : R -> R -> Prop. + +Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. + +Notation "0" := rO. +Notation "1" := rI. +Notation "x + y" := (rplus x y). +Notation "x * y " := (rtimes x y). +Notation "x - y " := (rminus x y). +Notation "- x" := (ropp x). +Notation "x == y" := (req x y). +Notation "x ~= y" := (~ req x y). +Notation "x <= y" := (rle x y). +Notation "x < y" := (rlt x y). + +(* Assume we have a type of coefficients C and a morphism from C to R *) + +Variable C : Type. +Variables cO cI : C. +Variables cplus ctimes cminus: C -> C -> C. +Variable copp : C -> C. +Variables ceqb cleb : C -> C -> bool. +Variable phi : C -> R. + +(* Power coefficients *) +Variable E : Set. (* the type of exponents *) +Variable pow_phi : N -> E. +Variable rpow : R -> E -> R. + +Notation "[ x ]" := (phi x). +Notation "x [=] y" := (ceqb x y). +Notation "x [<=] y" := (cleb x y). + +(* Let's collect all hypotheses in addition to the ordered ring axioms into +one structure *) + +Record SORaddon := mk_SOR_addon { + SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi; + SORpower : power_theory rI rtimes req pow_phi rpow; + SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y]; + SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y] +}. + +Variable addon : SORaddon. + +Add Relation R req + reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ ) + symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ ) + transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ ) +as micomega_sor_setoid. + +Add Morphism rplus with signature req ==> req ==> req as rplus_morph. +Proof. +exact sor.(SORplus_wd). +Qed. +Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. +Proof. +exact sor.(SORtimes_wd). +Qed. +Add Morphism ropp with signature req ==> req as ropp_morph. +Proof. +exact sor.(SORopp_wd). +Qed. +Add Morphism rle with signature req ==> req ==> iff as rle_morph. +Proof. + exact sor.(SORle_wd). +Qed. +Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. +Proof. + exact sor.(SORlt_wd). +Qed. + +Add Morphism rminus with signature req ==> req ==> req as rminus_morph. +Proof. + exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *) +Qed. + +Definition cneqb (x y : C) := negb (ceqb x y). +Definition cltb (x y : C) := (cleb x y) && (cneqb x y). + +Notation "x [~=] y" := (cneqb x y). +Notation "x [<] y" := (cltb x y). + +Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. +Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. +Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H]. + +Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y]. +Proof. + exact addon.(SORcleb_morph). +Qed. + +Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y]. +Proof. +intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1. +destruct (ceqb x y); now try discriminate. +Qed. + + +Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y]. +Proof. +intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2]. +apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split. +Qed. + +(* Begin Micromega *) + +Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *) +Definition PolEnv := Env R. (* For interpreting PolC *) +Definition eval_pol (env : PolEnv) (p:PolC) : R := + Pphi 0 rplus rtimes phi env p. + +Inductive Op1 : Set := (* relations with 0 *) +| Equal (* == 0 *) +| NonEqual (* ~= 0 *) +| Strict (* > 0 *) +| NonStrict (* >= 0 *). + +Definition NFormula := (PolC * Op1)%type. (* normalized formula *) + +Definition eval_op1 (o : Op1) : R -> Prop := +match o with +| Equal => fun x => x == 0 +| NonEqual => fun x : R => x ~= 0 +| Strict => fun x : R => 0 < x +| NonStrict => fun x : R => 0 <= x +end. + +Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop := +let (p, op) := f in eval_op1 op (eval_pol env p). + + +(** Rule of "signs" for addition and multiplication. + An arbitrary result is coded buy None. *) + +Definition OpMult (o o' : Op1) : option Op1 := +match o with +| Equal => Some Equal +| NonStrict => + match o' with + | Equal => Some Equal + | NonEqual => None + | Strict => Some NonStrict + | NonStrict => Some NonStrict + end +| Strict => match o' with + | NonEqual => None + | _ => Some o' + end +| NonEqual => match o' with + | Equal => Some Equal + | NonEqual => Some NonEqual + | _ => None + end +end. + +Definition OpAdd (o o': Op1) : option Op1 := + match o with + | Equal => Some o' + | NonStrict => + match o' with + | Strict => Some Strict + | NonEqual => None + | _ => Some NonStrict + end + | Strict => match o' with + | NonEqual => None + | _ => Some Strict + end + | NonEqual => match o' with + | Equal => Some NonEqual + | _ => None + end + end. + + +Lemma OpMult_sound : + forall (o o' om: Op1) (x y : R), + eval_op1 o x -> eval_op1 o' y -> OpMult o o' = Some om -> eval_op1 om (x * y). +Proof. +unfold eval_op1; destruct o; simpl; intros o' om x y H1 H2 H3. +(* x == 0 *) +inversion H3. rewrite H1. now rewrite (Rtimes_0_l sor). +(* x ~= 0 *) +destruct o' ; inversion H3. + (* y == 0 *) + rewrite H2. now rewrite (Rtimes_0_r sor). + (* y ~= 0 *) + apply (Rtimes_neq_0 sor) ; auto. +(* 0 < x *) +destruct o' ; inversion H3. + (* y == 0 *) + rewrite H2; now rewrite (Rtimes_0_r sor). + (* 0 < y *) + now apply (Rtimes_pos_pos sor). + (* 0 <= y *) + apply (Rtimes_nonneg_nonneg sor); [le_less | assumption]. +(* 0 <= x *) +destruct o' ; inversion H3. + (* y == 0 *) + rewrite H2; now rewrite (Rtimes_0_r sor). + (* 0 < y *) + apply (Rtimes_nonneg_nonneg sor); [assumption | le_less ]. + (* 0 <= y *) + now apply (Rtimes_nonneg_nonneg sor). +Qed. + +Lemma OpAdd_sound : + forall (o o' oa : Op1) (e e' : R), + eval_op1 o e -> eval_op1 o' e' -> OpAdd o o' = Some oa -> eval_op1 oa (e + e'). +Proof. +unfold eval_op1; destruct o; simpl; intros o' oa e e' H1 H2 Hoa. +(* e == 0 *) +inversion Hoa. rewrite <- H0. +destruct o' ; rewrite H1 ; now rewrite (Rplus_0_l sor). +(* e ~= 0 *) + destruct o'. + (* e' == 0 *) + inversion Hoa. + rewrite H2. now rewrite (Rplus_0_r sor). + (* e' ~= 0 *) + discriminate. + (* 0 < e' *) + discriminate. + (* 0 <= e' *) + discriminate. +(* 0 < e *) + destruct o'. + (* e' == 0 *) + inversion Hoa. + rewrite H2. now rewrite (Rplus_0_r sor). + (* e' ~= 0 *) + discriminate. + (* 0 < e' *) + inversion Hoa. + now apply (Rplus_pos_pos sor). + (* 0 <= e' *) + inversion Hoa. + now apply (Rplus_pos_nonneg sor). +(* 0 <= e *) + destruct o'. + (* e' == 0 *) + inversion Hoa. + now rewrite H2, (Rplus_0_r sor). + (* e' ~= 0 *) + discriminate. + (* 0 < e' *) + inversion Hoa. + now apply (Rplus_nonneg_pos sor). + (* 0 <= e' *) + inversion Hoa. + now apply (Rplus_nonneg_nonneg sor). +Qed. + +Inductive Psatz : Type := +| PsatzIn : nat -> Psatz +| PsatzSquare : PolC -> Psatz +| PsatzMulC : PolC -> Psatz -> Psatz +| PsatzMulE : Psatz -> Psatz -> Psatz +| PsatzAdd : Psatz -> Psatz -> Psatz +| PsatzC : C -> Psatz +| PsatzZ : Psatz. + +(** Given a list [l] of NFormula and an extended polynomial expression + [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a + logic consequence of the conjunction of the formulae in l. + Moreover, the polynomial expression is obtained by replacing the (PsatzIn n) + by the nth polynomial expression in [l] and the sign is computed by the "rule of sign" *) + +(* Might be defined elsewhere *) +Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B := + match o with + | None => None + | Some x => f x + end. + +Implicit Arguments map_option [A B]. + +Definition map_option2 (A B C : Type) (f : A -> B -> option C) + (o: option A) (o': option B) : option C := + match o , o' with + | None , _ => None + | _ , None => None + | Some x , Some x' => f x x' + end. + +Implicit Arguments map_option2 [A B C]. + +Definition Rops_wd := mk_reqe rplus rtimes ropp req + sor.(SORplus_wd) + sor.(SORtimes_wd) + sor.(SORopp_wd). + +Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula := + let (ef,o) := f in + match o with + | Equal => Some (Pmul cO cI cplus ctimes ceqb e ef , Equal) + | _ => None + end. + +Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula := + let (e1,o1) := f1 in + let (e2,o2) := f2 in + map_option (fun x => (Some (Pmul cO cI cplus ctimes ceqb e1 e2,x))) (OpMult o1 o2). + + Definition nformula_plus_nformula (f1 f2 : NFormula) : option NFormula := + let (e1,o1) := f1 in + let (e2,o2) := f2 in + map_option (fun x => (Some (Padd cO cplus ceqb e1 e2,x))) (OpAdd o1 o2). + + +Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula := + match e with + | PsatzIn n => Some (nth n l (Pc cO, Equal)) + | PsatzSquare e => Some (Psquare cO cI cplus ctimes ceqb e , NonStrict) + | PsatzMulC re e => map_option (pexpr_times_nformula re) (eval_Psatz l e) + | PsatzMulE f1 f2 => map_option2 nformula_times_nformula (eval_Psatz l f1) (eval_Psatz l f2) + | PsatzAdd f1 f2 => map_option2 nformula_plus_nformula (eval_Psatz l f1) (eval_Psatz l f2) + | PsatzC c => if cltb cO c then Some (Pc c, Strict) else None +(* This could be 0, or <> 0 -- but these cases are useless *) + | PsatzZ => Some (Pc cO, Equal) (* Just to make life easier *) + end. + +Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFormula), + eval_nformula env f -> pexpr_times_nformula e f = Some f' -> + eval_nformula env f'. +Proof. + unfold pexpr_times_nformula. + destruct f. + intros. destruct o ; inversion H0 ; try discriminate. + simpl in *. unfold eval_pol in *. + rewrite (Pmul_ok sor.(SORsetoid) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). + rewrite H. apply (Rtimes_0_r sor). +Qed. + +Lemma nformula_times_nformula_correct : forall (env:PolEnv) + (f1 f2 f : NFormula), + eval_nformula env f1 -> eval_nformula env f2 -> + nformula_times_nformula f1 f2 = Some f -> + eval_nformula env f. +Proof. + unfold nformula_times_nformula. + destruct f1 ; destruct f2. + case_eq (OpMult o o0) ; simpl ; try discriminate. + intros. inversion H2 ; simpl. + unfold eval_pol. + destruct o1; simpl; + rewrite (Pmul_ok sor.(SORsetoid) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + apply OpMult_sound with (3:= H);assumption. +Qed. + +Lemma nformula_plus_nformula_correct : forall (env:PolEnv) + (f1 f2 f : NFormula), + eval_nformula env f1 -> eval_nformula env f2 -> + nformula_plus_nformula f1 f2 = Some f -> + eval_nformula env f. +Proof. + unfold nformula_plus_nformula. + destruct f1 ; destruct f2. + case_eq (OpAdd o o0) ; simpl ; try discriminate. + intros. inversion H2 ; simpl. + unfold eval_pol. + destruct o1; simpl; + rewrite (Padd_ok sor.(SORsetoid) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + apply OpAdd_sound with (3:= H);assumption. +Qed. + +Lemma eval_Psatz_Sound : + forall (l : list NFormula) (env : PolEnv), + (forall (f : NFormula), In f l -> eval_nformula env f) -> + forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f -> + eval_nformula env f. +Proof. + induction e. + (* PsatzIn *) + simpl ; intros. + destruct (nth_in_or_default n l (Pc cO, Equal)). + (* index is in bounds *) + apply H ; congruence. + (* index is out-of-bounds *) + inversion H0. + rewrite e. simpl. + now apply addon.(SORrm).(morph0). + (* PsatzSquare *) + simpl. intros. inversion H0. + simpl. unfold eval_pol. + rewrite (Psquare_ok sor.(SORsetoid) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + now apply (Rtimes_square_nonneg sor). + (* PsatzMulC *) + simpl. + intro. + case_eq (eval_Psatz l e) ; simpl ; intros. + apply IHe in H0. + apply pexpr_times_nformula_correct with (1:=H0) (2:= H1). + discriminate. + (* PsatzMulC *) + simpl ; intro. + case_eq (eval_Psatz l e1) ; simpl ; try discriminate. + case_eq (eval_Psatz l e2) ; simpl ; try discriminate. + intros. + apply IHe1 in H1. apply IHe2 in H0. + apply (nformula_times_nformula_correct env n0 n) ; assumption. + (* PsatzAdd *) + simpl ; intro. + case_eq (eval_Psatz l e1) ; simpl ; try discriminate. + case_eq (eval_Psatz l e2) ; simpl ; try discriminate. + intros. + apply IHe1 in H1. apply IHe2 in H0. + apply (nformula_plus_nformula_correct env n0 n) ; assumption. + (* PsatzC *) + simpl. + intro. case_eq (cO [<] c). + intros. inversion H1. simpl. + rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. + discriminate. + (* PsatzZ *) + simpl. intros. inversion H0. + simpl. apply addon.(SORrm).(morph0). +Qed. + +Fixpoint ge_bool (n m : nat) : bool := + match n with + | O => match m with + | O => true + | S _ => false + end + | S n => match m with + | O => true + | S m => ge_bool n m + end + end. + +Lemma ge_bool_cases : forall n m, (if ge_bool n m then n >= m else n < m)%nat. +Proof. + induction n ; simpl. + destruct m ; simpl. + constructor. + omega. + destruct m. + constructor. + omega. + generalize (IHn m). + destruct (ge_bool n m) ; omega. +Qed. + + +Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz) : list nat := + match prf with + | PsatzC _ | PsatzZ | PsatzSquare _ => acc + | PsatzMulC _ prf => xhyps_of_psatz base acc prf + | PsatzAdd e1 e2 | PsatzMulE e1 e2 => xhyps_of_psatz base (xhyps_of_psatz base acc e2) e1 + | PsatzIn n => if ge_bool n base then (n::acc) else acc + end. + + +(* roughly speaking, normalise_pexpr_correct is a proof of + forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *) + +(*****) +Definition paddC := PaddC cplus. +Definition psubC := PsubC cminus. + +Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env P - [c] := + let Rops_wd := mk_reqe rplus rtimes ropp req + sor.(SORplus_wd) + sor.(SORtimes_wd) + sor.(SORopp_wd) in + PsubC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) + addon.(SORrm). + +Definition PaddC_ok : forall c P env, eval_pol env (paddC P c) == eval_pol env P + [c] := + let Rops_wd := mk_reqe rplus rtimes ropp req + sor.(SORplus_wd) + sor.(SORtimes_wd) + sor.(SORopp_wd) in + PaddC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) + addon.(SORrm). + + +(* Check that a formula f is inconsistent by normalizing and comparing the +resulting constant with 0 *) + +Definition check_inconsistent (f : NFormula) : bool := +let (e, op) := f in + match e with + | Pc c => + match op with + | Equal => cneqb c cO + | NonStrict => c [<] cO + | Strict => c [<=] cO + | NonEqual => c [=] cO + end + | _ => false (* not a constant *) + end. + +Lemma check_inconsistent_sound : + forall (p : PolC) (op : Op1), + check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pol env p). +Proof. +intros p op H1 env. unfold check_inconsistent in H1. +destruct op; simpl ; +(*****) +destruct p ; simpl; try discriminate H1; +try rewrite <- addon.(SORrm).(morph0); trivial. +now apply cneqb_sound. +apply addon.(SORrm).(morph_eq) in H1. congruence. +apply cleb_sound in H1. now apply -> (Rle_ngt sor). +apply cltb_sound in H1. now apply -> (Rlt_nge sor). +Qed. + +Definition check_normalised_formulas : list NFormula -> Psatz -> bool := + fun l cm => + match eval_Psatz l cm with + | None => false + | Some f => check_inconsistent f + end. + +Lemma checker_nf_sound : + forall (l : list NFormula) (cm : Psatz), + check_normalised_formulas l cm = true -> + forall env : PolEnv, make_impl (eval_nformula env) l False. +Proof. +intros l cm H env. +unfold check_normalised_formulas in H. +revert H. +case_eq (eval_Psatz l cm) ; [|discriminate]. +intros nf. intros. +rewrite <- make_conj_impl. intro. +assert (H1' := make_conj_in _ _ H1). +assert (Hnf := @eval_Psatz_Sound _ _ H1' _ _ H). +destruct nf. +apply (@check_inconsistent_sound _ _ H0 env Hnf). +Qed. + +(** Normalisation of formulae **) + +Inductive Op2 : Set := (* binary relations *) +| OpEq +| OpNEq +| OpLe +| OpGe +| OpLt +| OpGt. + +Definition eval_op2 (o : Op2) : R -> R -> Prop := +match o with +| OpEq => req +| OpNEq => fun x y : R => x ~= y +| OpLe => rle +| OpGe => fun x y : R => y <= x +| OpLt => fun x y : R => x < y +| OpGt => fun x y : R => y < x +end. + +Definition eval_pexpr (l : PolEnv) (pe : PExpr C) : R := PEeval rplus rtimes rminus ropp phi pow_phi rpow l pe. + +Record Formula : Type := { + Flhs : PExpr C; + Fop : Op2; + Frhs : PExpr C +}. + +Definition eval_formula (env : PolEnv) (f : Formula) : Prop := + let (lhs, op, rhs) := f in + (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs). + +(* We normalize Formulas by moving terms to one side *) + +Definition norm := norm_aux cO cI cplus ctimes cminus copp ceqb. + +Definition psub := Psub cO cplus cminus copp ceqb. + +Definition padd := Padd cO cplus ceqb. + +Definition normalise (f : Formula) : NFormula := +let (lhs, op, rhs) := f in + let lhs := norm lhs in + let rhs := norm rhs in + match op with + | OpEq => (psub lhs rhs, Equal) + | OpNEq => (psub lhs rhs, NonEqual) + | OpLe => (psub rhs lhs, NonStrict) + | OpGe => (psub lhs rhs, NonStrict) + | OpGt => (psub lhs rhs, Strict) + | OpLt => (psub rhs lhs, Strict) + end. + +Definition negate (f : Formula) : NFormula := +let (lhs, op, rhs) := f in + let lhs := norm lhs in + let rhs := norm rhs in + match op with + | OpEq => (psub rhs lhs, NonEqual) + | OpNEq => (psub rhs lhs, Equal) + | OpLe => (psub lhs rhs, Strict) (* e <= e' == ~ e > e' *) + | OpGe => (psub rhs lhs, Strict) + | OpGt => (psub rhs lhs, NonStrict) + | OpLt => (psub lhs rhs, NonStrict) + end. + + +Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs. +Proof. + intros. + apply (Psub_ok sor.(SORsetoid) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). +Qed. + +Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) == eval_pol env lhs + eval_pol env rhs. +Proof. + intros. + apply (Padd_ok sor.(SORsetoid) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). +Qed. + +Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env (norm lhs). +Proof. + intros. + apply (norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm) addon.(SORpower) ). +Qed. + + +Theorem normalise_sound : + forall (env : PolEnv) (f : Formula), + eval_formula env f -> eval_nformula env (normalise f). +Proof. +intros env f H; destruct f as [lhs op rhs]; simpl in *. +destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. +now apply <- (Rminus_eq_0 sor). +intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H. +now apply -> (Rle_le_minus sor). +now apply -> (Rle_le_minus sor). +now apply -> (Rlt_lt_minus sor). +now apply -> (Rlt_lt_minus sor). +Qed. + +Theorem negate_correct : + forall (env : PolEnv) (f : Formula), + eval_formula env f <-> ~ (eval_nformula env (negate f)). +Proof. +intros env f; destruct f as [lhs op rhs]; simpl. +destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. +symmetry. rewrite (Rminus_eq_0 sor). +split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)]. +rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor). +rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). +rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). +rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). +rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). +Qed. + +(** Another normalistion - this is used for cnf conversion **) + +Definition xnormalise (t:Formula) : list (NFormula) := + let (lhs,o,rhs) := t in + let lhs := norm lhs in + let rhs := norm rhs in + match o with + | OpEq => + (psub lhs rhs, Strict)::(psub rhs lhs , Strict)::nil + | OpNEq => (psub lhs rhs,Equal) :: nil + | OpGt => (psub rhs lhs,NonStrict) :: nil + | OpLt => (psub lhs rhs,NonStrict) :: nil + | OpGe => (psub rhs lhs , Strict) :: nil + | OpLe => (psub lhs rhs ,Strict) :: nil + end. + +Require Import Tauto. + +Definition cnf_normalise (t:Formula) : cnf (NFormula) := + List.map (fun x => x::nil) (xnormalise t). + + +Add Ring SORRing : sor.(SORrt). + +Lemma cnf_normalise_correct : forall env t, eval_cnf (eval_nformula env) (cnf_normalise t) -> eval_formula env t. +Proof. + unfold cnf_normalise, xnormalise ; simpl ; intros env t. + unfold eval_cnf. + destruct t as [lhs o rhs]; case_eq o ; simpl; + repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; + generalize (eval_pexpr env lhs); + generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros. + (**) + apply sor.(SORle_antisymm). + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + now rewrite <- (Rminus_eq_0 sor). + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. + rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. + rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. +Qed. + +Definition xnegate (t:Formula) : list (NFormula) := + let (lhs,o,rhs) := t in + let lhs := norm lhs in + let rhs := norm rhs in + match o with + | OpEq => (psub lhs rhs,Equal) :: nil + | OpNEq => (psub lhs rhs ,Strict)::(psub rhs lhs,Strict)::nil + | OpGt => (psub lhs rhs,Strict) :: nil + | OpLt => (psub rhs lhs,Strict) :: nil + | OpGe => (psub lhs rhs,NonStrict) :: nil + | OpLe => (psub rhs lhs,NonStrict) :: nil + end. + +Definition cnf_negate (t:Formula) : cnf (NFormula) := + List.map (fun x => x::nil) (xnegate t). + +Lemma cnf_negate_correct : forall env t, eval_cnf (eval_nformula env) (cnf_negate t) -> ~ eval_formula env t. +Proof. + unfold cnf_negate, xnegate ; simpl ; intros env t. + unfold eval_cnf. + destruct t as [lhs o rhs]; case_eq o ; simpl; + repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; + generalize (eval_pexpr env lhs); + generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; intuition. + (**) + apply H0. + rewrite H1 ; ring. + (**) + apply H1. + apply sor.(SORle_antisymm). + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. + (**) + apply H0. now rewrite (Rle_le_minus sor) in H1. + apply H0. now rewrite (Rle_le_minus sor) in H1. + apply H0. now rewrite (Rlt_lt_minus sor) in H1. + apply H0. now rewrite (Rlt_lt_minus sor) in H1. +Qed. + +Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). +Proof. + intros. + destruct d ; simpl. + generalize (eval_pol env p); intros. + destruct o ; simpl. + apply (Req_em sor r 0). + destruct (Req_em sor r 0) ; tauto. + rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto. + rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto. +Qed. + +(** Reverse transformation *) + +Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C := + match p with + | Pc c => PEc c + | Pinj j p => xdenorm (Pplus j jmp ) p + | PX p j q => PEadd + (PEmul (xdenorm jmp p) (PEpow (PEX _ jmp) (Npos j))) + (xdenorm (Psucc jmp) q) + end. + +Lemma xdenorm_correct : forall p i env, eval_pol (jump i env) p == eval_pexpr env (xdenorm (Psucc i) p). +Proof. + unfold eval_pol. + induction p. + simpl. reflexivity. + (* Pinj *) + simpl. + intros. + rewrite Pplus_succ_permute_r. + rewrite <- IHp. + symmetry. + rewrite Pplus_comm. + rewrite Pjump_Pplus. reflexivity. + (* PX *) + simpl. + intros. + rewrite <- IHp1. + rewrite <- IHp2. + unfold Env.tail , Env.hd. + rewrite <- Pjump_Pplus. + rewrite <- Pplus_one_succ_r. + unfold Env.nth. + unfold jump at 2. + rewrite Pplus_one_succ_l. + rewrite addon.(SORpower).(rpow_pow_N). + unfold pow_N. ring. +Qed. + +Definition denorm (p : Pol C) := xdenorm xH p. + +Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p). +Proof. + unfold denorm. + induction p. + reflexivity. + simpl. + rewrite <- Pplus_one_succ_r. + apply xdenorm_correct. + simpl. + intros. + rewrite IHp1. + unfold Env.tail. + rewrite xdenorm_correct. + change (Psucc xH) with 2%positive. + rewrite addon.(SORpower).(rpow_pow_N). + simpl. reflexivity. +Qed. + + +(** Some syntactic simplifications of expressions *) + + +Definition simpl_cone (e:Psatz) : Psatz := + match e with + | PsatzSquare t => + match t with + | Pc c => if ceqb cO c then PsatzZ else PsatzC (ctimes c c) + | _ => PsatzSquare t + end + | PsatzMulE t1 t2 => + match t1 , t2 with + | PsatzZ , x => PsatzZ + | x , PsatzZ => PsatzZ + | PsatzC c , PsatzC c' => PsatzC (ctimes c c') + | PsatzC p1 , PsatzMulE (PsatzC p2) x => PsatzMulE (PsatzC (ctimes p1 p2)) x + | PsatzC p1 , PsatzMulE x (PsatzC p2) => PsatzMulE (PsatzC (ctimes p1 p2)) x + | PsatzMulE (PsatzC p2) x , PsatzC p1 => PsatzMulE (PsatzC (ctimes p1 p2)) x + | PsatzMulE x (PsatzC p2) , PsatzC p1 => PsatzMulE (PsatzC (ctimes p1 p2)) x + | PsatzC x , PsatzAdd y z => PsatzAdd (PsatzMulE (PsatzC x) y) (PsatzMulE (PsatzC x) z) + | PsatzC c , _ => if ceqb cI c then t2 else PsatzMulE t1 t2 + | _ , PsatzC c => if ceqb cI c then t1 else PsatzMulE t1 t2 + | _ , _ => e + end + | PsatzAdd t1 t2 => + match t1 , t2 with + | PsatzZ , x => x + | x , PsatzZ => x + | x , y => PsatzAdd x y + end + | _ => e + end. + + + + +End Micromega. + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) \ No newline at end of file diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v new file mode 100644 index 00000000..b1d02176 --- /dev/null +++ b/plugins/micromega/Tauto.v @@ -0,0 +1,327 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* BFormula A + | A : A -> BFormula A + | Cj : BFormula A -> BFormula A -> BFormula A + | D : BFormula A-> BFormula A -> BFormula A + | N : BFormula A -> BFormula A + | I : BFormula A-> BFormula A-> BFormula A. + + Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop := + match f with + | TT => True + | FF => False + | A a => ev a + | X p => p + | Cj e1 e2 => (eval_f ev e1) /\ (eval_f ev e2) + | D e1 e2 => (eval_f ev e1) \/ (eval_f ev e2) + | N e => ~ (eval_f ev e) + | I f1 f2 => (eval_f ev f1) -> (eval_f ev f2) + end. + + + Lemma map_simpl : forall A B f l, @map A B f l = match l with + | nil => nil + | a :: l=> (f a) :: (@map A B f l) + end. + Proof. + destruct l ; reflexivity. + Qed. + + + + Section S. + + Variable Env : Type. + Variable Term : Type. + Variable eval : Env -> Term -> Prop. + Variable Term' : Type. + Variable eval' : Env -> Term' -> Prop. + + + + Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). + + + Definition clause := list Term'. + Definition cnf := list clause. + + Variable normalise : Term -> cnf. + Variable negate : Term -> cnf. + + + Definition tt : cnf := @nil clause. + Definition ff : cnf := cons (@nil Term') nil. + + + Definition or_clause_cnf (t:clause) (f:cnf) : cnf := + List.map (fun x => (t++x)) f. + + Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := + match f with + | nil => tt + | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') + end. + + + Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := + f1 ++ f2. + + Fixpoint xcnf (pol : bool) (f : BFormula Term) {struct f}: cnf := + match f with + | TT => if pol then tt else ff + | FF => if pol then ff else tt + | X p => if pol then ff else ff (* This is not complete - cannot negate any proposition *) + | A x => if pol then normalise x else negate x + | N e => xcnf (negb pol) e + | Cj e1 e2 => + (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) + | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) + | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) + end. + + Definition eval_cnf (env : Term' -> Prop) (f:cnf) := make_conj (fun cl => ~ make_conj env cl) f. + + + Lemma eval_cnf_app : forall env x y, eval_cnf (eval' env) (x++y) -> eval_cnf (eval' env) x /\ eval_cnf (eval' env) y. + Proof. + unfold eval_cnf. + intros. + rewrite make_conj_app in H ; auto. + Qed. + + + Lemma or_clause_correct : forall env t f, eval_cnf (eval' env) (or_clause_cnf t f) -> (~ make_conj (eval' env) t) \/ (eval_cnf (eval' env) f). + Proof. + unfold eval_cnf. + unfold or_clause_cnf. + induction f. + simpl. + intros ; right;auto. + (**) + rewrite map_simpl. + intros. + rewrite make_conj_cons in H. + destruct H as [HH1 HH2]. + generalize (IHf HH2) ; clear IHf ; intro. + destruct H. + left ; auto. + rewrite make_conj_cons. + destruct (not_make_conj_app _ _ _ (no_middle_eval' env) HH1). + tauto. + tauto. + Qed. + + Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf (eval' env) f -> eval_cnf (eval' env) (a::f). + Proof. + intros. + unfold eval_cnf in *. + rewrite make_conj_cons ; eauto. + Qed. + + Lemma or_cnf_correct : forall env f f', eval_cnf (eval' env) (or_cnf f f') -> (eval_cnf (eval' env) f) \/ (eval_cnf (eval' env) f'). + Proof. + induction f. + unfold eval_cnf. + simpl. + tauto. + (**) + intros. + simpl in H. + destruct (eval_cnf_app _ _ _ H). + clear H. + destruct (IHf _ H0). + destruct (or_clause_correct _ _ _ H1). + left. + apply eval_cnf_cons ; auto. + right ; auto. + right ; auto. + Qed. + + Variable normalise_correct : forall env t, eval_cnf (eval' env) (normalise t) -> eval env t. + + Variable negate_correct : forall env t, eval_cnf (eval' env) (negate t) -> ~ eval env t. + + + Lemma xcnf_correct : forall f pol env, eval_cnf (eval' env) (xcnf pol f) -> eval_f (eval env) (if pol then f else N f). + Proof. + induction f. + (* TT *) + unfold eval_cnf. + simpl. + destruct pol ; simpl ; auto. + (* FF *) + unfold eval_cnf. + destruct pol; simpl ; auto. + (* P *) + simpl. + destruct pol ; intros ;simpl. + unfold eval_cnf in H. + (* Here I have to drop the proposition *) + simpl in H. + tauto. + (* Here, I could store P in the clause *) + unfold eval_cnf in H;simpl in H. + tauto. + (* A *) + simpl. + destruct pol ; simpl. + intros. + apply normalise_correct ; auto. + (* A 2 *) + intros. + apply negate_correct ; auto. + auto. + (* Cj *) + destruct pol ; simpl. + (* pol = true *) + intros. + unfold and_cnf in H. + destruct (eval_cnf_app _ _ _ H). + clear H. + split. + apply (IHf1 _ _ H0). + apply (IHf2 _ _ H1). + (* pol = false *) + intros. + destruct (or_cnf_correct _ _ _ H). + generalize (IHf1 false env H0). + simpl. + tauto. + generalize (IHf2 false env H0). + simpl. + tauto. + (* D *) + simpl. + destruct pol. + (* pol = true *) + intros. + destruct (or_cnf_correct _ _ _ H). + generalize (IHf1 _ env H0). + simpl. + tauto. + generalize (IHf2 _ env H0). + simpl. + tauto. + (* pol = true *) + unfold and_cnf. + intros. + destruct (eval_cnf_app _ _ _ H). + clear H. + simpl. + generalize (IHf1 _ _ H0). + generalize (IHf2 _ _ H1). + simpl. + tauto. + (**) + simpl. + destruct pol ; simpl. + intros. + apply (IHf false) ; auto. + intros. + generalize (IHf _ _ H). + tauto. + (* I *) + simpl; intros. + destruct pol. + simpl. + intro. + destruct (or_cnf_correct _ _ _ H). + generalize (IHf1 _ _ H1). + simpl in *. + tauto. + generalize (IHf2 _ _ H1). + auto. + (* pol = false *) + unfold and_cnf in H. + simpl in H. + destruct (eval_cnf_app _ _ _ H). + generalize (IHf1 _ _ H0). + generalize (IHf2 _ _ H1). + simpl. + tauto. + Qed. + + + Variable Witness : Type. + Variable checker : list Term' -> Witness -> bool. + + Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval' env) t False. + + Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool := + match f with + | nil => true + | e::f => match l with + | nil => false + | c::l => match checker e c with + | true => cnf_checker f l + | _ => false + end + end + end. + + Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf (eval' env) t. + Proof. + unfold eval_cnf. + induction t. + (* bc *) + simpl. + auto. + (* ic *) + simpl. + destruct w. + intros ; discriminate. + case_eq (checker a w) ; intros ; try discriminate. + generalize (@checker_sound _ _ H env). + generalize (IHt _ H0 env) ; intros. + destruct t. + red ; intro. + rewrite <- make_conj_impl in H2. + tauto. + rewrite <- make_conj_impl in H2. + tauto. + Qed. + + + Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool := + cnf_checker (xcnf true f) w. + + Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (eval env) t. + Proof. + unfold tauto_checker. + intros. + change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)). + apply (xcnf_correct t true). + eapply cnf_checker_sound ; eauto. + Qed. + + + + +End S. + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v new file mode 100644 index 00000000..0a66fce3 --- /dev/null +++ b/plugins/micromega/VarMap.v @@ -0,0 +1,259 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t + | Node : t -> A -> t -> t . + + Fixpoint find (vm : t ) (p:positive) {struct vm} : A := + match vm with + | Empty => default + | Leaf i => i + | Node l e r => match p with + | xH => e + | xO p => find l p + | xI p => find r p + end + end. + + (* an off_map (a map with offset) offers the same functionalites as /plugins/setoid_ring/BinList.v - it is used in EnvRing.v *) +(* + Definition off_map := (option positive *t )%type. + + + + Definition jump (j:positive) (l:off_map ) := + let (o,m) := l in + match o with + | None => (Some j,m) + | Some j0 => (Some (j+j0)%positive,m) + end. + + Definition nth (n:positive) (l: off_map ) := + let (o,m) := l in + let idx := match o with + | None => n + | Some i => i + n + end%positive in + find idx m. + + + Definition hd (l:off_map) := nth xH l. + + + Definition tail (l:off_map ) := jump xH l. + + + Lemma psucc : forall p, (match p with + | xI y' => xO (Psucc y') + | xO y' => xI y' + | 1%positive => 2%positive + end) = (p+1)%positive. + Proof. + destruct p. + auto with zarith. + rewrite xI_succ_xO. + auto with zarith. + reflexivity. + Qed. + + Lemma jump_Pplus : forall i j l, + (jump (i + j) l) = (jump i (jump j l)). + Proof. + unfold jump. + destruct l. + destruct o. + rewrite Pplus_assoc. + reflexivity. + reflexivity. + Qed. + + Lemma jump_simpl : forall p l, + jump p l = + match p with + | xH => tail l + | xO p => jump p (jump p l) + | xI p => jump p (jump p (tail l)) + end. + Proof. + destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus. + (* xI p = p + p + 1 *) + rewrite xI_succ_xO. + rewrite Pplus_diag. + rewrite <- Pplus_one_succ_r. + reflexivity. + (* xO p = p + p *) + rewrite Pplus_diag. + reflexivity. + reflexivity. + Qed. + + Ltac jump_s := + repeat + match goal with + | |- context [jump xH ?e] => rewrite (jump_simpl xH) + | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p)) + | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p)) + end. + + Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l). + Proof. + unfold tail. + intros. + repeat rewrite <- jump_Pplus. + rewrite Pplus_comm. + reflexivity. + Qed. + + Lemma jump_Psucc : forall j l, + (jump (Psucc j) l) = (jump 1 (jump j l)). + Proof. + intros. + rewrite <- jump_Pplus. + rewrite Pplus_one_succ_r. + rewrite Pplus_comm. + reflexivity. + Qed. + + Lemma jump_Pdouble_minus_one : forall i l, + (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)). + Proof. + unfold tail. + intros. + repeat rewrite <- jump_Pplus. + rewrite <- Pplus_one_succ_r. + rewrite Psucc_o_double_minus_one_eq_xO. + rewrite Pplus_diag. + reflexivity. + Qed. + + Lemma jump_x0_tail : forall p l, jump (xO p) (tail l) = jump (xI p) l. + Proof. + intros. + jump_s. + repeat rewrite <- jump_Pplus. + reflexivity. + Qed. + + + Lemma nth_spec : forall p l, + nth p l = + match p with + | xH => hd l + | xO p => nth p (jump p l) + | xI p => nth p (jump p (tail l)) + end. + Proof. + unfold nth. + destruct l. + destruct o. + simpl. + rewrite psucc. + destruct p. + replace (p0 + xI p)%positive with ((p + (p0 + 1) + p))%positive. + reflexivity. + rewrite xI_succ_xO. + rewrite Pplus_one_succ_r. + rewrite <- Pplus_diag. + rewrite Pplus_comm. + symmetry. + rewrite (Pplus_comm p0). + rewrite <- Pplus_assoc. + rewrite (Pplus_comm 1)%positive. + rewrite <- Pplus_assoc. + reflexivity. + (**) + replace ((p0 + xO p))%positive with (p + p0 + p)%positive. + reflexivity. + rewrite <- Pplus_diag. + rewrite <- Pplus_assoc. + rewrite Pplus_comm. + rewrite Pplus_assoc. + reflexivity. + reflexivity. + simpl. + destruct p. + rewrite xI_succ_xO. + rewrite Pplus_one_succ_r. + rewrite <- Pplus_diag. + symmetry. + rewrite Pplus_comm. + rewrite Pplus_assoc. + reflexivity. + rewrite Pplus_diag. + reflexivity. + reflexivity. + Qed. + + + Lemma nth_jump : forall p l, nth p (tail l) = hd (jump p l). + Proof. + destruct l. + unfold tail. + unfold hd. + unfold jump. + unfold nth. + destruct o. + symmetry. + rewrite Pplus_comm. + rewrite <- Pplus_assoc. + rewrite (Pplus_comm p0). + reflexivity. + rewrite Pplus_comm. + reflexivity. + Qed. + + Lemma nth_Pdouble_minus_one : + forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). + Proof. + destruct l. + unfold tail. + unfold nth, jump. + destruct o. + rewrite ((Pplus_comm p)). + rewrite <- (Pplus_assoc p0). + rewrite Pplus_diag. + rewrite <- Psucc_o_double_minus_one_eq_xO. + rewrite Pplus_one_succ_r. + rewrite (Pplus_comm (Pdouble_minus_one p)). + rewrite Pplus_assoc. + rewrite (Pplus_comm p0). + reflexivity. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO. + rewrite Pplus_diag. + reflexivity. + Qed. + +*) + +End MakeVarMap. + diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v new file mode 100644 index 00000000..f27cd15e --- /dev/null +++ b/plugins/micromega/ZCoeff.v @@ -0,0 +1,173 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* R -> R. +Variable ropp : R -> R. +Variables req rle rlt : R -> R -> Prop. + +Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. + +Notation "0" := rO. +Notation "1" := rI. +Notation "x + y" := (rplus x y). +Notation "x * y " := (rtimes x y). +Notation "x - y " := (rminus x y). +Notation "- x" := (ropp x). +Notation "x == y" := (req x y). +Notation "x ~= y" := (~ req x y). +Notation "x <= y" := (rle x y). +Notation "x < y" := (rlt x y). + +Lemma req_refl : forall x, req x x. +Proof. + destruct sor.(SORsetoid). + apply Equivalence_Reflexive. +Qed. + +Lemma req_sym : forall x y, req x y -> req y x. +Proof. + destruct sor.(SORsetoid). + apply Equivalence_Symmetric. +Qed. + +Lemma req_trans : forall x y z, req x y -> req y z -> req x z. +Proof. + destruct sor.(SORsetoid). + apply Equivalence_Transitive. +Qed. + + +Add Relation R req + reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) + symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) + transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) +as sor_setoid. + +Add Morphism rplus with signature req ==> req ==> req as rplus_morph. +Proof. +exact sor.(SORplus_wd). +Qed. +Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. +Proof. +exact sor.(SORtimes_wd). +Qed. +Add Morphism ropp with signature req ==> req as ropp_morph. +Proof. +exact sor.(SORopp_wd). +Qed. +Add Morphism rle with signature req ==> req ==> iff as rle_morph. +Proof. +exact sor.(SORle_wd). +Qed. +Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. +Proof. +exact sor.(SORlt_wd). +Qed. +Add Morphism rminus with signature req ==> req ==> req as rminus_morph. +Proof. + exact (rminus_morph sor). +Qed. + +Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. +Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. + +Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp. + +Notation phi_pos := (gen_phiPOS 1 rplus rtimes). +Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes). + +Notation "[ x ]" := (gen_order_phi_Z x). + +Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req. +Proof. +constructor. +exact rplus_morph. +exact rtimes_morph. +exact ropp_morph. +Qed. + +Lemma Zring_morph : + ring_morph 0 1 rplus rtimes rminus ropp req + 0%Z 1%Z Zplus Zmult Zminus Zopp + Zeq_bool gen_order_phi_Z. +Proof. +exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)). +Qed. + +Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x. +Proof. +induction x as [x IH | x IH |]; simpl; +try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor); +try apply (Rlt_0_1 sor); assumption. +Qed. + +Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Psucc x) == 1 + phi_pos1 x. +Proof. +exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd + (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))). +Qed. + +Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y. +Proof. +intros x y H. pattern y; apply Plt_ind with x. +rewrite phi_pos1_succ; apply (Rlt_succ_r sor). +clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor). +assumption. +Qed. + +Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y]. +Proof. +unfold Zlt; intros x y H; +do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt)); +destruct x; destruct y; simpl in *; try discriminate. +apply phi_pos1_pos. +now apply clt_pos_morph. +apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. +apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. +apply phi_pos1_pos. +rewrite Pcompare_antisym in H; simpl in H. apply -> (Ropp_lt_mono sor). +now apply clt_pos_morph. +Qed. + +Lemma Zcleb_morph : forall x y : Z, Zle_bool x y = true -> [x] <= [y]. +Proof. +unfold Zle_bool; intros x y H. +case_eq (x ?= y)%Z; intro H1; rewrite H1 in H. +le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1. +le_less. now apply clt_morph. +discriminate. +Qed. + +Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y]. +Proof. +intros x y H. unfold Zeq_bool in H. +case_eq (Zcompare x y); intro H1; rewrite H1 in *; (discriminate || clear H). +apply (Rlt_neq sor). now apply clt_morph. +fold (x > y)%Z in H1. rewrite Zgt_iff_lt in H1. +apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph. +Qed. + +End InitialMorphism. + + diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v new file mode 100644 index 00000000..b02a9850 --- /dev/null +++ b/plugins/micromega/ZMicromega.v @@ -0,0 +1,1023 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* destruct (andb_prop _ _ id); clear id + | [ id : (_ || _)%bool = true |- _ ] => destruct (orb_prop _ _ id); clear id + end. + +Ltac inv H := inversion H ; try subst ; clear H. + + +Require Import EnvRing. + +Open Scope Z_scope. + +Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt. +Proof. + constructor ; intros ; subst ; try (intuition (auto with zarith)). + apply Zsth. + apply Zth. + destruct (Ztrichotomy n m) ; intuition (auto with zarith). + apply Zmult_lt_0_compat ; auto. +Qed. + +Lemma ZSORaddon : + SORaddon 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle (* ring elements *) + 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *) + Zeq_bool Zle_bool + (fun x => x) (fun x => x) (pow_N 1 Zmult). +Proof. + constructor. + constructor ; intros ; try reflexivity. + apply Zeq_bool_eq ; auto. + constructor. + reflexivity. + intros x y. + apply Zeq_bool_neq ; auto. + apply Zle_bool_imp_le. +Qed. + +Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z := + match e with + | PEc c => c + | PEX x => env x + | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2 + | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2 + | PEpow e1 n => Zpower (Zeval_expr env e1) (Z_of_N n) + | PEsub e1 e2 => (Zeval_expr env e1) - (Zeval_expr env e2) + | PEopp e => Zopp (Zeval_expr env e) + end. + +Definition eval_expr := eval_pexpr Zplus Zmult Zminus Zopp (fun x => x) (fun x => x) (pow_N 1 Zmult). + +Lemma ZNpower : forall r n, r ^ Z_of_N n = pow_N 1 Zmult r n. +Proof. + destruct n. + reflexivity. + simpl. + unfold Zpower_pos. + replace (pow_pos Zmult r p) with (1 * (pow_pos Zmult r p)) by ring. + generalize 1. + induction p; simpl ; intros ; repeat rewrite IHp ; ring. +Qed. + +Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = eval_expr env e. +Proof. + induction e ; simpl ; try congruence. + reflexivity. + rewrite ZNpower. congruence. +Qed. + +Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop := +match o with +| OpEq => @eq Z +| OpNEq => fun x y => ~ x = y +| OpLe => Zle +| OpGe => Zge +| OpLt => Zlt +| OpGt => Zgt +end. + +Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):= + let (lhs, op, rhs) := f in + (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs). + +Definition Zeval_formula' := + eval_formula Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult). + +Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f. +Proof. + destruct f ; simpl. + rewrite Zeval_expr_compat. rewrite Zeval_expr_compat. + unfold eval_expr. + generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Zmult) env Flhs). + generalize ((eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Zmult) env Frhs)). + destruct Fop ; simpl; intros ; intuition (auto with zarith). +Qed. + + +Definition eval_nformula := + eval_nformula 0 Zplus Zmult (@eq Z) Zle Zlt (fun x => x) . + +Definition Zeval_op1 (o : Op1) : Z -> Prop := +match o with +| Equal => fun x : Z => x = 0 +| NonEqual => fun x : Z => x <> 0 +| Strict => fun x : Z => 0 < x +| NonStrict => fun x : Z => 0 <= x +end. + + +Lemma Zeval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). +Proof. + intros. + apply (eval_nformula_dec Zsor). +Qed. + +Definition ZWitness := Psatz Z. + +Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zeq_bool Zle_bool. + +Lemma ZWeakChecker_sound : forall (l : list (NFormula Z)) (cm : ZWitness), + ZWeakChecker l cm = true -> + forall env, make_impl (eval_nformula env) l False. +Proof. + intros l cm H. + intro. + unfold eval_nformula. + apply (checker_nf_sound Zsor ZSORaddon l cm). + unfold ZWeakChecker in H. + exact H. +Qed. + +Definition psub := psub Z0 Zplus Zminus Zopp Zeq_bool. + +Definition padd := padd Z0 Zplus Zeq_bool. + +Definition norm := norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool. + +Definition eval_pol := eval_pol 0 Zplus Zmult (fun x => x). + +Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) = eval_pol env lhs - eval_pol env rhs. +Proof. + intros. + apply (eval_pol_sub Zsor ZSORaddon). +Qed. + +Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) = eval_pol env lhs + eval_pol env rhs. +Proof. + intros. + apply (eval_pol_add Zsor ZSORaddon). +Qed. + +Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (norm e) . +Proof. + intros. + apply (eval_pol_norm Zsor ZSORaddon). +Qed. + +Definition xnormalise (t:Formula Z) : list (NFormula Z) := + let (lhs,o,rhs) := t in + let lhs := norm lhs in + let rhs := norm rhs in + match o with + | OpEq => + ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil + | OpNEq => (psub lhs rhs,Equal) :: nil + | OpGt => (psub rhs lhs,NonStrict) :: nil + | OpLt => (psub lhs rhs,NonStrict) :: nil + | OpGe => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil + | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil + end. + +Require Import Tauto. + +Definition normalise (t:Formula Z) : cnf (NFormula Z) := + List.map (fun x => x::nil) (xnormalise t). + + +Lemma normalise_correct : forall env t, eval_cnf (eval_nformula env) (normalise t) <-> Zeval_formula env t. +Proof. + Opaque padd. + unfold normalise, xnormalise ; simpl; intros env t. + rewrite Zeval_formula_compat. + unfold eval_cnf. + destruct t as [lhs o rhs]; case_eq o; simpl; + repeat rewrite eval_pol_sub; + repeat rewrite eval_pol_add; + repeat rewrite <- eval_pol_norm ; simpl in *; + unfold eval_expr; + generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs); + generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst; + intuition (auto with zarith). + Transparent padd. +Qed. + +Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := + let (lhs,o,rhs) := t in + let lhs := norm lhs in + let rhs := norm rhs in + match o with + | OpEq => (psub lhs rhs,Equal) :: nil + | OpNEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil + | OpGt => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil + | OpLt => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil + | OpGe => (psub lhs rhs,NonStrict) :: nil + | OpLe => (psub rhs lhs,NonStrict) :: nil + end. + +Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) := + List.map (fun x => x::nil) (xnegate t). + +Lemma negate_correct : forall env t, eval_cnf (eval_nformula env) (negate t) <-> ~ Zeval_formula env t. +Proof. +Proof. + Opaque padd. + intros env t. + rewrite Zeval_formula_compat. + unfold negate, xnegate ; simpl. + unfold eval_cnf. + destruct t as [lhs o rhs]; case_eq o; simpl; + repeat rewrite eval_pol_sub; + repeat rewrite eval_pol_add; + repeat rewrite <- eval_pol_norm ; simpl in *; + unfold eval_expr; + generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs); + generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst; + intuition (auto with zarith). + Transparent padd. +Qed. + + + +Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool := + @tauto_checker (Formula Z) (NFormula Z) normalise negate ZWitness ZWeakChecker f w. + +(* To get a complete checker, the proof format has to be enriched *) + +Require Import Zdiv. +Open Scope Z_scope. + +Definition ceiling (a b:Z) : Z := + let (q,r) := Zdiv_eucl a b in + match r with + | Z0 => q + | _ => q + 1 + end. + +Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x >= b -> x >= ceiling b a. +Proof. + unfold ceiling. + intros. + generalize (Z_div_mod b a H). + destruct (Zdiv_eucl b a). + intros. + destruct H1. + destruct H2. + subst. + destruct (Ztrichotomy z0 0) as [ HH1 | [HH2 | HH3]]; destruct z0 ; try auto with zarith ; try discriminate. + assert (HH :x >= z \/ x < z) by (destruct (Ztrichotomy x z) ; auto with zarith). + destruct HH ;auto. + generalize (Zmult_lt_compat_l _ _ _ H3 H1). + auto with zarith. + clear H2. + assert (HH :x >= z +1 \/ x <= z) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)). + destruct HH ;auto. + assert (0 < a) by auto with zarith. + generalize (Zmult_lt_0_le_compat_r _ _ _ H2 H1). + intros. + rewrite Zmult_comm in H4. + rewrite (Zmult_comm z) in H4. + auto with zarith. +Qed. + +(** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *) + +Require Import QArith. + +Inductive ZArithProof : Type := +| DoneProof +| RatProof : ZWitness -> ZArithProof -> ZArithProof +| CutProof : ZWitness -> ZArithProof -> ZArithProof +| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof. + +(* n/d <= x -> d*x - n >= 0 *) +(* +Definition makeLb (v:PExpr Z) (q:Q) : NFormula Z := + let (n,d) := q in (PEsub (PEmul (PEc (Zpos d)) v) (PEc n),NonStrict). + +(* x <= n/d -> d * x <= d *) +Definition makeUb (v:PExpr Z) (q:Q) : NFormula Z := + let (n,d) := q in + (PEsub (PEc n) (PEmul (PEc (Zpos d)) v), NonStrict). + +Definition qceiling (q:Q) : Z := + let (n,d) := q in ceiling n (Zpos d). + +Definition qfloor (q:Q) : Z := + let (n,d) := q in Zdiv n (Zpos d). + +Definition makeLbCut (v:PExprC Z) (q:Q) : NFormula Z := + (PEsub v (PEc (qceiling q)), NonStrict). + +Definition neg_nformula (f : NFormula Z) := + let (e,o) := f in + (PEopp (PEadd e (PEc 1%Z)), o). + +Lemma neg_nformula_sound : forall env f, snd f = NonStrict ->( ~ (Zeval_nformula env (neg_nformula f)) <-> Zeval_nformula env f). +Proof. + unfold neg_nformula. + destruct f. + simpl. + intros ; subst ; simpl in *. + split; auto with zarith. +Qed. +*) + +(* In order to compute the 'cut', we need to express a polynomial P as a * Q + b. + - b is the constant + - a is the gcd of the other coefficient. +*) +Require Import Znumtheory. + +Definition isZ0 (x:Z) := + match x with + | Z0 => true + | _ => false + end. + +Lemma isZ0_0 : forall x, isZ0 x = true <-> x = 0. +Proof. + destruct x ; simpl ; intuition congruence. +Qed. + +Lemma isZ0_n0 : forall x, isZ0 x = false <-> x <> 0. +Proof. + destruct x ; simpl ; intuition congruence. +Qed. + +Definition ZgcdM (x y : Z) := Zmax (Zgcd x y) 1. + + +Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) := + match p with + | Pc c => (0,c) + | Pinj _ p => Zgcd_pol p + | PX p _ q => + let (g1,c1) := Zgcd_pol p in + let (g2,c2) := Zgcd_pol q in + (ZgcdM (ZgcdM g1 c1) g2 , c2) + end. + +(*Eval compute in (Zgcd_pol ((PX (Pc (-2)) 1 (Pc 4)))).*) + + +Fixpoint Zdiv_pol (p:PolC Z) (x:Z) : PolC Z := + match p with + | Pc c => Pc (Zdiv c x) + | Pinj j p => Pinj j (Zdiv_pol p x) + | PX p j q => PX (Zdiv_pol p x) j (Zdiv_pol q x) + end. + +Inductive Zdivide_pol (x:Z): PolC Z -> Prop := +| Zdiv_Pc : forall c, (x | c) -> Zdivide_pol x (Pc c) +| Zdiv_Pinj : forall p, Zdivide_pol x p -> forall j, Zdivide_pol x (Pinj j p) +| Zdiv_PX : forall p q, Zdivide_pol x p -> Zdivide_pol x q -> forall j, Zdivide_pol x (PX p j q). + + +Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p -> + forall env, eval_pol env p = a * eval_pol env (Zdiv_pol p a). +Proof. + intros until 2. + induction H0. + (* Pc *) + simpl. + intros. + apply Zdivide_Zdiv_eq ; auto. + (* Pinj *) + simpl. + intros. + apply IHZdivide_pol. + (* PX *) + simpl. + intros. + rewrite IHZdivide_pol1. + rewrite IHZdivide_pol2. + ring. +Qed. + +Lemma Zgcd_pol_ge : forall p, fst (Zgcd_pol p) >= 0. +Proof. + induction p. + simpl. auto with zarith. + simpl. auto. + simpl. + case_eq (Zgcd_pol p1). + case_eq (Zgcd_pol p3). + intros. + simpl. + unfold ZgcdM. + generalize (Zgcd_is_pos z1 z2). + generalize (Zmax_spec (Zgcd z1 z2) 1). + generalize (Zgcd_is_pos (Zmax (Zgcd z1 z2) 1) z). + generalize (Zmax_spec (Zgcd (Zmax (Zgcd z1 z2) 1) z) 1). + auto with zarith. +Qed. + +Lemma Zdivide_pol_Zdivide : forall p x y, Zdivide_pol x p -> (y | x) -> Zdivide_pol y p. +Proof. + intros. + induction H. + constructor. + apply Zdivide_trans with (1:= H0) ; assumption. + constructor. auto. + constructor ; auto. +Qed. + +Lemma Zdivide_pol_one : forall p, Zdivide_pol 1 p. +Proof. + induction p ; constructor ; auto. + exists c. ring. +Qed. + +Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Zgcd a b | c). +Proof. + intros a b c (q,Hq). + destruct (Zgcd_is_gcd a b) as [(a',Ha) (b',Hb) _]. + set (g:=Zgcd a b) in *; clearbody g. + exists (q * a' + b'). + symmetry in Hq. rewrite <- Zeq_plus_swap in Hq. + rewrite <- Hq, Hb, Ha. ring. +Qed. + +Lemma Zdivide_pol_sub : forall p a b, + 0 < Zgcd a b -> + Zdivide_pol a (PsubC Zminus p b) -> + Zdivide_pol (Zgcd a b) p. +Proof. + induction p. + simpl. + intros. inversion H0. + constructor. + apply Zgcd_minus ; auto. + intros. + constructor. + simpl in H0. inversion H0 ; subst; clear H0. + apply IHp ; auto. + simpl. intros. + inv H0. + constructor. + apply Zdivide_pol_Zdivide with (1:= H3). + destruct (Zgcd_is_gcd a b) ; assumption. + apply IHp2 ; assumption. +Qed. + +Lemma Zdivide_pol_sub_0 : forall p a, + Zdivide_pol a (PsubC Zminus p 0) -> + Zdivide_pol a p. +Proof. + induction p. + simpl. + intros. inversion H. + constructor. replace (c - 0) with c in H1 ; auto with zarith. + intros. + constructor. + simpl in H. inversion H ; subst; clear H. + apply IHp ; auto. + simpl. intros. + inv H. + constructor. auto. + apply IHp2 ; assumption. +Qed. + + +Lemma Zgcd_pol_div : forall p g c, + Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Zminus p c). +Proof. + induction p ; simpl. + (* Pc *) + intros. inv H. + constructor. + exists 0. now ring. + (* Pinj *) + intros. + constructor. apply IHp ; auto. + (* PX *) + intros g c. + case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros. + inv H1. + unfold ZgcdM at 1. + destruct (Zmax_spec (Zgcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1]; + destruct HH1 as [HH1 HH1'] ; rewrite HH1'. + constructor. + apply Zdivide_pol_Zdivide with (x:= ZgcdM z1 z2). + unfold ZgcdM. + destruct (Zmax_spec (Zgcd z1 z2) 1) as [HH2 | HH2]. + destruct HH2. + rewrite H2. + apply Zdivide_pol_sub ; auto. + auto with zarith. + destruct HH2. rewrite H2. + apply Zdivide_pol_one. + unfold ZgcdM in HH1. unfold ZgcdM. + destruct (Zmax_spec (Zgcd z1 z2) 1) as [HH2 | HH2]. + destruct HH2. rewrite H2 in *. + destruct (Zgcd_is_gcd (Zgcd z1 z2) z); auto. + destruct HH2. rewrite H2. + destruct (Zgcd_is_gcd 1 z); auto. + apply Zdivide_pol_Zdivide with (x:= z). + apply (IHp2 _ _ H); auto. + destruct (Zgcd_is_gcd (ZgcdM z1 z2) z); auto. + constructor. apply Zdivide_pol_one. + apply Zdivide_pol_one. +Qed. + + + + +Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Zminus p c) g)) + c. +Proof. + intros. + rewrite <- Zdiv_pol_correct ; auto. + rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). + unfold eval_pol. ring. + (**) + apply Zgcd_pol_div ; auto. +Qed. + + + +Definition makeCuttingPlane (p : PolC Z) : PolC Z * Z := + let (g,c) := Zgcd_pol p in + if Zgt_bool g Z0 + then (Zdiv_pol (PsubC Zminus p c) g , Zopp (ceiling (Zopp c) g)) + else (p,Z0). + + +Definition genCuttingPlane (f : NFormula Z) : option (PolC Z * Z * Op1) := + let (e,op) := f in + match op with + | Equal => let (g,c) := Zgcd_pol e in + if andb (Zgt_bool g Z0) (andb (Zgt_bool c Z0) (negb (Zeq_bool (Zgcd g c) g))) + then None (* inconsistent *) + else Some (e, Z0,op) (* It could still be inconsistent -- but not a cut *) + | NonEqual => Some (e,Z0,op) + | Strict => let (p,c) := makeCuttingPlane (PsubC Zminus e 1) in + Some (p,c,NonStrict) + | NonStrict => let (p,c) := makeCuttingPlane e in + Some (p,c,NonStrict) + end. + +Definition nformula_of_cutting_plane (t : PolC Z * Z * Op1) : NFormula Z := + let (e_z, o) := t in + let (e,z) := e_z in + (padd e (Pc z) , o). + +Definition is_pol_Z0 (p : PolC Z) : bool := + match p with + | Pc Z0 => true + | _ => false + end. + +Lemma is_pol_Z0_eval_pol : forall p, is_pol_Z0 p = true -> forall env, eval_pol env p = 0. +Proof. + unfold is_pol_Z0. + destruct p ; try discriminate. + destruct z ; try discriminate. + reflexivity. +Qed. + + + + + +Definition eval_Psatz : list (NFormula Z) -> ZWitness -> option (NFormula Z) := + eval_Psatz 0 1 Zplus Zmult Zeq_bool Zle_bool. + + +Definition check_inconsistent := check_inconsistent 0 Zeq_bool Zle_bool. + + + +Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := + match pf with + | DoneProof => false + | RatProof w pf => + match eval_Psatz l w with + | None => false + | Some f => + if check_inconsistent f then true + else ZChecker (f::l) pf + end + | CutProof w pf => + match eval_Psatz l w with + | None => false + | Some f => + match genCuttingPlane f with + | None => true + | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf + end + end + | EnumProof w1 w2 pf => + match eval_Psatz l w1 , eval_Psatz l w2 with + | Some f1 , Some f2 => + match genCuttingPlane f1 , genCuttingPlane f2 with + |Some (e1,z1,op1) , Some (e2,z2,op2) => + match op1 , op2 with + | NonStrict , NonStrict => + if is_pol_Z0 (padd e1 e2) + then + (fix label (pfs:list ZArithProof) := + fun lb ub => + match pfs with + | nil => if Zgt_bool lb ub then true else false + | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) + end) + pf (Zopp z1) z2 + else false + | _ , _ => false + end + | _ , _ => false + end + | _ , _ => false + end + end. + + + +Fixpoint bdepth (pf : ZArithProof) : nat := + match pf with + | DoneProof => O + | RatProof _ p => S (bdepth p) + | CutProof _ p => S (bdepth p) + | EnumProof _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x) O l) + end. + +Require Import Wf_nat. + +Lemma in_bdepth : forall l a b y, In y l -> ltof ZArithProof bdepth y (EnumProof a b l). +Proof. + induction l. + (* nil *) + simpl. + tauto. + (* cons *) + simpl. + intros. + destruct H. + subst. + unfold ltof. + simpl. + generalize ( (fold_right + (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat l)). + intros. + generalize (bdepth y) ; intros. + generalize (Max.max_l n0 n) (Max.max_r n0 n). + auto with zarith. + generalize (IHl a0 b y H). + unfold ltof. + simpl. + generalize ( (fold_right (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat + l)). + intros. + generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n). + auto with zarith. +Qed. + + +Lemma eval_Psatz_sound : forall env w l f', + make_conj (eval_nformula env) l -> + eval_Psatz l w = Some f' -> eval_nformula env f'. +Proof. + intros. + apply (eval_Psatz_Sound Zsor ZSORaddon) with (l:=l) (e:= w) ; auto. + apply make_conj_in ; auto. +Qed. + +Lemma makeCuttingPlane_sound : forall env e e' c, + eval_nformula env (e, NonStrict) -> + makeCuttingPlane e = (e',c) -> + eval_nformula env (nformula_of_cutting_plane (e', c, NonStrict)). +Proof. + unfold nformula_of_cutting_plane. + unfold eval_nformula. unfold RingMicromega.eval_nformula. + unfold eval_op1. + intros. + rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). + simpl. + (**) + unfold makeCuttingPlane in H0. + revert H0. + case_eq (Zgcd_pol e) ; intros g c0. + generalize (Zgt_cases g 0) ; destruct (Zgt_bool g 0). + intros. + inv H2. + change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in *. + apply Zgcd_pol_correct_lt with (env:=env) in H1. + generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Zminus e c0) g)) H0). + auto with zarith. + auto with zarith. + (* g <= 0 *) + intros. inv H2. auto with zarith. +Qed. + + +Lemma cutting_plane_sound : forall env f p, + eval_nformula env f -> + genCuttingPlane f = Some p -> + eval_nformula env (nformula_of_cutting_plane p). +Proof. + unfold genCuttingPlane. + destruct f as [e op]. + destruct op. + (* Equal *) + destruct p as [[e' z] op]. + case_eq (Zgcd_pol e) ; intros g c. + destruct (Zgt_bool g 0 && (Zgt_bool c 0 && negb (Zeq_bool (Zgcd g c) g))) ; [discriminate|]. + intros. inv H1. unfold nformula_of_cutting_plane. + unfold eval_nformula in *. + unfold RingMicromega.eval_nformula in *. + unfold eval_op1 in *. + rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). + simpl. rewrite H0. reflexivity. + (* NonEqual *) + intros. + inv H0. + unfold eval_nformula in *. + unfold RingMicromega.eval_nformula in *. + unfold nformula_of_cutting_plane. + unfold eval_op1 in *. + rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). + simpl. auto with zarith. + (* Strict *) + destruct p as [[e' z] op]. + case_eq (makeCuttingPlane (PsubC Zminus e 1)). + intros. + inv H1. + apply makeCuttingPlane_sound with (env:=env) (2:= H). + simpl in *. + rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). + auto with zarith. + (* NonStrict *) + destruct p as [[e' z] op]. + case_eq (makeCuttingPlane e). + intros. + inv H1. + apply makeCuttingPlane_sound with (env:=env) (2:= H). + assumption. +Qed. + +Lemma genCuttingPlaneNone : forall env f, + genCuttingPlane f = None -> + eval_nformula env f -> False. +Proof. + unfold genCuttingPlane. + destruct f. + destruct o. + case_eq (Zgcd_pol p) ; intros g c. + case_eq (Zgt_bool g 0 && (Zgt_bool c 0 && negb (Zeq_bool (Zgcd g c) g))). + intros. + flatten_bool. + rewrite negb_true_iff in H5. + apply Zeq_bool_neq in H5. + contradict H5. + rewrite <- Zgt_is_gt_bool in H3. + rewrite <- Zgt_is_gt_bool in H. + apply Zis_gcd_gcd; auto with zarith. + constructor; auto with zarith. + change (eval_pol env p = 0) in H2. + rewrite Zgcd_pol_correct_lt with (1:= H0) in H2; auto with zarith. + set (x:=eval_pol env (Zdiv_pol (PsubC Zminus p c) g)) in *; clearbody x. + exists (-x). + rewrite <- Zopp_mult_distr_l, Zmult_comm; auto with zarith. + (**) + discriminate. + discriminate. + destruct (makeCuttingPlane (PsubC Zminus p 1)) ; discriminate. + destruct (makeCuttingPlane p) ; discriminate. +Qed. + + +Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False. +Proof. + induction w using (well_founded_ind (well_founded_ltof _ bdepth)). + destruct w as [ | w pf | w pf | w1 w2 pf]. + (* DoneProof *) + simpl. discriminate. + (* RatProof *) + simpl. + intro l. case_eq (eval_Psatz l w) ; [| discriminate]. + intros f Hf. + case_eq (check_inconsistent f). + intros. + apply (checker_nf_sound Zsor ZSORaddon l w). + unfold check_normalised_formulas. unfold eval_Psatz in Hf. rewrite Hf. + unfold check_inconsistent in H0. assumption. + intros. + assert (make_impl (eval_nformula env) (f::l) False). + apply H with (2:= H1). + unfold ltof. + simpl. + auto with arith. + destruct f. + rewrite <- make_conj_impl in H2. + rewrite make_conj_cons in H2. + rewrite <- make_conj_impl. + intro. + apply H2. + split ; auto. + apply eval_Psatz_sound with (2:= Hf) ; assumption. + (* CutProof *) + simpl. + intro l. + case_eq (eval_Psatz l w) ; [ | discriminate]. + intros f' Hlc. + case_eq (genCuttingPlane f'). + intros. + assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False). + eapply (H pf) ; auto. + unfold ltof. + simpl. + auto with arith. + rewrite <- make_conj_impl in H2. + rewrite make_conj_cons in H2. + rewrite <- make_conj_impl. + intro. + apply H2. + split ; auto. + apply eval_Psatz_sound with (env:=env) in Hlc. + apply cutting_plane_sound with (1:= Hlc) (2:= H0). + auto. + (* genCuttingPlane = None *) + intros. + rewrite <- make_conj_impl. + intros. + apply eval_Psatz_sound with (2:= Hlc) in H2. + apply genCuttingPlaneNone with (2:= H2) ; auto. + (* EnumProof *) + intro. + simpl. + case_eq (eval_Psatz l w1) ; [ | discriminate]. + case_eq (eval_Psatz l w2) ; [ | discriminate]. + intros f1 Hf1 f2 Hf2. + case_eq (genCuttingPlane f2) ; [ | discriminate]. + destruct p as [ [p1 z1] op1]. + case_eq (genCuttingPlane f1) ; [ | discriminate]. + destruct p as [ [p2 z2] op2]. + case_eq op1 ; case_eq op2 ; try discriminate. + case_eq (is_pol_Z0 (padd p1 p2)) ; try discriminate. + intros. + (* get the bounds of the enum *) + rewrite <- make_conj_impl. + intro. + assert (-z1 <= eval_pol env p1 <= z2). + split. + apply eval_Psatz_sound with (env:=env) in Hf2 ; auto. + apply cutting_plane_sound with (1:= Hf2) in H4. + unfold nformula_of_cutting_plane in H4. + unfold eval_nformula in H4. + unfold RingMicromega.eval_nformula in H4. + change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H4. + unfold eval_op1 in H4. + rewrite eval_pol_add in H4. simpl in H4. + auto with zarith. + (**) + apply is_pol_Z0_eval_pol with (env := env) in H0. + rewrite eval_pol_add in H0. + replace (eval_pol env p1) with (- eval_pol env p2) by omega. + apply eval_Psatz_sound with (env:=env) in Hf1 ; auto. + apply cutting_plane_sound with (1:= Hf1) in H3. + unfold nformula_of_cutting_plane in H3. + unfold eval_nformula in H3. + unfold RingMicromega.eval_nformula in H3. + change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H3. + unfold eval_op1 in H3. + rewrite eval_pol_add in H3. simpl in H3. + omega. + revert H5. + set (FF := (fix label (pfs : list ZArithProof) (lb ub : Z) {struct pfs} : bool := + match pfs with + | nil => if Z_gt_dec lb ub then true else false + | pf :: rsr => + (ZChecker ((PsubC Zminus p1 lb, Equal) :: l) pf && + label rsr (lb + 1)%Z ub)%bool + end)). + intros. + assert (HH :forall x, -z1 <= x <= z2 -> exists pr, + (In pr pf /\ + ZChecker ((PsubC Zminus p1 x,Equal) :: l) pr = true)%Z). + clear H. + clear H0 H1 H2 H3 H4 H7. + revert H5. + generalize (-z1). clear z1. intro z1. + revert z1 z2. + induction pf;simpl ;intros. + generalize (Zgt_cases z1 z2). + destruct (Zgt_bool z1 z2). + intros. + apply False_ind ; omega. + discriminate. + flatten_bool. + assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega. + destruct HH. + subst. + exists a ; auto. + assert (z1 + 1 <= x <= z2)%Z by omega. + destruct (IHpf _ _ H1 _ H3). + destruct H4. + exists x0 ; split;auto. + (*/asser *) + destruct (HH _ H7) as [pr [Hin Hcheker]]. + assert (make_impl (eval_nformula env) ((PsubC Zminus p1 (eval_pol env p1),Equal) :: l) False). + apply (H pr);auto. + apply in_bdepth ; auto. + rewrite <- make_conj_impl in H8. + apply H8. + rewrite make_conj_cons. + split ;auto. + unfold eval_nformula. + unfold RingMicromega.eval_nformula. + simpl. + rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). + unfold eval_pol. ring. +Qed. + +Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ZArithProof): bool := + @tauto_checker (Formula Z) (NFormula Z) normalise negate ZArithProof ZChecker f w. + +Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (Zeval_formula env) f. +Proof. + intros f w. + unfold ZTautoChecker. + apply (tauto_checker_sound Zeval_formula eval_nformula). + apply Zeval_nformula_dec. + intros env t. + rewrite normalise_correct ; auto. + intros env t. + rewrite negate_correct ; auto. + intros t w0. + apply ZChecker_sound. +Qed. + +Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := + match pt with + | DoneProof => acc + | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt + | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt + | EnumProof c1 c2 l => + let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in + List.fold_left (xhyps_of_pt (S base)) l acc + end. + +Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. + + +(*Lemma hyps_of_pt_correct : forall pt l, *) + + + + + + +Open Scope Z_scope. + + +(** To ease bindings from ml code **) +(*Definition varmap := Quote.varmap.*) +Definition make_impl := Refl.make_impl. +Definition make_conj := Refl.make_conj. + +Require VarMap. + +(*Definition varmap_type := VarMap.t Z. *) +Definition env := PolEnv Z. +Definition node := @VarMap.Node Z. +Definition empty := @VarMap.Empty Z. +Definition leaf := @VarMap.Leaf Z. + +Definition coneMember := ZWitness. + +Definition eval := eval_formula. + +Definition prod_pos_nat := prod positive nat. + +Definition n_of_Z (z:Z) : BinNat.N := + match z with + | Z0 => N0 + | Zpos p => Npos p + | Zneg p => N0 + end. + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) + + diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml new file mode 100644 index 00000000..c5760229 --- /dev/null +++ b/plugins/micromega/certificate.ml @@ -0,0 +1,813 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ) = add_num +let (<->) = minus_num +let (<*>) = mult_num + +type var = Mc.positive + +module Monomial : +sig + type t + val const : t + val var : var -> t + val find : var -> t -> int + val mult : var -> t -> t + val prod : t -> t -> t + val compare : t -> t -> int + val pp : out_channel -> t -> unit + val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a +end + = +struct + (* A monomial is represented by a multiset of variables *) + module Map = Map.Make(struct type t = var let compare = Pervasives.compare end) + open Map + + type t = int Map.t + + (* The monomial that corresponds to a constant *) + let const = Map.empty + + (* The monomial 'x' *) + let var x = Map.add x 1 Map.empty + + (* Get the degre of a variable in a monomial *) + let find x m = try find x m with Not_found -> 0 + + (* Multiply a monomial by a variable *) + let mult x m = add x ( (find x m) + 1) m + + (* Product of monomials *) + let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 + + (* Total ordering of monomials *) + let compare m1 m2 = Map.compare Pervasives.compare m1 m2 + + let pp o m = Map.iter (fun k v -> + if v = 1 then Printf.fprintf o "x%i." (C2Ml.index k) + else Printf.fprintf o "x%i^%i." (C2Ml.index k) v) m + + let fold = fold + +end + + +module Poly : + (* A polynomial is a map of monomials *) + (* + This is probably a naive implementation + (expected to be fast enough - Coq is probably the bottleneck) + *The new ring contribution is using a sparse Horner representation. + *) +sig + type t + val get : Monomial.t -> t -> num + val variable : var -> t + val add : Monomial.t -> num -> t -> t + val constant : num -> t + val mult : Monomial.t -> num -> t -> t + val product : t -> t -> t + val addition : t -> t -> t + val uminus : t -> t + val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a + val pp : out_channel -> t -> unit + val compare : t -> t -> int + val is_null : t -> bool +end = +struct + (*normalisation bug : 0*x ... *) + module P = Map.Make(Monomial) + open P + + type t = num P.t + + let pp o p = P.iter (fun k v -> + if compare_num v (Int 0) <> 0 + then + if Monomial.compare Monomial.const k = 0 + then Printf.fprintf o "%s " (string_of_num v) + else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p + + (* Get the coefficient of monomial mn *) + let get : Monomial.t -> t -> num = + fun mn p -> try find mn p with Not_found -> (Int 0) + + + (* The polynomial 1.x *) + let variable : var -> t = + fun x -> add (Monomial.var x) (Int 1) empty + + (*The constant polynomial *) + let constant : num -> t = + fun c -> add (Monomial.const) c empty + + (* The addition of a monomial *) + + let add : Monomial.t -> num -> t -> t = + fun mn v p -> + let vl = (get mn p) <+> v in + add mn vl p + + + (** Design choice: empty is not a polynomial + I do not remember why .... + **) + + (* The product by a monomial *) + let mult : Monomial.t -> num -> t -> t = + fun mn v p -> + fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty + + + let addition : t -> t -> t = + fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 + + + let product : t -> t -> t = + fun p1 p2 -> + fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty + + + let uminus : t -> t = + fun p -> map (fun v -> minus_num v) p + + let fold = P.fold + + let is_null p = fold (fun mn vl b -> b & sign_num vl = 0) p true + + let compare = compare compare_num +end + +open Mutils +type 'a number_spec = { + bigint_to_number : big_int -> 'a; + number_to_num : 'a -> num; + zero : 'a; + unit : 'a; + mult : 'a -> 'a -> 'a; + eqb : 'a -> 'a -> bool +} + +let z_spec = { + bigint_to_number = Ml2C.bigint ; + number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); + zero = Mc.Z0; + unit = Mc.Zpos Mc.XH; + mult = Mc.zmult; + eqb = Mc.zeq_bool +} + + +let q_spec = { + bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); + number_to_num = C2Ml.q_to_num; + zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH}; + unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH}; + mult = Mc.qmult; + eqb = Mc.qeq_bool +} + +let r_spec = z_spec + + + + +let dev_form n_spec p = + let rec dev_form p = + match p with + | Mc.PEc z -> Poly.constant (n_spec.number_to_num z) + | Mc.PEX v -> Poly.variable v + | Mc.PEmul(p1,p2) -> + let p1 = dev_form p1 in + let p2 = dev_form p2 in + Poly.product p1 p2 + | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2) + | Mc.PEopp p -> Poly.uminus (dev_form p) + | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2)) + | Mc.PEpow(p,n) -> + let p = dev_form p in + let n = C2Ml.n n in + let rec pow n = + if n = 0 + then Poly.constant (n_spec.number_to_num n_spec.unit) + else Poly.product p (pow (n-1)) in + pow n in + dev_form p + + +let monomial_to_polynomial mn = + Monomial.fold + (fun v i acc -> + let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in + if acc = Mc.PEc (Mc.Zpos Mc.XH) + then mn + else Mc.PEmul(mn,acc)) + mn + (Mc.PEc (Mc.Zpos Mc.XH)) + +let list_to_polynomial vars l = + assert (List.for_all (fun x -> ceiling_num x =/ x) l); + let var x = monomial_to_polynomial (List.nth vars x) in + let rec xtopoly p i = function + | [] -> p + | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l + else let c = Mc.PEc (Ml2C.bigint (numerator c)) in + let mn = + if c = Mc.PEc (Mc.Zpos Mc.XH) + then var i + else Mc.PEmul (c,var i) in + let p' = if p = Mc.PEc Mc.Z0 then mn else + Mc.PEadd (mn, p) in + xtopoly p' (i+1) l in + + xtopoly (Mc.PEc Mc.Z0) 0 l + +let rec fixpoint f x = + let y' = f x in + if y' = x then y' + else fixpoint f y' + + + + + + + + +let rec_simpl_cone n_spec e = + let simpl_cone = + Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in + + let rec rec_simpl_cone = function + | Mc.PsatzMulE(t1, t2) -> + simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) + | Mc.PsatzAdd(t1,t2) -> + simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2)) + | x -> simpl_cone x in + rec_simpl_cone e + + +let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c + +type cone_prod = + Const of cone + | Ideal of cone *cone + | Mult of cone * cone + | Other of cone +and cone = Mc.zWitness + + + +let factorise_linear_cone c = + + let rec cone_list c l = + match c with + | Mc.PsatzAdd (x,r) -> cone_list r (x::l) + | _ -> c :: l in + + let factorise c1 c2 = + match c1 , c2 with + | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> + if x = x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None + | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> + if x = x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None + | _ -> None in + + let rec rebuild_cone l pending = + match l with + | [] -> (match pending with + | None -> Mc.PsatzZ + | Some p -> p + ) + | e::l -> + (match pending with + | None -> rebuild_cone l (Some e) + | Some p -> (match factorise p e with + | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e)) + | Some f -> rebuild_cone l (Some f) ) + ) in + + (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None) + + + +(* The binding with Fourier might be a bit obsolete + -- how does it handle equalities ? *) + +(* Certificates are elements of the cone such that P = 0 *) + +(* To begin with, we search for certificates of the form: + a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0 + where pi >= 0 qi > 0 + ai >= 0 + bi >= 0 + Sum bi + c >= 1 + This is a linear problem: each monomial is considered as a variable. + Hence, we can use fourier. + + The variable c is at index 0 +*) + +open Mfourier + (*module Fourier = Fourier(Vector.VList)(SysSet(Vector.VList))*) + (*module Fourier = Fourier(Vector.VSparse)(SysSetAlt(Vector.VSparse))*) +(*module Fourier = Mfourier.Fourier(Vector.VSparse)(*(SysSetAlt(Vector.VMap))*)*) + +(*module Vect = Fourier.Vect*) +(*open Fourier.Cstr*) + +(* fold_left followed by a rev ! *) + +let constrain_monomial mn l = + let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in + if mn = Monomial.const + then + { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; + op = Eq ; + cst = Big_int zero_big_int } + else + { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; + op = Eq ; + cst = Big_int zero_big_int } + + +let positivity l = + let rec xpositivity i l = + match l with + | [] -> [] + | (_,Mc.Equal)::l -> xpositivity (i+1) l + | (_,_)::l -> + {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; + op = Ge ; + cst = Int 0 } :: (xpositivity (i+1) l) + in + xpositivity 0 l + + +let string_of_op = function + | Mc.Strict -> "> 0" + | Mc.NonStrict -> ">= 0" + | Mc.Equal -> "= 0" + | Mc.NonEqual -> "<> 0" + + + +(* If the certificate includes at least one strict inequality, + the obtained polynomial can also be 0 *) +let build_linear_system l = + + (* Gather the monomials: HINT add up of the polynomials *) + let l' = List.map fst l in + let monomials = + List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l' + in (* For each monomial, compute a constraint *) + let s0 = + Poly.fold (fun mn _ res -> (constrain_monomial mn l')::res) monomials [] in + (* I need at least something strictly positive *) + let strict = { + coeffs = Vect.from_list ((Big_int unit_big_int):: + (List.map (fun (x,y) -> + match y with Mc.Strict -> + Big_int unit_big_int + | _ -> Big_int zero_big_int) l)); + op = Ge ; cst = Big_int unit_big_int } in + (* Add the positivity constraint *) + {coeffs = Vect.from_list ([Big_int unit_big_int]) ; + op = Ge ; + cst = Big_int zero_big_int}::(strict::(positivity l)@s0) + + +let big_int_to_z = Ml2C.bigint + +(* For Q, this is a pity that the certificate has been scaled + -- at a lower layer, certificates are using nums... *) +let make_certificate n_spec (cert,li) = + let bint_to_cst = n_spec.bigint_to_number in + match cert with + | [] -> failwith "empty_certificate" + | e::cert' -> + let cst = match compare_big_int e zero_big_int with + | 0 -> Mc.PsatzZ + | 1 -> Mc.PsatzC (bint_to_cst e) + | _ -> failwith "positivity error" + in + let rec scalar_product cert l = + match cert with + | [] -> Mc.PsatzZ + | c::cert -> match l with + | [] -> failwith "make_certificate(1)" + | i::l -> + let r = scalar_product cert l in + match compare_big_int c zero_big_int with + | -1 -> Mc.PsatzAdd ( + Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), + r) + | 0 -> r + | _ -> Mc.PsatzAdd ( + Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), + r) in + + ((factorise_linear_cone + (simplify_cone n_spec (Mc.PsatzAdd (cst, scalar_product cert' li))))) + + +exception Found of Monomial.t + +exception Strict + +let primal l = + let vr = ref 0 in + let module Mmn = Map.Make(Monomial) in + + let vect_of_poly map p = + Poly.fold (fun mn vl (map,vect) -> + if mn = Monomial.const + then (map,vect) + else + let (mn,m) = try (Mmn.find mn map,map) with Not_found -> let res = (!vr, Mmn.add mn !vr map) in incr vr ; res in + (m,if sign_num vl = 0 then vect else (mn,vl)::vect)) p (map,[]) in + + let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in + + let cmp x y = Pervasives.compare (fst x) (fst y) in + + snd (List.fold_right (fun (p,op) (map,l) -> + let (mp,vect) = vect_of_poly map p in + let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in + + (mp,cstr::l)) l (Mmn.empty,[])) + +let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = +(* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *) + + + let sys = build_linear_system l in + + try + match Fourier.find_point sys with + | Inr _ -> None + | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) + (* should not use rats_to_ints *) + with x -> + if debug + then (Printf.printf "raw certificate %s" (Printexc.to_string x); + flush stdout) ; + None + + +let raw_certificate l = + try + let p = primal l in + match Fourier.find_point p with + | Inr prf -> + if debug then Printf.printf "AProof : %a\n" pp_proof prf ; + let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in + if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; + Some (rats_to_ints (Vect.to_list cert)) + | Inl _ -> None + with Strict -> + (* Fourier elimination should handle > *) + dual_raw_certificate l + + +let simple_linear_prover (*to_constant*) l = + let (lc,li) = List.split l in + match raw_certificate lc with + | None -> None (* No certificate *) + | Some cert -> (* make_certificate to_constant*)Some (cert,li) + + + +let linear_prover n_spec l = + let li = List.combine l (interval 0 (List.length l -1)) in + let (l1,l') = List.partition + (fun (x,_) -> if snd x = Mc.NonEqual then true else false) li in + let l' = List.map + (fun ((x,y),i) -> match y with + Mc.NonEqual -> failwith "cannot happen" + | y -> ((dev_form n_spec x, y),i)) l' in + + simple_linear_prover (*n_spec*) l' + + +let linear_prover n_spec l = + try linear_prover n_spec l with + x -> (print_string (Printexc.to_string x); None) + +let linear_prover_with_cert spec l = + match linear_prover spec l with + | None -> None + | Some cert -> Some (make_certificate spec cert) + + + +(* zprover.... *) + +(* I need to gather the set of variables ---> + Then go for fold + Once I have an interval, I need a certificate : 2 other fourier elims. + (I could probably get the certificate directly + as it is done in the fourier contrib.) +*) + +let make_linear_system l = + let l' = List.map fst l in + let monomials = List.fold_left (fun acc p -> Poly.addition p acc) + (Poly.constant (Int 0)) l' in + let monomials = Poly.fold + (fun mn _ l -> if mn = Monomial.const then l else mn::l) monomials [] in + (List.map (fun (c,op) -> + {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ; + op = op ; + cst = minus_num ( (Poly.get Monomial.const c))}) l + ,monomials) + + +let pplus x y = Mc.PEadd(x,y) +let pmult x y = Mc.PEmul(x,y) +let pconst x = Mc.PEc x +let popp x = Mc.PEopp x + +let debug = false + +(* keep track of enumerated vectors *) +let rec mem p x l = + match l with [] -> false | e::l -> if p x e then true else mem p x l + +let rec remove_assoc p x l = + match l with [] -> [] | e::l -> if p x (fst e) then + remove_assoc p x l else e::(remove_assoc p x l) + +let eq x y = Vect.compare x y = 0 + +let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l + + +(* The prover is (probably) incomplete -- + only searching for naive cutting planes *) + +let candidates sys = + let ll = List.fold_right ( + fun (e,k) r -> + match k with + | Mc.NonStrict -> (dev_form z_spec e , Ge)::r + | Mc.Equal -> (dev_form z_spec e , Eq)::r + (* we already know the bound -- don't compute it again *) + | _ -> failwith "Cannot happen candidates") sys [] in + + let (sys,var_mn) = make_linear_system ll in + let vars = mapi (fun _ i -> Vect.set i (Int 1) Vect.null) var_mn in + (List.fold_left (fun l cstr -> + let gcd = Big_int (Vect.gcd cstr.coeffs) in + if gcd =/ (Int 1) && cstr.op = Eq + then l + else (Vect.mul (Int 1 // gcd) cstr.coeffs)::l) [] sys) @ vars + + + + +let rec xzlinear_prover planes sys = + match linear_prover z_spec sys with + | Some prf -> Some (Mc.RatProof (make_certificate z_spec prf,Mc.DoneProof)) + | None -> (* find the candidate with the smallest range *) + (* Grrr - linear_prover is also calling 'make_linear_system' *) + let ll = List.fold_right (fun (e,k) r -> match k with + Mc.NonEqual -> r + | k -> (dev_form z_spec e , + match k with + Mc.NonStrict -> Ge + | Mc.Equal -> Eq + | Mc.Strict | Mc.NonEqual -> failwith "Cannot happen") :: r) sys [] in + let (ll,var) = make_linear_system ll in + let candidates = List.fold_left (fun acc vect -> + match Fourier.optimise vect ll with + | None -> acc + | Some i -> +(* Printf.printf "%s in %s\n" (Vect.string vect) (string_of_intrvl i) ; *) + flush stdout ; + (vect,i) ::acc) [] planes in + + let smallest_interval = + match List.fold_left (fun (x1,i1) (x2,i2) -> + if Itv.smaller_itv i1 i2 + then (x1,i1) else (x2,i2)) (Vect.null,(None,None)) candidates + with + | (x,(Some i, Some j)) -> Some(i,x,j) + | x -> None (* This might be a cutting plane *) + in + match smallest_interval with + | Some (lb,e,ub) -> + let (lbn,lbd) = + (Ml2C.bigint (sub_big_int (numerator lb) unit_big_int), + Ml2C.bigint (denominator lb)) in + let (ubn,ubd) = + (Ml2C.bigint (add_big_int unit_big_int (numerator ub)) , + Ml2C.bigint (denominator ub)) in + let expr = list_to_polynomial var (Vect.to_list e) in + (match + (*x <= ub -> x > ub *) + linear_prover z_spec + ((pplus (pmult (pconst ubd) expr) (popp (pconst ubn)), + Mc.NonStrict) :: sys), + (* lb <= x -> lb > x *) + linear_prover z_spec + ((pplus (popp (pmult (pconst lbd) expr)) (pconst lbn), + Mc.NonStrict)::sys) + with + | Some cub , Some clb -> + (match zlinear_enum (remove e planes) expr + (ceiling_num lb) (floor_num ub) sys + with + | None -> None + | Some prf -> + let bound_proof (c,l) = make_certificate z_spec (List.tl c , List.tl (List.map (fun x -> x -1) l)) in + + Some (Mc.EnumProof((*Ml2C.q lb,expr,Ml2C.q ub,*) bound_proof clb, bound_proof cub,prf))) + | _ -> None + ) + | _ -> None +and zlinear_enum planes expr clb cub l = + if clb >/ cub + then Some [] + else + let pexpr = pplus (popp (pconst (Ml2C.bigint (numerator clb)))) expr in + let sys' = (pexpr, Mc.Equal)::l in + (*let enum = *) + match xzlinear_prover planes sys' with + | None -> if debug then print_string "zlp?"; None + | Some prf -> if debug then print_string "zlp!"; + match zlinear_enum planes expr (clb +/ (Int 1)) cub l with + | None -> None + | Some prfl -> Some (prf :: prfl) + +let zlinear_prover sys = + let candidates = candidates sys in + (* Printf.printf "candidates %d" (List.length candidates) ; *) + (*let t0 = Sys.time () in*) + let res = xzlinear_prover candidates sys in + (*Printf.printf "Time prover : %f" (Sys.time () -. t0) ;*) res + +open Sos_types +open Mutils + +let rec scale_term t = + match t with + | Zero -> unit_big_int , Zero + | Const n -> (denominator n) , Const (Big_int (numerator n)) + | Var n -> unit_big_int , Var n + | Inv _ -> failwith "scale_term : not implemented" + | Opp t -> let s, t = scale_term t in s, Opp t + | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in + let g = gcd_big_int s1 s2 in + let s1' = div_big_int s1 g in + let s2' = div_big_int s2 g in + let e = mult_big_int g (mult_big_int s1' s2') in + if (compare_big_int e unit_big_int) = 0 + then (unit_big_int, Add (y1,y2)) + else e, Add (Mul(Const (Big_int s2'), y1), + Mul (Const (Big_int s1'), y2)) + | Sub _ -> failwith "scale term: not implemented" + | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in + mult_big_int s1 s2 , Mul (y1, y2) + | Pow(t,n) -> let s,t = scale_term t in + power_big_int_positive_int s n , Pow(t,n) + | _ -> failwith "scale_term : not implemented" + +let scale_term t = + let (s,t') = scale_term t in + s,t' + + +let get_index_of_ith_match f i l = + let rec get j res l = + match l with + | [] -> failwith "bad index" + | e::l -> if f e + then + (if j = i then res else get (j+1) (res+1) l ) + else get j (res+1) l in + get 0 0 l + + +let rec scale_certificate pos = match pos with + | Axiom_eq i -> unit_big_int , Axiom_eq i + | Axiom_le i -> unit_big_int , Axiom_le i + | Axiom_lt i -> unit_big_int , Axiom_lt i + | Monoid l -> unit_big_int , Monoid l + | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) + | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) + | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) + | Square t -> let s,t' = scale_term t in + mult_big_int s s , Square t' + | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in + mult_big_int s1 s2 , Eqmul (y1,y2) + | Sum (y, z) -> let s1,y1 = scale_certificate y + and s2,y2 = scale_certificate z in + let g = gcd_big_int s1 s2 in + let s1' = div_big_int s1 g in + let s2' = div_big_int s2 g in + mult_big_int g (mult_big_int s1' s2'), + Sum (Product(Rational_le (Big_int s2'), y1), + Product (Rational_le (Big_int s1'), y2)) + | Product (y, z) -> + let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in + mult_big_int s1 s2 , Product (y1,y2) + + +open Micromega + let rec term_to_q_expr = function + | Const n -> PEc (Ml2C.q n) + | Zero -> PEc ( Ml2C.q (Int 0)) + | Var s -> PEX (Ml2C.index + (int_of_string (String.sub s 1 (String.length s - 1)))) + | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) + | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) + | Opp p -> PEopp (term_to_q_expr p) + | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n) + | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2) + | _ -> failwith "term_to_q_expr: not implemented" + + let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e) + + + let rec product l = + match l with + | [] -> Mc.PsatzZ + | [i] -> Mc.PsatzIn (Ml2C.nat i) + | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) + + +let q_cert_of_pos pos = + let rec _cert_of_pos = function + Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) + | Monoid l -> product l + | Rational_eq n | Rational_le n | Rational_lt n -> + if compare_num n (Int 0) = 0 then Mc.PsatzZ else + Mc.PsatzC (Ml2C.q n) + | Square t -> Mc.PsatzSquare (term_to_q_pol t) + | Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y) + | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) + | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in + simplify_cone q_spec (_cert_of_pos pos) + + + let rec term_to_z_expr = function + | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) + | Zero -> PEc ( Z0) + | Var s -> PEX (Ml2C.index + (int_of_string (String.sub s 1 (String.length s - 1)))) + | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2) + | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2) + | Opp p -> PEopp (term_to_z_expr p) + | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n) + | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2) + | _ -> failwith "term_to_z_expr: not implemented" + + let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.zplus Mc.zmult Mc.zminus Mc.zopp Mc.zeq_bool (term_to_z_expr e) + +let z_cert_of_pos pos = + let s,pos = (scale_certificate pos) in + let rec _cert_of_pos = function + Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) + | Monoid l -> product l + | Rational_eq n | Rational_le n | Rational_lt n -> + if compare_num n (Int 0) = 0 then Mc.PsatzZ else + Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) + | Square t -> Mc.PsatzSquare (term_to_z_pol t) + | Eqmul (t, y) -> Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y) + | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) + | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in + simplify_cone z_spec (_cert_of_pos pos) + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml new file mode 100644 index 00000000..abe4b368 --- /dev/null +++ b/plugins/micromega/coq_micromega.ml @@ -0,0 +1,1710 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ,=,<>,<=,>=} pExpr2 + * where pExpr1, pExpr2 are polynomial expressions (see Micromega). pExprs are + * parametrized by 'cst, which is used as the type of constants. + *) + +type 'cst atom = 'cst Micromega.formula + +(** + * Micromega's encoding of formulas. + * By order of appearance: boolean constants, variables, atoms, conjunctions, + * disjunctions, negation, implication. + *) + +type 'cst formula = + | TT + | FF + | X of Term.constr + | A of 'cst atom * tag * Term.constr + | C of 'cst formula * 'cst formula + | D of 'cst formula * 'cst formula + | N of 'cst formula + | I of 'cst formula * Names.identifier option * 'cst formula + +(** + * Formula pretty-printer. + *) + +let rec pp_formula o f = + match f with + | TT -> output_string o "tt" + | FF -> output_string o "ff" + | X c -> output_string o "X " + | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t + | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 + | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 + | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" + pp_formula f1 + (match n with + | Some id -> Names.string_of_id id + | None -> "") pp_formula f2 + | N(f) -> Printf.fprintf o "N(%a)" pp_formula f + +(** + * Collect the identifiers of a (string of) implications. Implication labels + * are inherited from Coq/CoC's higher order dependent type constructor (Pi). + *) + +let rec ids_of_formula f = + match f with + | I(f1,Some id,f2) -> id::(ids_of_formula f2) + | _ -> [] + +(** + * A clause is a list of (tagged) nFormulas. + * nFormulas are normalized formulas, i.e., of the form: + * cPol {=,<>,>,>=} 0 + * with cPol compact polynomials (see the Pol inductive type in EnvRing.v). + *) + +type 'cst clause = ('cst Micromega.nFormula * tag) list + +(** + * A CNF is a list of clauses. + *) + +type 'cst cnf = ('cst clause) list + +(** + * True and False are empty cnfs and clauses. + *) + +let tt : 'cst cnf = [] + +let ff : 'cst cnf = [ [] ] + +(** + * A refinement of cnf with tags left out. This is an intermediary form + * between the cnf tagged list representation ('cst cnf) used to solve psatz, + * and the freeform formulas ('cst formula) that is retrieved from Coq. + *) + +type 'cst mc_cnf = ('cst Micromega.nFormula) list list + +(** + * From a freeform formula, build a cnf. + * The parametric functions negate and normalize are theory-dependent, and + * originate in micromega.ml (extracted, e.g. for rnegate, from RMicromega.v + * and RingMicromega.v). + *) + +let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (f:'cst formula) = + let negate a t = + List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in + + let normalise a t = + List.map (fun cl -> List.map (fun x -> (x,t)) cl) (normalise a) in + + let and_cnf x y = x @ y in + + let or_clause_cnf t f = List.map (fun x -> t@x) f in + + let rec or_cnf f f' = + match f with + | [] -> tt + | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') in + + let rec xcnf (polarity : bool) f = + match f with + | TT -> if polarity then tt else ff + | FF -> if polarity then ff else tt + | X p -> if polarity then ff else ff + | A(x,t,_) -> if polarity then normalise x t else negate x t + | N(e) -> xcnf (not polarity) e + | C(e1,e2) -> + (if polarity then and_cnf else or_cnf) (xcnf polarity e1) (xcnf polarity e2) + | D(e1,e2) -> + (if polarity then or_cnf else and_cnf) (xcnf polarity e1) (xcnf polarity e2) + | I(e1,_,e2) -> + (if polarity then or_cnf else and_cnf) (xcnf (not polarity) e1) (xcnf polarity e2) in + + xcnf true f + +(** + * MODULE: Ordered set of integers. + *) + +module ISet = Set.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end) + +(** + * Given a set of integers s={i0,...,iN} and a list m, return the list of + * elements of m that are at position i0,...,iN. + *) + +let selecti s m = + let rec xselecti i m = + match m with + | [] -> [] + | e::m -> if ISet.mem i s then e::(xselecti (i+1) m) else xselecti (i+1) m in + xselecti 0 m + +(** + * MODULE: Mapping of the Coq data-strustures into Caml and Caml extracted + * code. This includes initializing Caml variables based on Coq terms, parsing + * various Coq expressions into Caml, and dumping Caml expressions into Coq. + * + * Opened here and in csdpcert.ml. + *) + +module M = +struct + + open Coqlib + open Term + + (** + * Location of the Coq libraries. + *) + + let logic_dir = ["Coq";"Logic";"Decidable"] + let coq_modules = + init_modules @ + [logic_dir] @ arith_modules @ zarith_base_modules @ + [ ["Coq";"Lists";"List"]; + ["ZMicromega"]; + ["Tauto"]; + ["RingMicromega"]; + ["EnvRing"]; + ["Coq"; "micromega"; "ZMicromega"]; + ["Coq" ; "micromega" ; "Tauto"]; + ["Coq" ; "micromega" ; "RingMicromega"]; + ["Coq" ; "micromega" ; "EnvRing"]; + ["Coq";"QArith"; "QArith_base"]; + ["Coq";"Reals" ; "Rdefinitions"]; + ["Coq";"Reals" ; "Rpow_def"]; + ["LRing_normalise"]] + + (** + * Initialization : a large amount of Caml symbols are derived from + * ZMicromega.v + *) + + let init_constant = gen_constant_in_modules "ZMicromega" init_modules + let constant = gen_constant_in_modules "ZMicromega" coq_modules + (* let constant = gen_constant_in_modules "Omicron" coq_modules *) + + let coq_and = lazy (init_constant "and") + let coq_or = lazy (init_constant "or") + let coq_not = lazy (init_constant "not") + let coq_iff = lazy (init_constant "iff") + let coq_True = lazy (init_constant "True") + let coq_False = lazy (init_constant "False") + + let coq_cons = lazy (constant "cons") + let coq_nil = lazy (constant "nil") + let coq_list = lazy (constant "list") + + let coq_O = lazy (init_constant "O") + let coq_S = lazy (init_constant "S") + let coq_nat = lazy (init_constant "nat") + + let coq_NO = lazy + (gen_constant_in_modules "N" [ ["Coq";"NArith";"BinNat" ]] "N0") + let coq_Npos = lazy + (gen_constant_in_modules "N" [ ["Coq";"NArith"; "BinNat"]] "Npos") + (* let coq_n = lazy (constant "N")*) + + let coq_pair = lazy (constant "pair") + let coq_None = lazy (constant "None") + let coq_option = lazy (constant "option") + let coq_positive = lazy (constant "positive") + let coq_xH = lazy (constant "xH") + let coq_xO = lazy (constant "xO") + let coq_xI = lazy (constant "xI") + + let coq_N0 = lazy (constant "N0") + let coq_N0 = lazy (constant "Npos") + + let coq_Z = lazy (constant "Z") + let coq_Q = lazy (constant "Q") + let coq_R = lazy (constant "R") + + let coq_ZERO = lazy (constant "Z0") + let coq_POS = lazy (constant "Zpos") + let coq_NEG = lazy (constant "Zneg") + + let coq_Build_Witness = lazy (constant "Build_Witness") + + let coq_Qmake = lazy (constant "Qmake") + let coq_R0 = lazy (constant "R0") + let coq_R1 = lazy (constant "R1") + + let coq_proofTerm = lazy (constant "ZArithProof") + let coq_doneProof = lazy (constant "DoneProof") + let coq_ratProof = lazy (constant "RatProof") + let coq_cutProof = lazy (constant "CutProof") + let coq_enumProof = lazy (constant "EnumProof") + + let coq_Zgt = lazy (constant "Zgt") + let coq_Zge = lazy (constant "Zge") + let coq_Zle = lazy (constant "Zle") + let coq_Zlt = lazy (constant "Zlt") + let coq_Eq = lazy (init_constant "eq") + + let coq_Zplus = lazy (constant "Zplus") + let coq_Zminus = lazy (constant "Zminus") + let coq_Zopp = lazy (constant "Zopp") + let coq_Zmult = lazy (constant "Zmult") + let coq_Zpower = lazy (constant "Zpower") + + let coq_Qgt = lazy (constant "Qgt") + let coq_Qge = lazy (constant "Qge") + let coq_Qle = lazy (constant "Qle") + let coq_Qlt = lazy (constant "Qlt") + let coq_Qeq = lazy (constant "Qeq") + + let coq_Qplus = lazy (constant "Qplus") + let coq_Qminus = lazy (constant "Qminus") + let coq_Qopp = lazy (constant "Qopp") + let coq_Qmult = lazy (constant "Qmult") + let coq_Qpower = lazy (constant "Qpower") + + let coq_Rgt = lazy (constant "Rgt") + let coq_Rge = lazy (constant "Rge") + let coq_Rle = lazy (constant "Rle") + let coq_Rlt = lazy (constant "Rlt") + + let coq_Rplus = lazy (constant "Rplus") + let coq_Rminus = lazy (constant "Rminus") + let coq_Ropp = lazy (constant "Ropp") + let coq_Rmult = lazy (constant "Rmult") + let coq_Rpower = lazy (constant "pow") + + let coq_PEX = lazy (constant "PEX" ) + let coq_PEc = lazy (constant"PEc") + let coq_PEadd = lazy (constant "PEadd") + let coq_PEopp = lazy (constant "PEopp") + let coq_PEmul = lazy (constant "PEmul") + let coq_PEsub = lazy (constant "PEsub") + let coq_PEpow = lazy (constant "PEpow") + + let coq_PX = lazy (constant "PX" ) + let coq_Pc = lazy (constant"Pc") + let coq_Pinj = lazy (constant "Pinj") + + let coq_OpEq = lazy (constant "OpEq") + let coq_OpNEq = lazy (constant "OpNEq") + let coq_OpLe = lazy (constant "OpLe") + let coq_OpLt = lazy (constant "OpLt") + let coq_OpGe = lazy (constant "OpGe") + let coq_OpGt = lazy (constant "OpGt") + + let coq_PsatzIn = lazy (constant "PsatzIn") + let coq_PsatzSquare = lazy (constant "PsatzSquare") + let coq_PsatzMulE = lazy (constant "PsatzMulE") + let coq_PsatzMultC = lazy (constant "PsatzMulC") + let coq_PsatzAdd = lazy (constant "PsatzAdd") + let coq_PsatzC = lazy (constant "PsatzC") + let coq_PsatzZ = lazy (constant "PsatzZ") + let coq_coneMember = lazy (constant "coneMember") + + let coq_make_impl = lazy + (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl") + let coq_make_conj = lazy + (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj") + + let coq_TT = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") + let coq_FF = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF") + let coq_And = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj") + let coq_Or = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D") + let coq_Neg = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N") + let coq_Atom = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A") + let coq_X = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X") + let coq_Impl = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I") + let coq_Formula = lazy + (gen_constant_in_modules "ZMicromega" + [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula") + + (** + * Initialization : a few Caml symbols are derived from other libraries; + * QMicromega, ZArithRing, RingMicromega. + *) + + let coq_QWitness = lazy + (gen_constant_in_modules "QMicromega" + [["Coq"; "micromega"; "QMicromega"]] "QWitness") + let coq_ZWitness = lazy + (gen_constant_in_modules "QMicromega" + [["Coq"; "micromega"; "ZMicromega"]] "ZWitness") + + let coq_N_of_Z = lazy + (gen_constant_in_modules "ZArithRing" + [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z") + + let coq_Build = lazy + (gen_constant_in_modules "RingMicromega" + [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] + "Build_Formula") + let coq_Cstr = lazy + (gen_constant_in_modules "RingMicromega" + [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula") + + (** + * Parsing and dumping : transformation functions between Caml and Coq + * data-structures. + * + * dump_* functions go from Micromega to Coq terms + * parse_* functions go from Coq to Micromega terms + * pp_* functions pretty-print Coq terms. + *) + + (* Error datastructures *) + + type parse_error = + | Ukn + | BadStr of string + | BadNum of int + | BadTerm of Term.constr + | Msg of string + | Goal of (Term.constr list ) * Term.constr * parse_error + + let string_of_error = function + | Ukn -> "ukn" + | BadStr s -> s + | BadNum i -> string_of_int i + | BadTerm _ -> "BadTerm" + | Msg s -> s + | Goal _ -> "Goal" + + exception ParseError + + (* A simple but useful getter function *) + + let get_left_construct term = + match Term.kind_of_term term with + | Term.Construct(_,i) -> (i,[| |]) + | Term.App(l,rst) -> + (match Term.kind_of_term l with + | Term.Construct(_,i) -> (i,rst) + | _ -> raise ParseError + ) + | _ -> raise ParseError + + (* Access the Micromega module *) + + module Mc = Micromega + + (* parse/dump/print from numbers up to expressions and formulas *) + + let rec parse_nat term = + let (i,c) = get_left_construct term in + match i with + | 1 -> Mc.O + | 2 -> Mc.S (parse_nat (c.(0))) + | i -> raise ParseError + + let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n) + + let rec dump_nat x = + match x with + | Mc.O -> Lazy.force coq_O + | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |]) + + let rec parse_positive term = + let (i,c) = get_left_construct term in + match i with + | 1 -> Mc.XI (parse_positive c.(0)) + | 2 -> Mc.XO (parse_positive c.(0)) + | 3 -> Mc.XH + | i -> raise ParseError + + let rec dump_positive x = + match x with + | Mc.XH -> Lazy.force coq_xH + | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_positive p |]) + | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_positive p |]) + + let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) + + let rec dump_n x = + match x with + | Mc.N0 -> Lazy.force coq_N0 + | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) + + let rec dump_index x = + match x with + | Mc.XH -> Lazy.force coq_xH + | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_index p |]) + | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_index p |]) + + let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) + + let rec dump_n x = + match x with + | Mc.N0 -> Lazy.force coq_NO + | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p |]) + + let rec pp_n o x = output_string o (string_of_int (CoqToCaml.n x)) + + let dump_pair t1 t2 dump_t1 dump_t2 (x,y) = + Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|]) + + let rec parse_z term = + let (i,c) = get_left_construct term in + match i with + | 1 -> Mc.Z0 + | 2 -> Mc.Zpos (parse_positive c.(0)) + | 3 -> Mc.Zneg (parse_positive c.(0)) + | i -> raise ParseError + + let dump_z x = + match x with + | Mc.Z0 ->Lazy.force coq_ZERO + | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|]) + | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|]) + + let pp_z o x = Printf.fprintf o "%i" (CoqToCaml.z x) + + let dump_num bd1 = + Term.mkApp(Lazy.force coq_Qmake, + [|dump_z (CamlToCoq.bigint (numerator bd1)) ; + dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |]) + + let dump_q q = + Term.mkApp(Lazy.force coq_Qmake, + [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) + + let parse_q term = + match Term.kind_of_term term with + | Term.App(c, args) -> if c = Lazy.force coq_Qmake then + {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) } + else raise ParseError + | _ -> raise ParseError + + let rec parse_list parse_elt term = + let (i,c) = get_left_construct term in + match i with + | 1 -> [] + | 2 -> parse_elt c.(1) :: parse_list parse_elt c.(2) + | i -> raise ParseError + + let rec dump_list typ dump_elt l = + match l with + | [] -> Term.mkApp(Lazy.force coq_nil,[| typ |]) + | e :: l -> Term.mkApp(Lazy.force coq_cons, + [| typ; dump_elt e;dump_list typ dump_elt l|]) + + let pp_list op cl elt o l = + let rec _pp o l = + match l with + | [] -> () + | [e] -> Printf.fprintf o "%a" elt e + | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in + Printf.fprintf o "%s%a%s" op _pp l cl + + let pp_var = pp_positive + + let dump_var = dump_positive + + let pp_expr pp_z o e = + let rec pp_expr o e = + match e with + | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n + | Mc.PEc z -> pp_z o z + | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2 + | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2 + | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e + | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2 + | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n n in + pp_expr o e + + let dump_expr typ dump_z e = + let rec dump_expr e = + match e with + | Mc.PEX n -> mkApp(Lazy.force coq_PEX,[| typ; dump_var n |]) + | Mc.PEc z -> mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |]) + | Mc.PEadd(e1,e2) -> mkApp(Lazy.force coq_PEadd, + [| typ; dump_expr e1;dump_expr e2|]) + | Mc.PEsub(e1,e2) -> mkApp(Lazy.force coq_PEsub, + [| typ; dump_expr e1;dump_expr e2|]) + | Mc.PEopp e -> mkApp(Lazy.force coq_PEopp, + [| typ; dump_expr e|]) + | Mc.PEmul(e1,e2) -> mkApp(Lazy.force coq_PEmul, + [| typ; dump_expr e1;dump_expr e2|]) + | Mc.PEpow(e,n) -> mkApp(Lazy.force coq_PEpow, + [| typ; dump_expr e; dump_n n|]) + in + dump_expr e + + let dump_pol typ dump_c e = + let rec dump_pol e = + match e with + | Mc.Pc n -> mkApp(Lazy.force coq_Pc, [|typ ; dump_c n|]) + | Mc.Pinj(p,pol) -> mkApp(Lazy.force coq_Pinj , [| typ ; dump_positive p ; dump_pol pol|]) + | Mc.PX(pol1,p,pol2) -> mkApp(Lazy.force coq_PX, [| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2|]) in + dump_pol e + + let pp_pol pp_c o e = + let rec pp_pol o e = + match e with + | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n + | Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol + | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in + pp_pol o e + + let pp_cnf pp_c o f = + let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) l in + List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f + + let dump_psatz typ dump_z e = + let z = Lazy.force typ in + let rec dump_cone e = + match e with + | Mc.PsatzIn n -> mkApp(Lazy.force coq_PsatzIn,[| z; dump_nat n |]) + | Mc.PsatzMulC(e,c) -> mkApp(Lazy.force coq_PsatzMultC, + [| z; dump_pol z dump_z e ; dump_cone c |]) + | Mc.PsatzSquare e -> mkApp(Lazy.force coq_PsatzSquare, + [| z;dump_pol z dump_z e|]) + | Mc.PsatzAdd(e1,e2) -> mkApp(Lazy.force coq_PsatzAdd, + [| z; dump_cone e1; dump_cone e2|]) + | Mc.PsatzMulE(e1,e2) -> mkApp(Lazy.force coq_PsatzMulE, + [| z; dump_cone e1; dump_cone e2|]) + | Mc.PsatzC p -> mkApp(Lazy.force coq_PsatzC,[| z; dump_z p|]) + | Mc.PsatzZ -> mkApp( Lazy.force coq_PsatzZ,[| z|]) in + dump_cone e + + let pp_psatz pp_z o e = + let rec pp_cone o e = + match e with + | Mc.PsatzIn n -> + Printf.fprintf o "(In %a)%%nat" pp_nat n + | Mc.PsatzMulC(e,c) -> + Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c + | Mc.PsatzSquare e -> + Printf.fprintf o "(%a^2)" (pp_pol pp_z) e + | Mc.PsatzAdd(e1,e2) -> + Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2 + | Mc.PsatzMulE(e1,e2) -> + Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2 + | Mc.PsatzC p -> + Printf.fprintf o "(%a)%%positive" pp_z p + | Mc.PsatzZ -> + Printf.fprintf o "0" in + pp_cone o e + + let rec dump_op = function + | Mc.OpEq-> Lazy.force coq_OpEq + | Mc.OpNEq-> Lazy.force coq_OpNEq + | Mc.OpLe -> Lazy.force coq_OpLe + | Mc.OpGe -> Lazy.force coq_OpGe + | Mc.OpGt-> Lazy.force coq_OpGt + | Mc.OpLt-> Lazy.force coq_OpLt + + let pp_op o e= + match e with + | Mc.OpEq-> Printf.fprintf o "=" + | Mc.OpNEq-> Printf.fprintf o "<>" + | Mc.OpLe -> Printf.fprintf o "=<" + | Mc.OpGe -> Printf.fprintf o ">=" + | Mc.OpGt-> Printf.fprintf o ">" + | Mc.OpLt-> Printf.fprintf o "<" + + let pp_cstr pp_z o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } = + Printf.fprintf o"(%a %a %a)" (pp_expr pp_z) l pp_op op (pp_expr pp_z) r + + let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = + Term.mkApp(Lazy.force coq_Build, + [| typ; dump_expr typ dump_constant e1 ; + dump_op o ; + dump_expr typ dump_constant e2|]) + + let assoc_const x l = + try + snd (List.find (fun (x',y) -> x = Lazy.force x') l) + with + Not_found -> raise ParseError + + let zop_table = [ + coq_Zgt, Mc.OpGt ; + coq_Zge, Mc.OpGe ; + coq_Zlt, Mc.OpLt ; + coq_Zle, Mc.OpLe ] + + let rop_table = [ + coq_Rgt, Mc.OpGt ; + coq_Rge, Mc.OpGe ; + coq_Rlt, Mc.OpLt ; + coq_Rle, Mc.OpLe ] + + let qop_table = [ + coq_Qlt, Mc.OpLt ; + coq_Qle, Mc.OpLe ; + coq_Qeq, Mc.OpEq + ] + + let parse_zop (op,args) = + match kind_of_term op with + | Const x -> (assoc_const op zop_table, args.(0) , args.(1)) + | Ind(n,0) -> + if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_Z + then (Mc.OpEq, args.(1), args.(2)) + else raise ParseError + | _ -> failwith "parse_zop" + + let parse_rop (op,args) = + match kind_of_term op with + | Const x -> (assoc_const op rop_table, args.(0) , args.(1)) + | Ind(n,0) -> + if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_R + then (Mc.OpEq, args.(1), args.(2)) + else raise ParseError + | _ -> failwith "parse_zop" + + let parse_qop (op,args) = + (assoc_const op qop_table, args.(0) , args.(1)) + + let is_constant t = (* This is an approx *) + match kind_of_term t with + | Construct(i,_) -> true + | _ -> false + + type 'a op = + | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) + | Opp + | Power + | Ukn of string + + let assoc_ops x l = + try + snd (List.find (fun (x',y) -> x = Lazy.force x') l) + with + Not_found -> Ukn "Oups" + + (** + * MODULE: Env is for environment. + *) + + module Env = + struct + type t = constr list + + let compute_rank_add env v = + let rec _add env n v = + match env with + | [] -> ([v],n) + | e::l -> + if eq_constr e v + then (env,n) + else + let (env,n) = _add l ( n+1) v in + (e::env,n) in + let (env, n) = _add env 1 v in + (env, CamlToCoq.idx n) + + let empty = [] + + let elements env = env + + end (* MODULE END: Env *) + + (** + * This is the big generic function for expression parsers. + *) + + let parse_expr parse_constant parse_exp ops_spec env term = + if debug + then (Pp.pp (Pp.str "parse_expr: "); + Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ()); + + let constant_or_variable env term = + try + ( Mc.PEc (parse_constant term) , env) + with ParseError -> + let (env,n) = Env.compute_rank_add env term in + (Mc.PEX n , env) in + + let rec parse_expr env term = + let combine env op (t1,t2) = + let (expr1,env) = parse_expr env t1 in + let (expr2,env) = parse_expr env t2 in + (op expr1 expr2,env) in + + match kind_of_term term with + | App(t,args) -> + ( + match kind_of_term t with + | Const c -> + ( match assoc_ops t ops_spec with + | Binop f -> combine env f (args.(0),args.(1)) + | Opp -> let (expr,env) = parse_expr env args.(0) in + (Mc.PEopp expr, env) + | Power -> + begin + try + let (expr,env) = parse_expr env args.(0) in + let power = (parse_exp expr args.(1)) in + (power , env) + with _ -> (* if the exponent is a variable *) + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + end + | Ukn s -> + if debug + then (Printf.printf "unknown op: %s\n" s; flush stdout;); + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + ) + | _ -> constant_or_variable env term + ) + | _ -> constant_or_variable env term in + parse_expr env term + + let zop_spec = + [ + coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ; + coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ; + coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; + coq_Zopp , Opp ; + coq_Zpower , Power] + + let qop_spec = + [ + coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ; + coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ; + coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; + coq_Qopp , Opp ; + coq_Qpower , Power] + + let rop_spec = + [ + coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ; + coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ; + coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; + coq_Ropp , Opp ; + coq_Rpower , Power] + + let zconstant = parse_z + let qconstant = parse_q + + let rconstant term = + if debug + then (Pp.pp_flush (); + Pp.pp (Pp.str "rconstant: "); + Pp.pp (Printer.prterm term); Pp.pp_flush ()); + match Term.kind_of_term term with + | Const x -> + if term = Lazy.force coq_R0 + then Mc.Z0 + else if term = Lazy.force coq_R1 + then Mc.Zpos Mc.XH + else raise ParseError + | _ -> raise ParseError + + let parse_zexpr = parse_expr + zconstant + (fun expr x -> + let exp = (parse_z x) in + match exp with + | Mc.Zneg _ -> Mc.PEc Mc.Z0 + | _ -> Mc.PEpow(expr, Mc.n_of_Z exp)) + zop_spec + + let parse_qexpr = parse_expr + qconstant + (fun expr x -> + let exp = parse_z x in + match exp with + | Mc.Zneg _ -> + begin + match expr with + | Mc.PEc q -> Mc.PEc (Mc.qpower q exp) + | _ -> print_string "parse_qexpr parse error" ; flush stdout ; raise ParseError + end + | _ -> let exp = Mc.n_of_Z exp in + Mc.PEpow(expr,exp)) + qop_spec + + let parse_rexpr = parse_expr + rconstant + (fun expr x -> + let exp = Mc.n_of_nat (parse_nat x) in + Mc.PEpow(expr,exp)) + rop_spec + + let parse_arith parse_op parse_expr env cstr = + if debug + then (Pp.pp_flush (); + Pp.pp (Pp.str "parse_arith: "); + Pp.pp (Printer.prterm cstr); + Pp.pp_flush ()); + match kind_of_term cstr with + | App(op,args) -> + let (op,lhs,rhs) = parse_op (op,args) in + let (e1,env) = parse_expr env lhs in + let (e2,env) = parse_expr env rhs in + ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) + | _ -> failwith "error : parse_arith(2)" + + let parse_zarith = parse_arith parse_zop parse_zexpr + + let parse_qarith = parse_arith parse_qop parse_qexpr + + let parse_rarith = parse_arith parse_rop parse_rexpr + + (* generic parsing of arithmetic expressions *) + + let rec f2f = function + | TT -> Mc.TT + | FF -> Mc.FF + | X _ -> Mc.X + | A (x,_,_) -> Mc.A x + | C (a,b) -> Mc.Cj(f2f a,f2f b) + | D (a,b) -> Mc.D(f2f a,f2f b) + | N (a) -> Mc.N(f2f a) + | I(a,_,b) -> Mc.I(f2f a,f2f b) + + let is_prop t = + match t with + | Names.Anonymous -> true (* Not quite right *) + | Names.Name x -> false + + let mkC f1 f2 = C(f1,f2) + let mkD f1 f2 = D(f1,f2) + let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1)) + let mkI f1 f2 = I(f1,None,f2) + + let mkformula_binary g term f1 f2 = + match f1 , f2 with + | X _ , X _ -> X(term) + | _ -> g f1 f2 + + (** + * This is the big generic function for formula parsers. + *) + + let parse_formula parse_atom env term = + + let parse_atom env tg t = try let (at,env) = parse_atom env t in + (A(at,tg,t), env,Tag.next tg) with _ -> (X(t),env,tg) in + + let rec xparse_formula env tg term = + match kind_of_term term with + | App(l,rst) -> + (match rst with + | [|a;b|] when l = Lazy.force coq_and -> + let f,env,tg = xparse_formula env tg a in + let g,env, tg = xparse_formula env tg b in + mkformula_binary mkC term f g,env,tg + | [|a;b|] when l = Lazy.force coq_or -> + let f,env,tg = xparse_formula env tg a in + let g,env,tg = xparse_formula env tg b in + mkformula_binary mkD term f g,env,tg + | [|a|] when l = Lazy.force coq_not -> + let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) + | [|a;b|] when l = Lazy.force coq_iff -> + let f,env,tg = xparse_formula env tg a in + let g,env,tg = xparse_formula env tg b in + mkformula_binary mkIff term f g,env,tg + | _ -> parse_atom env tg term) + | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) -> + let f,env,tg = xparse_formula env tg a in + let g,env,tg = xparse_formula env tg b in + mkformula_binary mkI term f g,env,tg + | _ when term = Lazy.force coq_True -> (TT,env,tg) + | _ when term = Lazy.force coq_False -> (FF,env,tg) + | _ -> X(term),env,tg in + xparse_formula env term + + let dump_formula typ dump_atom f = + let rec xdump f = + match f with + | TT -> mkApp(Lazy.force coq_TT,[|typ|]) + | FF -> mkApp(Lazy.force coq_FF,[|typ|]) + | C(x,y) -> mkApp(Lazy.force coq_And,[|typ ; xdump x ; xdump y|]) + | D(x,y) -> mkApp(Lazy.force coq_Or,[|typ ; xdump x ; xdump y|]) + | I(x,_,y) -> mkApp(Lazy.force coq_Impl,[|typ ; xdump x ; xdump y|]) + | N(x) -> mkApp(Lazy.force coq_Neg,[|typ ; xdump x|]) + | A(x,_,_) -> mkApp(Lazy.force coq_Atom,[|typ ; dump_atom x|]) + | X(t) -> mkApp(Lazy.force coq_X,[|typ ; t|]) in + xdump f + + (** + * Given a conclusion and a list of affectations, rebuild a term prefixed by + * the appropriate letins. + * TODO: reverse the list of bindings! + *) + + let set l concl = + let rec xset acc = function + | [] -> acc + | (e::l) -> + let (name,expr,typ) = e in + xset (Term.mkNamedLetIn + (Names.id_of_string name) + expr typ acc) l in + xset concl l + +end (** + * MODULE END: M + *) + +open M + +let rec sig_of_cone = function + | Mc.PsatzIn n -> [CoqToCaml.nat n] + | Mc.PsatzMulE(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) + | Mc.PsatzMulC(w1,w2) -> (sig_of_cone w2) + | Mc.PsatzAdd(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) + | _ -> [] + +let same_proof sg cl1 cl2 = + let rec xsame_proof sg = + match sg with + | [] -> true + | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false) + && (xsame_proof sg ) in + xsame_proof sg + +let tags_of_clause tgs wit clause = + let rec xtags tgs = function + | Mc.PsatzIn n -> Names.Idset.union tgs + (snd (List.nth clause (CoqToCaml.nat n) )) + | Mc.PsatzMulC(e,w) -> xtags tgs w + | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(w1,w2) -> xtags (xtags tgs w1) w2 + | _ -> tgs in + xtags tgs wit + +let tags_of_cnf wits cnf = + List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) + Names.Idset.empty wits cnf + +let find_witness prover polys1 = try_any prover polys1 + +let rec witness prover l1 l2 = + match l2 with + | [] -> Some [] + | e :: l2 -> + match find_witness prover (e::l1) with + | None -> None + | Some w -> + (match witness prover l1 l2 with + | None -> None + | Some l -> Some (w::l) + ) + +let rec apply_ids t ids = + match ids with + | [] -> t + | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids + +let coq_Node = lazy + (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") +let coq_Leaf = lazy + (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") +let coq_Empty = lazy + (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") + +let btree_of_array typ a = + let size_of_a = Array.length a in + let semi_size_of_a = size_of_a lsr 1 in + let node = Lazy.force coq_Node + and leaf = Lazy.force coq_Leaf + and empty = Term.mkApp (Lazy.force coq_Empty, [| typ |]) in + let rec aux n = + if n > size_of_a + then empty + else if n > semi_size_of_a + then Term.mkApp (leaf, [| typ; a.(n-1) |]) + else Term.mkApp (node, [| typ; aux (2*n); a.(n-1); aux (2*n+1) |]) + in + aux 1 + +let btree_of_array typ a = + try + btree_of_array typ a + with x -> + failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x)) + +let dump_varmap typ env = + btree_of_array typ (Array.of_list env) + + +let rec pp_varmap o vm = + match vm with + | Mc.Empty -> output_string o "[]" + | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z + | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l pp_z z pp_varmap r + + + +let rec dump_proof_term = function + | Micromega.DoneProof -> Lazy.force coq_doneProof + | Micromega.RatProof(cone,rst) -> + Term.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|]) + | Micromega.CutProof(cone,prf) -> + Term.mkApp(Lazy.force coq_cutProof, + [| dump_psatz coq_Z dump_z cone ; + dump_proof_term prf|]) + | Micromega.EnumProof(c1,c2,prfs) -> + Term.mkApp (Lazy.force coq_enumProof, + [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; + dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) + +let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden + + +let rec pp_proof_term o = function + | Micromega.DoneProof -> Printf.fprintf o "D" + | Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst + | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst + | Micromega.EnumProof(c1,c2,rst) -> + Printf.fprintf o "EP[%a,%a,%a]" + (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 + (pp_list "[" "]" pp_proof_term) rst + +let rec parse_hyps parse_arith env tg hyps = + match hyps with + | [] -> ([],env,tg) + | (i,t)::l -> + let (lhyps,env,tg) = parse_hyps parse_arith env tg l in + try + let (c,env,tg) = parse_formula parse_arith env tg t in + ((i,c)::lhyps, env,tg) + with _ -> (lhyps,env,tg) + (*(if debug then Printf.printf "parse_arith : %s\n" x);*) + + +(*exception ParseError*) + +let parse_goal parse_arith env hyps term = + (* try*) + let (f,env,tg) = parse_formula parse_arith env (Tag.from 0) term in + let (lhyps,env,tg) = parse_hyps parse_arith env tg hyps in + (lhyps,f,env) + (* with Failure x -> raise ParseError*) + +(** + * The datastructures that aggregate theory-dependent proof values. + *) + +type ('d, 'prf) domain_spec = { + typ : Term.constr; (* Z, Q , R *) + coeff : Term.constr ; (* Z, Q *) + dump_coeff : 'd -> Term.constr ; + proof_typ : Term.constr ; + dump_proof : 'prf -> Term.constr +} + +let zz_domain_spec = lazy { + typ = Lazy.force coq_Z; + coeff = Lazy.force coq_Z; + dump_coeff = dump_z ; + proof_typ = Lazy.force coq_proofTerm ; + dump_proof = dump_proof_term +} + +let qq_domain_spec = lazy { + typ = Lazy.force coq_Q; + coeff = Lazy.force coq_Q; + dump_coeff = dump_q ; + proof_typ = Lazy.force coq_QWitness ; + dump_proof = dump_psatz coq_Q dump_q +} + +let rz_domain_spec = lazy { + typ = Lazy.force coq_R; + coeff = Lazy.force coq_Z; + dump_coeff = dump_z; + proof_typ = Lazy.force coq_ZWitness ; + dump_proof = dump_psatz coq_Z dump_z +} + +(** + * Instanciate the current Coq goal with a Micromega formula, a varmap, and a + * witness. + *) + +let micromega_order_change spec cert cert_typ env ff gl = + let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in + let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in + let vm = dump_varmap (spec.typ) env in + Tactics.change_in_concl None + (set + [ + ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); + ("__varmap", vm, Term.mkApp + (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|spec.typ|])); + ("__wit", cert, cert_typ) + ] + (Tacmach.pf_concl gl) + ) + gl + +(** + * The datastructures that aggregate prover attributes. + *) + +type ('a,'prf) prover = { + name : string ; (* name of the prover *) + prover : 'a list -> 'prf option ; (* the prover itself *) + hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *) + compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *) + pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *) + pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*) +} + +(** + * Given a list of provers and a disjunction of atoms, find a proof of any of + * the atoms. Returns an (optional) pair of a proof and a prover + * datastructure. + *) + +let find_witness provers polys1 = + let provers = List.map (fun p -> + (fun l -> + match p.prover l with + | None -> None + | Some prf -> Some(prf,p)) , p.name) provers in + try_any provers (List.map fst polys1) + +(** + * Given a list of provers and a CNF, find a proof for each of the clauses. + * Return the proofs as a list. + *) + +let witness_list prover l = + let rec xwitness_list l = + match l with + | [] -> Some [] + | e :: l -> + match find_witness prover e with + | None -> None + | Some w -> + (match xwitness_list l with + | None -> None + | Some l -> Some (w :: l) + ) in + xwitness_list l + +let witness_list_tags = witness_list + +(* *Deprecated* let is_singleton = function [] -> true | [e] -> true | _ -> false *) + +let pp_ml_list pp_elt o l = + output_string o "[" ; + List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ; + output_string o "]" + +(** + * Prune the proof object, according to the 'diff' between two cnf formulas. + *) + +let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = + + let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = + let new_cl = Mutils.mapi (fun (f,_) i -> (f,i)) new_cl in + let remap i = + let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in + List.assoc formula new_cl in + if debug then + begin + Printf.printf "\ncompact_proof : %a %a %a" + (pp_ml_list prover.pp_f) (List.map fst old_cl) + prover.pp_prf prf + (pp_ml_list prover.pp_f) (List.map fst new_cl) ; + flush stdout + end ; + let res = try prover.compact prf remap with x -> + if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; + (* This should not happen -- this is the recovery plan... *) + match prover.prover (List.map fst new_cl) with + | None -> failwith "proof compaction error" + | Some p -> p + in + if debug then + begin + Printf.printf " -> %a\n" + prover.pp_prf res ; + flush stdout + end ; + res in + + let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = + let hyps_idx = prover.hyps prf in + let hyps = selecti hyps_idx old_cl in + is_sublist hyps new_cl in + + let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) + + List.map (fun x -> + let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res + in compact_proof o p x) cnf_ff' + + +(** + * "Hide out" tagged atoms of a formula by transforming them into generic + * variables. See the Tag module in mutils.ml for more. + *) + +let abstract_formula hyps f = + let rec xabs f = + match f with + | X c -> X c + | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term) + | C(f1,f2) -> + (match xabs f1 , xabs f2 with + | X a1 , X a2 -> X (Term.mkApp(Lazy.force coq_and, [|a1;a2|])) + | f1 , f2 -> C(f1,f2) ) + | D(f1,f2) -> + (match xabs f1 , xabs f2 with + | X a1 , X a2 -> X (Term.mkApp(Lazy.force coq_or, [|a1;a2|])) + | f1 , f2 -> D(f1,f2) ) + | N(f) -> + (match xabs f with + | X a -> X (Term.mkApp(Lazy.force coq_not, [|a|])) + | f -> N f) + | I(f1,hyp,f2) -> + (match xabs f1 , hyp, xabs f2 with + | X a1 , Some _ , af2 -> af2 + | X a1 , None , X a2 -> X (Term.mkArrow a1 a2) + | af1 , _ , af2 -> I(af1,hyp,af2) + ) + | FF -> FF + | TT -> TT + in xabs f + +(** + * This exception is raised by really_call_csdpcert if Coq's configure didn't + * find a CSDP executable. + *) + +exception CsdpNotFound + +(** + * This is the core of Micromega: apply the prover, analyze the result and + * prune unused fomulas, and finally modify the proof state. + *) + +let micromega_tauto negate normalise spec prover env polys1 polys2 gl = + let spec = Lazy.force spec in + + (* Express the goal as one big implication *) + let (ff,ids) = + List.fold_right + (fun (id,f) (cc,ids) -> + match f with + X _ -> (cc,ids) + | _ -> (I(f,Some id,cc), id::ids)) + polys1 (polys2,[]) in + + (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *) + let cnf_ff = cnf negate normalise ff in + + if debug then + begin + Pp.pp (Pp.str "Formula....\n") ; + let formula_typ = (Term.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in + let ff = dump_formula formula_typ + (dump_cstr spec.typ spec.dump_coeff) ff in + Pp.pp (Printer.prterm ff) ; Pp.pp_flush (); + Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff + end; + + match witness_list_tags prover cnf_ff with + | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl + | Some res -> (*Printf.printf "\nList %i" (List.length `res); *) + let hyps = List.fold_left (fun s (cl,(prf,p)) -> + let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in + if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; + (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in + TagSet.union s tags) TagSet.empty (List.combine cnf_ff res) in + + if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; + Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; + + let ff' = abstract_formula hyps ff in + let cnf_ff' = cnf negate normalise ff' in + + if debug then + begin + Pp.pp (Pp.str "\nAFormula\n") ; + let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in + let ff' = dump_formula formula_typ + (dump_cstr spec.typ spec.dump_coeff) ff' in + Pp.pp (Printer.prterm ff') ; Pp.pp_flush (); + Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' + end; + + (* Even if it does not work, this does not mean it is not provable + -- the prover is REALLY incomplete *) + (* if debug then + begin + (* recompute the proofs *) + match witness_list_tags prover cnf_ff' with + | None -> failwith "abstraction is wrong" + | Some res -> () + end ; *) + let res' = compact_proofs cnf_ff res cnf_ff' in + + let (ff',res',ids) = (ff',res',List.map Term.mkVar (ids_of_formula ff')) in + + let res' = dump_list (spec.proof_typ) spec.dump_proof res' in + (Tacticals.tclTHENSEQ + [ + Tactics.generalize ids ; + micromega_order_change spec res' + (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff' + ]) gl + +(** + * Parse the proof environment, and call micromega_tauto + *) + +let micromega_gen + parse_arith + (negate:'cst atom -> 'cst mc_cnf) + (normalise:'cst atom -> 'cst mc_cnf) + spec prover gl = + let concl = Tacmach.pf_concl gl in + let hyps = Tacmach.pf_hyps_types gl in + try + let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in + let env = Env.elements env in + micromega_tauto negate normalise spec prover env hyps concl gl + with + | Failure x -> flush stdout ; Pp.pp_flush () ; + Tacticals.tclFAIL 0 (Pp.str x) gl + | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl + | CsdpNotFound -> flush stdout ; Pp.pp_flush () ; + Tacticals.tclFAIL 0 (Pp.str + (" Skipping what remains of this tactic: the complexity of the goal requires " + ^ "the use of a specialized external tool called csdp. \n\n" + ^ "Unfortunately this instance of Coq isn't aware of the presence of any \"csdp\" executable. \n\n" + ^ "You may need to specify the location during Coq's pre-compilation configuration step")) gl + +let lift_ratproof prover l = + match prover l with + | None -> None + | Some c -> Some (Mc.RatProof( c,Mc.DoneProof)) + +type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list +type csdp_certificate = S of Sos_types.positivstellensatz option | F of string +type provername = string * int option + +(** + * The caching mechanism. + *) + +open Persistent_cache + +module Cache = PHashtable(struct + type t = (provername * micromega_polys) + let equal = (=) + let hash = Hashtbl.hash +end) + +let csdp_cache = "csdp.cache" + +(** + * Build the command to call csdpcert, and launch it. This in turn will call + * the sos driver to the csdp executable. + * Throw CsdpNotFound if a Coq isn't aware of any csdp executable. + *) + +let require_csdp = + match System.search_exe_in_path "csdp" with + | Some _ -> lazy () + | _ -> lazy (raise CsdpNotFound) + +let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option = + fun provername poly -> + + Lazy.force require_csdp; + + let cmdname = + List.fold_left Filename.concat (Envars.coqlib ()) + ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in + + match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with + | F str -> failwith str + | S res -> res + +(** + * Check the cache before calling the prover. + *) + +let xcall_csdpcert = + Cache.memo csdp_cache (fun (prover,pb) -> really_call_csdpcert prover pb) + +(** + * Prover callback functions. + *) + +let call_csdpcert prover pb = xcall_csdpcert (prover,pb) + +let rec z_to_q_pol e = + match e with + | Mc.Pc z -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH} + | Mc.Pinj(p,pol) -> Mc.Pinj(p,z_to_q_pol pol) + | Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2) + +let call_csdpcert_q provername poly = + match call_csdpcert provername poly with + | None -> None + | Some cert -> + let cert = Certificate.q_cert_of_pos cert in + if Mc.qWeakChecker poly cert + then Some cert + else ((print_string "buggy certificate" ; flush stdout) ;None) + +let call_csdpcert_z provername poly = + let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in + match call_csdpcert provername l with + | None -> None + | Some cert -> + let cert = Certificate.z_cert_of_pos cert in + if Mc.zWeakChecker poly cert + then Some cert + else ((print_string "buggy certificate" ; flush stdout) ;None) + +let xhyps_of_cone base acc prf = + let rec xtract e acc = + match e with + | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc + | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in + if n >= base + then ISet.add (n-base) acc + else acc + | Mc.PsatzMulC(_,c) -> xtract c acc + | Mc.PsatzAdd(e1,e2) | Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in + + xtract prf acc + +let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf + +let compact_cone prf f = + let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in + + let rec xinterp prf = + match prf with + | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> prf + | Mc.PsatzIn n -> Mc.PsatzIn (np n) + | Mc.PsatzMulC(e,c) -> Mc.PsatzMulC(e,xinterp c) + | Mc.PsatzAdd(e1,e2) -> Mc.PsatzAdd(xinterp e1,xinterp e2) + | Mc.PsatzMulE(e1,e2) -> Mc.PsatzMulE(xinterp e1,xinterp e2) in + + xinterp prf + +let hyps_of_pt pt = + + let rec xhyps base pt acc = + match pt with + | Mc.DoneProof -> acc + | Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) + | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) + | Mc.EnumProof(c1,c2,l) -> + let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in + List.fold_left (fun s x -> xhyps (base + 1) x s) s l in + + xhyps 0 pt ISet.empty + +let hyps_of_pt pt = + let res = hyps_of_pt pt in + if debug + then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res); + res + +let compact_pt pt f = + let translate ofset x = + if x < ofset then x + else (f (x-ofset) + ofset) in + + let rec compact_pt ofset pt = + match pt with + | Mc.DoneProof -> Mc.DoneProof + | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) + | Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) + | Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)), + Mc.map (fun x -> compact_pt (ofset+1) x) l) in + compact_pt 0 pt + +(** + * Definition of provers. + * Instantiates the type ('a,'prf) prover defined above. + *) + +let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) + +let linear_prover_Z = { + name = "linear prover" ; + prover = lift_ratproof (lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec)) ; + hyps = hyps_of_pt ; + compact = compact_pt ; + pp_prf = pp_proof_term; + pp_f = fun o x -> pp_pol pp_z o (fst x) +} + +let linear_prover_Q = { + name = "linear prover"; + prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ; + hyps = hyps_of_cone ; + compact = compact_cone ; + pp_prf = pp_psatz pp_q ; + pp_f = fun o x -> pp_pol pp_q o (fst x) +} + +let linear_prover_R = { + name = "linear prover"; + prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec) ; + hyps = hyps_of_cone ; + compact = compact_cone ; + pp_prf = pp_psatz pp_z ; + pp_f = fun o x -> pp_pol pp_z o (fst x) +} + +let non_linear_prover_Q str o = { + name = "real nonlinear prover"; + prover = call_csdpcert_q (str, o); + hyps = hyps_of_cone; + compact = compact_cone ; + pp_prf = pp_psatz pp_q ; + pp_f = fun o x -> pp_pol pp_q o (fst x) +} + +let non_linear_prover_R str o = { + name = "real nonlinear prover"; + prover = call_csdpcert_z (str, o); + hyps = hyps_of_cone; + compact = compact_cone; + pp_prf = pp_psatz pp_z; + pp_f = fun o x -> pp_pol pp_z o (fst x) +} + +let non_linear_prover_Z str o = { + name = "real nonlinear prover"; + prover = lift_ratproof (call_csdpcert_z (str, o)); + hyps = hyps_of_pt; + compact = compact_pt; + pp_prf = pp_proof_term; + pp_f = fun o x -> pp_pol pp_z o (fst x) +} + +module CacheZ = PHashtable(struct + type t = (Mc.z Mc.pol * Mc.op1) list + let equal = (=) + let hash = Hashtbl.hash +end) + +let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover) + +let linear_Z = { + name = "lia"; + prover = memo_zlinear_prover ; + hyps = hyps_of_pt; + compact = compact_pt; + pp_prf = pp_proof_term; + pp_f = fun o x -> pp_pol pp_z o (fst x) +} + +(** + * Functions instantiating micromega_gen with the appropriate theories and + * solvers + *) + +let psatzl_Z gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec + [ linear_prover_Z ] gl + +let psatzl_Q gl = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec + [ linear_prover_Q ] gl + +let psatz_Q i gl = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec + [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] gl + +let psatzl_R gl = + micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec + [ linear_prover_R ] gl + +let psatz_R i gl = + micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec + [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] gl + +let psatz_Z i gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec + [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl + +let sos_Z gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec + [ non_linear_prover_Z "pure_sos" None ] gl + +let sos_Q gl = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec + [ non_linear_prover_Q "pure_sos" None ] gl + +let sos_R gl = + micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec + [ non_linear_prover_R "pure_sos" None ] gl + +let xlia gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec + [ linear_Z ] gl + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml new file mode 100644 index 00000000..d4e6d920 --- /dev/null +++ b/plugins/micromega/csdpcert.ml @@ -0,0 +1,214 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Const (C2Ml.q_to_num z) + | PEX v -> Var ("x"^(string_of_int (C2Ml.index v))) + | PEmul(p1,p2) -> + let p1 = expr_to_term p1 in + let p2 = expr_to_term p2 in + let res = Mul(p1,p2) in res + + | PEadd(p1,p2) -> Add(expr_to_term p1, expr_to_term p2) + | PEsub(p1,p2) -> Sub(expr_to_term p1, expr_to_term p2) + | PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n) + | PEopp p -> Opp (expr_to_term p) + + +end +open M + +open List +open Mutils + + + + +let rec canonical_sum_to_string = function s -> failwith "not implemented" + +let print_canonical_sum m = Format.print_string (canonical_sum_to_string m) + +let print_list_term o l = + output_string o "print_list_term\n"; + List.iter (fun (e,k) -> Printf.fprintf o "q: %s %s ;" + (string_of_poly (poly_of_term (expr_to_term e))) + (match k with + Mc.Equal -> "= " + | Mc.Strict -> "> " + | Mc.NonStrict -> ">= " + | _ -> failwith "not_implemented")) (List.map (fun (e, o) -> Mc.denorm e , o) l) ; + output_string o "\n" + + +let partition_expr l = + let rec f i = function + | [] -> ([],[],[]) + | (e,k)::l -> + let (eq,ge,neq) = f (i+1) l in + match k with + | Mc.Equal -> ((e,i)::eq,ge,neq) + | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq) + | Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *) + (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq) + | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq) + (* Not quite sure -- Coq interface has changed *) + in f 0 l + + +let rec sets_of_list l = + match l with + | [] -> [[]] + | e::l -> let s = sets_of_list l in + s@(List.map (fun s0 -> e::s0) s) + +(* The exploration is probably not complete - for simple cases, it works... *) +let real_nonlinear_prover d l = + let l = List.map (fun (e,op) -> (Mc.denorm e,op)) l in + try + let (eq,ge,neq) = partition_expr l in + + let rec elim_const = function + [] -> [] + | (x,y)::l -> let p = poly_of_term (expr_to_term x) in + if poly_isconst p + then elim_const l + else (p,y)::(elim_const l) in + + let eq = elim_const eq in + let peq = List.map fst eq in + + let pge = List.map + (fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in + + let monoids = List.map (fun m -> (List.fold_right (fun (p,kd) y -> + let p = poly_of_term (expr_to_term p) in + match kd with + | Axiom_lt i -> poly_mul p y + | Axiom_eq i -> poly_mul (poly_pow p 2) y + | _ -> failwith "monoids") m (poly_const (Int 1)) , map snd m)) + (sets_of_list neq) in + + let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> + list_try_find (fun m -> let (ci,cc) = + real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in + (ci,cc,snd m)) monoids) 0 in + + let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i)) + cert_ideal (List.map snd eq) in + + let proofs_cone = map term_of_sos cert_cone in + + let proof_ne = + let (neq , lt) = List.partition + (function Axiom_eq _ -> true | _ -> false ) monoid in + let sq = match + (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq) + with + | [] -> Rational_lt (Int 1) + | l -> Monoid l in + List.fold_right (fun x y -> Product(x,y)) lt sq in + + let proof = list_fold_right_elements + (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in + S (Some proof) + with + | Sos_lib.TooDeep -> S None + | x -> F (Printexc.to_string x) + +(* This is somewhat buggy, over Z, strict inequality vanish... *) +let pure_sos l = + let l = List.map (fun (e,o) -> Mc.denorm e, o) l in + + (* If there is no strict inequality, + I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) + try + let l = List.combine l (interval 0 (length l -1)) in + let (lt,i) = try (List.find (fun (x,_) -> snd x = Mc.Strict) l) + with Not_found -> List.hd l in + let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in + let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *) + let pos = Product (Rational_lt n, + List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square + (term_of_poly p)), rst)) + polys (Rational_lt (Int 0))) in + let proof = Sum(Axiom_lt i, pos) in +(* let s,proof' = scale_certificate proof in + let cert = snd (cert_of_pos proof') in *) + S (Some proof) + with +(* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *) + | x -> (* May be that could be refined *) S None + + + +let run_prover prover pb = + match prover with + | "real_nonlinear_prover", Some d -> real_nonlinear_prover d pb + | "pure_sos", None -> pure_sos pb + | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) + + +let output_csdp_certificate o = function + | S None -> output_string o "S None" + | S (Some p) -> Printf.fprintf o "S (Some %a)" output_psatz p + | F s -> Printf.fprintf o "F %s" s + + +let main () = + try + let (prover,poly) = (input_value stdin : provername * micromega_polys) in + let cert = run_prover prover poly in +(* Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ; + close_out chan ; *) + + output_value stdout (cert:csdp_certificate); + flush stdout ; + Marshal.to_channel chan (cert:csdp_certificate) [] ; + flush chan ; + exit 0 + with x -> (Printf.fprintf chan "error %s" (Printexc.to_string x) ; exit 1) + +;; + +let _ = main () in () + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 new file mode 100644 index 00000000..f4d04e5d --- /dev/null +++ b/plugins/micromega/g_micromega.ml4 @@ -0,0 +1,76 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* anomaly "Unevaluated or_var variable" + | ArgArg x -> x + +TACTIC EXTEND PsatzZ +| [ "psatz_Z" int_or_var(i) ] -> [ Coq_micromega.psatz_Z (out_arg i) ] +| [ "psatz_Z" ] -> [ Coq_micromega.psatz_Z (-1) ] +END + +TACTIC EXTEND ZOmicron +[ "xlia" ] -> [ Coq_micromega.xlia] +END + + +TACTIC EXTEND Sos_Z +| [ "sos_Z" ] -> [ Coq_micromega.sos_Z] + END + +TACTIC EXTEND Sos_Q +| [ "sos_Q" ] -> [ Coq_micromega.sos_Q] + END + +TACTIC EXTEND Sos_R +| [ "sos_R" ] -> [ Coq_micromega.sos_R] +END + + +TACTIC EXTEND Omicron +[ "psatzl_Z" ] -> [ Coq_micromega.psatzl_Z] +END + +TACTIC EXTEND QOmicron +[ "psatzl_Q" ] -> [ Coq_micromega.psatzl_Q] +END + + + +TACTIC EXTEND ROmicron +[ "psatzl_R" ] -> [ Coq_micromega.psatzl_R] +END + +TACTIC EXTEND RMicromega +| [ "psatz_R" int_or_var(i) ] -> [ Coq_micromega.psatz_R (out_arg i) ] +| [ "psatz_R" ] -> [ Coq_micromega.psatz_R (-1) ] +END + + +TACTIC EXTEND QMicromega +| [ "psatz_Q" int_or_var(i) ] -> [ Coq_micromega.psatz_Q (out_arg i) ] +| [ "psatz_Q" ] -> [ Coq_micromega.psatz_Q (-1) ] +END + diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml new file mode 100644 index 00000000..6250e324 --- /dev/null +++ b/plugins/micromega/mfourier.ml @@ -0,0 +1,1012 @@ +open Num +module Utils = Mutils + +let map_option = Utils.map_option +let from_option = Utils.from_option + +let debug = false +type ('a,'b) lr = Inl of 'a | Inr of 'b + + +module Vect = + struct + (** [t] is the type of vectors. + A vector [(x1,v1) ; ... ; (xn,vn)] is such that: + - variables indexes are ordered (x1 < ... < xn + - values are all non-zero + *) + type var = int + type t = (var * num) list + +(** [equal v1 v2 = true] if the vectors are syntactically equal. + ([num] is not handled by [Pervasives.equal] *) + + let rec equal v1 v2 = + match v1 , v2 with + | [] , [] -> true + | [] , _ -> false + | _::_ , [] -> false + | (i1,n1)::v1 , (i2,n2)::v2 -> + (i1 = i2) && n1 =/ n2 && equal v1 v2 + + let hash v = + let rec hash i = function + | [] -> i + | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in + Hashtbl.hash (hash 0 v ) + + + let null = [] + + let pp_vect o vect = + List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect + + let from_list (l: num list) = + let rec xfrom_list i l = + match l with + | [] -> [] + | e::l -> + if e <>/ Int 0 + then (i,e)::(xfrom_list (i+1) l) + else xfrom_list (i+1) l in + + xfrom_list 0 l + + let zero_num = Int 0 + let unit_num = Int 1 + + + let to_list m = + let rec xto_list i l = + match l with + | [] -> [] + | (x,v)::l' -> + if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in + xto_list 0 m + + + let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst + + let rec update i f t = + match t with + | [] -> cons i (f zero_num) [] + | (k,v)::l -> + match Pervasives.compare i k with + | 0 -> cons k (f v) l + | -1 -> cons i (f zero_num) t + | 1 -> (k,v) ::(update i f l) + | _ -> failwith "compare_num" + + let rec set i n t = + match t with + | [] -> cons i n [] + | (k,v)::l -> + match Pervasives.compare i k with + | 0 -> cons k n l + | -1 -> cons i n t + | 1 -> (k,v) :: (set i n l) + | _ -> failwith "compare_num" + + let gcd m = + let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Utils.numerator e)) Big_int.zero_big_int m in + if Big_int.compare_big_int res Big_int.zero_big_int = 0 + then Big_int.unit_big_int else res + + let rec mul z t = + match z with + | Int 0 -> [] + | Int 1 -> t + | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t + + let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical + [ + (fun () -> Pervasives.compare (fst x) (fst y)); + (fun () -> compare_num (snd x) (snd y))]) + + (** [tail v vect] returns + - [None] if [v] is not a variable of the vector [vect] + - [Some(vl,rst)] where [vl] is the value of [v] in vector [vect] + and [rst] is the remaining of the vector + We exploit that vectors are ordered lists + *) + let rec tail (v:var) (vect:t) = + match vect with + | [] -> None + | (v',vl)::vect' -> + match Pervasives.compare v' v with + | 0 -> Some (vl,vect) (* Ok, found *) + | -1 -> tail v vect' (* Might be in the tail *) + | _ -> None (* Hopeless *) + + let get v vect = + match tail v vect with + | None -> None + | Some(vl,_) -> Some vl + + + let rec fresh v = + match v with + | [] -> 1 + | [v,_] -> v + 1 + | _::v -> fresh v + + end +open Vect + +(** Implementation of intervals *) +module Itv = +struct + + (** The type of intervals is *) + type interval = num option * num option + (** None models the absence of bound i.e. infinity *) + (** As a result, + - None , None -> ]-oo,+oo[ + - None , Some v -> ]-oo,v] + - Some v, None -> [v,+oo[ + - Some v, Some v' -> [v,v'] + Intervals needs to be explicitely normalised. + *) + + type who = Left | Right + + + (** if then interval [itv] is empty, [norm_itv itv] returns [None] + otherwise, it returns [Some itv] *) + + let norm_itv itv = + match itv with + | Some a , Some b -> if a <=/ b then Some itv else None + | _ -> Some itv + + (** [opp_itv itv] computes the opposite interval *) + let opp_itv itv = + let (l,r) = itv in + (map_option minus_num r, map_option minus_num l) + + + + +(** [inter i1 i2 = None] if the intersection of intervals is empty + [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) + let inter i1 i2 = + let (l1,r1) = i1 + and (l2,r2) = i2 in + + let inter f o1 o2 = + match o1 , o2 with + | None , None -> None + | Some _ , None -> o1 + | None , Some _ -> o2 + | Some n1 , Some n2 -> Some (f n1 n2) in + + norm_itv (inter max_num l1 l2 , inter min_num r1 r2) + + let range = function + | None,_ | _,None -> None + | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1)) + + + let smaller_itv i1 i2 = + match range i1 , range i2 with + | None , _ -> false + | _ , None -> true + | Some i , Some j -> i <=/ j + + +(** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *) +let in_bound bnd v = + let (l,r) = bnd in + match l , r with + | None , None -> true + | None , Some a -> v <=/ a + | Some a , None -> a <=/ v + | Some a , Some b -> a <=/ v && v <=/ b + +end +open Itv +type vector = Vect.t + +type cstr = { coeffs : vector ; bound : interval } +(** 'cstr' is the type of constraints. + {coeffs = v ; bound = (l,r) } models the constraints l <= v <= r +**) + +module ISet = Set.Make(struct type t = int let compare = Pervasives.compare end) + + +module PSet = ISet + + +module System = Hashtbl.Make(Vect) + + type proof = + | Hyp of int + | Elim of var * proof * proof + | And of proof * proof + + + +type system = { + sys : cstr_info ref System.t ; + vars : ISet.t +} +and cstr_info = { + bound : interval ; + prf : proof ; + pos : int ; + neg : int ; +} + + +(** A system of constraints has the form [{sys = s ; vars = v}]. + [s] is a hashtable mapping a normalised vector to a [cstr_info] record where + - [bound] is an interval + - [prf_idx] is the set of hypothese indexes (i.e. constraints in the initial system) used to obtain the current constraint. + In the initial system, each constraint is given an unique singleton proof_idx. + When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn] + - [pos] is the number of positive values of the vector + - [neg] is the number of negative values of the vector + ( [neg] + [pos] is therefore the length of the vector) + [v] is an upper-bound of the set of variables which appear in [s]. +*) + +(** To be thrown when a system has no solution *) +exception SystemContradiction of proof +let hyps prf = + let rec hyps prf acc = + match prf with + | Hyp i -> ISet.add i acc + | Elim(_,prf1,prf2) + | And(prf1,prf2) -> hyps prf1 (hyps prf2 acc) in + hyps prf ISet.empty + + +(** Pretty printing *) + let rec pp_proof o prf = + match prf with + | Hyp i -> Printf.fprintf o "H%i" i + | Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2 + | And(prf1,prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2 + +let pp_bound o = function + | None -> output_string o "oo" + | Some a -> output_string o (string_of_num a) + +let pp_itv o (l,r) = Printf.fprintf o "(%a,%a)" pp_bound l pp_bound r + +let rec pp_list f o l = + match l with + | [] -> () + | e::l -> f o e ; output_string o ";" ; pp_list f o l + +let pp_iset o s = + output_string o "{" ; + ISet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); + output_string o "}" + +let pp_pset o s = + output_string o "{" ; + PSet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); + output_string o "}" + + +let pp_info o i = pp_itv o i.bound + +let pp_cstr o (vect,bnd) = + let (l,r) = bnd in + (match l with + | None -> () + | Some n -> Printf.fprintf o "%s <= " (string_of_num n)) + ; + pp_vect o vect ; + (match r with + | None -> output_string o"\n" + | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n)) + + +let pp_system o sys= + System.iter (fun vect ibnd -> + pp_cstr o (vect,(!ibnd).bound)) sys + + + +let pp_split_cstr o (vl,v,c,_) = + Printf.fprintf o "(val x = %s ,%a,%s)" (string_of_num vl) pp_vect v (string_of_num c) + +(** [merge_cstr_info] takes: + - the intersection of bounds and + - the union of proofs + - [pos] and [neg] fields should be identical *) + +let merge_cstr_info i1 i2 = + let { pos = p1 ; neg = n1 ; bound = i1 ; prf = prf1 } = i1 + and { pos = p2 ; neg = n2 ; bound = i2 ; prf = prf2 } = i2 in + assert (p1 = p2 && n1 = n2) ; + match inter i1 i2 with + | None -> None (* Could directly raise a system contradiction exception *) + | Some bnd -> + Some { pos = p1 ; neg = n1 ; bound = bnd ; prf = And(prf1,prf2) } + +(** [xadd_cstr vect cstr_info] loads an constraint into the system. + The constraint is neither redundant nor contradictory. + @raise SystemContradiction if [cstr_info] returns [None] +*) + +let xadd_cstr vect cstr_info sys = + if debug && System.length sys mod 1000 = 0 then (print_string "*" ; flush stdout) ; + try + let info = System.find sys vect in + match merge_cstr_info cstr_info !info with + | None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf))) + | Some info' -> info := info' + with + | Not_found -> System.replace sys vect (ref cstr_info) + + +type cstr_ext = + | Contradiction (** The constraint is contradictory. + Typically, a [SystemContradiction] exception will be raised. *) + | Redundant (** The constrain is redundant. + Typically, the constraint will be dropped *) + | Cstr of vector * cstr_info (** Taken alone, the constraint is neither contradictory nor redundant. + Typically, it will be added to the constraint system. *) + +(** [normalise_cstr] : vector -> cstr_info -> cstr_ext *) +let normalise_cstr vect cinfo = + match norm_itv cinfo.bound with + | None -> Contradiction + | Some (l,r) -> + match vect with + | [] -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction + | (_,n)::_ -> Cstr( + (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect), + let divn x = x // n in + if sign_num n = 1 + then{cinfo with bound = (map_option divn l , map_option divn r) } + else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)}) + +(** For compatibility, there an external representation of constraints *) + +type cstr_compat = {coeffs : vector ; op : op ; cst : num} +and op = |Eq | Ge + +let string_of_op = function Eq -> "=" | Ge -> ">=" + + +let eval_op = function + | Eq -> (=/) + | Ge -> (>=/) + +let count v = + let rec count n p v = + match v with + | [] -> (n,p) + | (_,vl)::v -> let sg = sign_num vl in + assert (sg <> 0) ; + if sg = 1 then count n (p+1) v else count (n+1) p v in + count 0 0 v + + +let norm_cstr {coeffs = v ; op = o ; cst = c} idx = + let (n,p) = count v in + + normalise_cstr v {pos = p ; neg = n ; bound = + (match o with + | Eq -> Some c , Some c + | Ge -> Some c , None) ; + prf = Hyp idx } + + +(** [load_system l] takes a list of constraints of type [cstr_compat] + @return a system of constraints + @raise SystemContradiction if a contradiction is found +*) +let load_system l = + + let sys = System.create 1000 in + + let li = Mutils.mapi (fun e i -> (e,i)) l in + + let vars = List.fold_left (fun vrs (cstr,i) -> + match norm_cstr cstr i with + | Contradiction -> raise (SystemContradiction (Hyp i)) + | Redundant -> vrs + | Cstr(vect,info) -> + xadd_cstr vect info sys ; + List.fold_left (fun s (v,_) -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in + + {sys = sys ;vars = vars} + +let system_list sys = + let { sys = s ; vars = v } = sys in + System.fold (fun k bi l -> (k, !bi)::l) s [] + + +(** [add (v1,c1) (v2,c2) ] + precondition: (c1 <>/ Int 0 && c2 <>/ Int 0) + @return a pair [(v,ln)] such that + [v] is the sum of vector [v1] divided by [c1] and vector [v2] divided by [c2] + Note that the resulting vector is not normalised. +*) + +let add (v1,c1) (v2,c2) = + assert (c1 <>/ Int 0 && c2 <>/ Int 0) ; + + let rec xadd v1 v2 = + match v1 , v2 with + | (x1,n1)::v1' , (x2,n2)::v2' -> + if x1 = x2 + then + let n' = (n1 // c1) +/ (n2 // c2) in + if n' =/ Int 0 then xadd v1' v2' + else + let res = xadd v1' v2' in + (x1,n') ::res + else if x1 < x2 + then let res = xadd v1' v2 in + (x1, n1 // c1)::res + else let res = xadd v1 v2' in + (x2, n2 // c2)::res + | [] , [] -> [] + | [] , _ -> List.map (fun (x,vl) -> (x,vl // c2)) v2 + | _ , [] -> List.map (fun (x,vl) -> (x,vl // c1)) v1 in + + let res = xadd v1 v2 in + (res, count res) + +let add (v1,c1) (v2,c2) = + let res = add (v1,c1) (v2,c2) in + (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*) + res + +type tlr = (num * vector * cstr_info) list +type tm = (vector * cstr_info ) list + +(** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *) + +(** [split x vect info (l,m,r)] + @param v is the variable to eliminate + @param l contains constraints such that (e + a*x) // a >= c / a + @param r contains constraints such that (e + a*x) // - a >= c / -a + @param m contains constraints which do not mention [x] +*) + +let split x (vect: vector) info (l,m,r) = + match get x vect with + | None -> (* The constraint does not mention [x], store it in m *) + (l,(vect,info)::m,r) + | Some vl -> (* otherwise *) + + let cons_bound lst bd = + match bd with + | None -> lst + | Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in + + let lb,rb = info.bound in + if sign_num vl = 1 + then (cons_bound l lb,m,cons_bound r rb) + else (* sign_num vl = -1 *) + (cons_bound l rb,m,cons_bound r lb) + + +(** [project vr sys] projects system [sys] over the set of variables [ISet.remove vr sys.vars ]. + This is a one step Fourier elimination. +*) +let project vr sys = + + let (l,m,r) = System.fold (fun vect rf l_m_r -> split vr vect !rf l_m_r) sys.sys ([],[],[]) in + + let new_sys = System.create (System.length sys.sys) in + + (* Constraints in [m] belong to the projection - for those [vr] is already projected out *) + List.iter (fun (vect,info) -> System.replace new_sys vect (ref info) ) m ; + + let elim (v1,vect1,info1) (v2,vect2,info2) = + let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1 + and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in + + let bnd1 = from_option (fst bound1) + and bnd2 = from_option (fst bound2) in + let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in + let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2) in + (vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in + + List.iter(fun l_elem -> List.iter (fun r_elem -> + let (vect,info) = elim l_elem r_elem in + match normalise_cstr vect info with + | Redundant -> () + | Contradiction -> raise (SystemContradiction info.prf) + | Cstr(vect,info) -> xadd_cstr vect info new_sys) r ) l; + {sys = new_sys ; vars = ISet.remove vr sys.vars} + + +(** [project_using_eq] performs elimination by pivoting using an equation. + This is the counter_part of the [elim] sub-function of [!project]. + @param vr is the variable to be used as pivot + @param c is the coefficient of variable [vr] in vector [vect] + @param len is the length of the equation + @param bound is the bound of the equation + @param prf is the proof of the equation +*) + +let project_using_eq vr c vect bound prf (vect',info') = + match get vr vect' with + | Some c2 -> + let c1 = if c2 >=/ Int 0 then minus_num c else c in + + let c2 = abs_num c2 in + + let (vres,(n,p)) = add (vect,c1) (vect', c2) in + + let cst = bound // c1 in + + let bndres = + let f x = cst +/ x // c2 in + let (l,r) = info'.bound in + (map_option f l , map_option f r) in + + (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) + | None -> (vect',info') + +let elim_var_using_eq vr vect cst prf sys = + let c = from_option (get vr vect) in + + let elim_var = project_using_eq vr c vect cst prf in + + let new_sys = System.create (System.length sys.sys) in + + System.iter(fun vect iref -> + let (vect',info') = elim_var (vect,!iref) in + match normalise_cstr vect' info' with + | Redundant -> () + | Contradiction -> raise (SystemContradiction info'.prf) + | Cstr(vect,info') -> xadd_cstr vect info' new_sys) sys.sys ; + + {sys = new_sys ; vars = ISet.remove vr sys.vars} + + +(** [size sys] computes the number of entries in the system of constraints *) +let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0 + +module IMap = Map.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end) + +let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (string_of_num elt)) map () + +(** [eval_vect map vect] evaluates vector [vect] using the values of [map]. + If [map] binds all the variables of [vect], we get + [eval_vect map [(x1,v1);...;(xn,vn)] = (IMap.find x1 map * v1) + ... + (IMap.find xn map) * vn , []] + The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *) + +let eval_vect map vect = + let rec xeval_vect vect sum rst = + match vect with + | [] -> (sum,rst) + | (v,vl)::vect -> + try + let val_v = IMap.find v map in + xeval_vect vect (sum +/ (val_v */ vl)) rst + with + Not_found -> xeval_vect vect sum ((v,vl)::rst) in + xeval_vect vect (Int 0) [] + + +(** [restrict_bound n sum itv] returns the interval of [x] + given that (fst itv) <= x * n + sum <= (snd itv) *) +let restrict_bound n sum (itv:interval) = + let f x = (x -/ sum) // n in + let l,r = itv in + match sign_num n with + | 0 -> if in_bound itv sum + then (None,None) (* redundant *) + else failwith "SystemContradiction" + | 1 -> map_option f l , map_option f r + | _ -> map_option f r , map_option f l + + +(** [bound_of_variable map v sys] computes the interval of [v] in + [sys] given a mapping [map] binding all the other variables *) +let bound_of_variable map v sys = + System.fold (fun vect iref bnd -> + let sum,rst = eval_vect map vect in + let vl = match get v rst with + | None -> Int 0 + | Some v -> v in + match inter bnd (restrict_bound vl sum (!iref).bound) with + | None -> failwith "bound_of_variable: impossible" + | Some itv -> itv) sys (None,None) + + +(** [pick_small_value bnd] picks a value being closed to zero within the interval *) +let pick_small_value bnd = + match bnd with + | None , None -> Int 0 + | None , Some i -> if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i + | Some i,None -> if i <=/ (Int 0) then Int 0 else ceiling_num i + | Some i,Some j -> + if i <=/ Int 0 && Int 0 <=/ j + then Int 0 + else if ceiling_num i <=/ floor_num j + then ceiling_num i (* why not *) else i + + +(** [solution s1 sys_l = Some(sn,[(vn-1,sn-1);...; (v1,s1)]@sys_l)] + then [sn] is a system which contains only [black_v] -- if it existed in [s1] + and [sn+1] is obtained by projecting [vn] out of [sn] + @raise SystemContradiction if system [s] has no solution +*) + +let solve_sys black_v choose_eq choose_variable sys sys_l = + + let rec solve_sys sys sys_l = + if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys); + + let eqs = choose_eq sys in + try + let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in + if debug then + (Printf.printf "\nE %a = %s variable %i\n" pp_vect vect (string_of_num cst) v ; + flush stdout); + let sys' = elim_var_using_eq v vect cst ln sys in + solve_sys sys' ((v,sys)::sys_l) + with Not_found -> + let vars = choose_variable sys in + try + let (v,est) = (List.find (fun (v,_) -> v <> black_v) vars) in + if debug then (Printf.printf "\nV : %i esimate %f\n" v est ; flush stdout) ; + let sys' = project v sys in + solve_sys sys' ((v,sys)::sys_l) + with Not_found -> (* we are done *) Inl (sys,sys_l) in + solve_sys sys sys_l + + + + +let solve black_v choose_eq choose_variable cstrs = + + try + let sys = load_system cstrs in +(* Printf.printf "solve :\n %a" pp_system sys.sys ; *) + solve_sys black_v choose_eq choose_variable sys [] + with SystemContradiction prf -> Inr prf + + +(** The purpose of module [EstimateElimVar] is to try to estimate the cost of eliminating a variable. + The output is an ordered list of (variable,cost). +*) + +module EstimateElimVar = +struct + type sys_list = (vector * cstr_info) list + + let abstract_partition (v:int) (l: sys_list) = + + let rec xpart (l:sys_list) (ltl:sys_list) (n:int list) (z:int) (p:int list) = + match l with + | [] -> (ltl, n,z,p) + | (l1,info) ::rl -> + match l1 with + | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p + | (vr,vl)::rl1 -> + if v = vr + then + let cons_bound lst bd = + match bd with + | None -> lst + | Some bnd -> info.neg+info.pos::lst in + + let lb,rb = info.bound in + if sign_num vl = 1 + then xpart rl ((rl1,info)::ltl) (cons_bound n lb) z (cons_bound p rb) + else xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb) + else + (* the variable is greater *) + xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p + + in + let (sys',n,z,p) = xpart l [] [] 0 [] in + + let ln = float_of_int (List.length n) in + let sn = float_of_int (List.fold_left (+) 0 n) in + let lp = float_of_int (List.length p) in + let sp = float_of_int (List.fold_left (+) 0 p) in + (sys', float_of_int z +. lp *. sn +. ln *. sp -. lp*.ln) + + + let choose_variable sys = + let {sys = s ; vars = v} = sys in + + let sl = system_list sys in + + let evals = fst + (ISet.fold (fun v (eval,s) -> let ts,vl = abstract_partition v s in + ((v,vl)::eval, ts)) v ([],sl)) in + + List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) evals + + +end +open EstimateElimVar + +(** The module [EstimateElimEq] is similar to [EstimateElimVar] but it orders equations. +*) +module EstimateElimEq = +struct + + let itv_point bnd = + match bnd with + |(Some a, Some b) -> a =/ b + | _ -> false + + let eq_bound bnd c = + match bnd with + |(Some a, Some b) -> a =/ b && c =/ b + | _ -> false + + + let rec unroll_until v l = + match l with + | [] -> (false,[]) + | (i,_)::rl -> if i = v + then (true,rl) + else if i < v then unroll_until v rl else (false,l) + + + let choose_primal_equation eqs sys_l = + + let is_primal_equation_var v = + List.fold_left (fun (nb_eq,nb_cst) (vect,info) -> + if fst (unroll_until v vect) + then if itv_point info.bound then (nb_eq + 1,nb_cst) else (nb_eq,nb_cst) + else (nb_eq,nb_cst)) (0,0) sys_l in + + let rec find_var vect = + match vect with + | [] -> None + | (i,_)::vect -> + let (nb_eq,nb_cst) = is_primal_equation_var i in + if nb_eq = 2 && nb_cst = 0 + then Some i else find_var vect in + + let rec find_eq_var eqs = + match eqs with + | [] -> None + | (vect,a,prf,ln)::l -> + match find_var vect with + | None -> find_eq_var l + | Some r -> Some (r,vect,a,prf,ln) + in + + + find_eq_var eqs + + + + + let choose_equality_var sys = + + let sys_l = system_list sys in + + let equalities = List.fold_left + (fun l (vect,info) -> + match info.bound with + | Some a , Some b -> + if a =/ b then (* This an equation *) + (vect,a,info.prf,info.neg+info.pos)::l else l + | _ -> l + ) [] sys_l in + + let rec estimate_cost v ct sysl acc tlsys = + match sysl with + | [] -> (acc,tlsys) + | (l,info)::rsys -> + let ln = info.pos + info.neg in + let (b,l) = unroll_until v l in + match b with + | true -> + if itv_point info.bound + then estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) (* this is free *) + else estimate_cost v ct rsys (acc+ln+ct) ((l,info)::tlsys) (* should be more ? *) + | false -> estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) in + + match choose_primal_equation equalities sys_l with + | None -> + let cost_eq eq const prf ln acc_costs = + + let rec cost_eq eqr sysl costs = + match eqr with + | [] -> costs + | (v,_) ::eqr -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in + cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in + cost_eq eq sys_l acc_costs in + + let all_costs = List.fold_left (fun all_costs (vect,const,prf,ln) -> cost_eq vect const prf ln all_costs) [] equalities in + + (* pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *) + + List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) all_costs + | Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0] + + +end +open EstimateElimEq + +module Fourier = +struct + + let optimise vect l = + (* We add a dummy (fresh) variable for vector *) + let fresh = + List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 l in + let cstr = { + coeffs = Vect.set fresh (Int (-1)) vect ; + op = Eq ; + cst = (Int 0)} in + match solve fresh choose_equality_var choose_variable (cstr::l) with + | Inr prf -> None (* This is an unsatisfiability proof *) + | Inl (s,_) -> + try + Some (bound_of_variable IMap.empty fresh s.sys) + with + x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None + + + let find_point cstrs = + + match solve max_int choose_equality_var choose_variable cstrs with + | Inr prf -> Inr prf + | Inl (_,l) -> + + let rec rebuild_solution l map = + match l with + | [] -> map + | (v,e)::l -> + let itv = bound_of_variable map v e.sys in + let map = IMap.add v (pick_small_value itv) map in + rebuild_solution l map + in + + let map = rebuild_solution l IMap.empty in + let vect = List.rev (IMap.fold (fun v i vect -> (v,i)::vect) map []) in +(* Printf.printf "SOLUTION %a" pp_vect vect ; *) + let res = Inl vect in + res + + +end + + +module Proof = +struct + + + + +(** A proof term in the sense of a ZMicromega.RatProof is a positive combination of the hypotheses which leads to a contradiction. + The proofs constructed by Fourier elimination are more like execution traces: + - certain facts are recorded but are useless + - certain inferences are implicit. + The following code implements proof reconstruction. +*) + let add x y = fst (add x y) + + + let forall_pairs f l1 l2 = + List.fold_left (fun acc e1 -> + List.fold_left (fun acc e2 -> + match f e1 e2 with + | None -> acc + | Some v -> v::acc) acc l2) [] l1 + + + let add_op x y = + match x , y with + | Eq , Eq -> Eq + | _ -> Ge + + + let pivot v (p1,c1) (p2,c2) = + let {coeffs = v1 ; op = op1 ; cst = n1} = c1 + and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in + + match Vect.get v v1 , Vect.get v v2 with + | None , _ | _ , None -> None + | Some a , Some b -> + if (sign_num a) * (sign_num b) = -1 + then Some (add (p1,abs_num a) (p2,abs_num b) , + {coeffs = add (v1,abs_num a) (v2,abs_num b) ; + op = add_op op1 op2 ; + cst = n1 // (abs_num a) +/ n2 // (abs_num b) }) + else if op1 = Eq + then Some (add (p1,minus_num (a // b)) (p2,Int 1), + {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ; + op = add_op op1 op2; + cst = n1 // (minus_num (a// b)) +/ n2 // (Int 1)}) + else if op2 = Eq + then + Some (add (p2,minus_num (b // a)) (p1,Int 1), + {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ; + op = add_op op1 op2; + cst = n2 // (minus_num (b// a)) +/ n1 // (Int 1)}) + else None (* op2 could be Eq ... this might happen *) + + + let normalise_proofs l = + List.fold_left (fun acc (prf,cstr) -> + match acc with + | Inr _ -> acc (* I already found a contradiction *) + | Inl acc -> + match norm_cstr cstr 0 with + | Redundant -> Inl acc + | Contradiction -> Inr (prf,cstr) + | Cstr(v,info) -> Inl ((prf,cstr,v,info)::acc)) (Inl []) l + + + type oproof = (vector * cstr_compat * num) option + + let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) = + let (l,r) = info.bound in + + let keep p ob bd = + match ob , bd with + | None , None -> None + | None , Some b -> Some(prf,cstr,b) + | Some _ , None -> ob + | Some(prfl,cstrl,bl) , Some b -> if p bl b then Some(prf,cstr, b) else ob in + + let oleft = keep (<=/) oleft l in + let oright = keep (>=/) oright r in + (* Now, there might be a contradiction *) + match oleft , oright with + | None , _ | _ , None -> Inl (oleft,oright) + | Some(prfl,cstrl,l) , Some(prfr,cstrr,r) -> + if l <=/ r + then Inl (oleft,oright) + else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*) + match cstrr.coeffs with + | [] -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *) + | (v,_)::_ -> + match pivot v (prfl,cstrl) (prfr,cstrr) with + | None -> failwith "merge_proof : pivot is not possible" + | Some x -> Inr x + +let mk_proof hyps prf = + (* I am keeping list - I might have a proof for the left bound and a proof for the right bound. + If I perform aggressive elimination of redundancies, I expect the list to be of length at most 2. + For each proof list, all the vectors should be of the form a.v for different constants a. + *) + + let rec mk_proof prf = + match prf with + | Hyp i -> [ ([i, Int 1] , List.nth hyps i) ] + + | Elim(v,prf1,prf2) -> + let prfsl = mk_proof prf1 + and prfsr = mk_proof prf2 in + (* I take only the pairs for which the elimination is meaningfull *) + forall_pairs (pivot v) prfsl prfsr + | And(prf1,prf2) -> + let prfsl1 = mk_proof prf1 + and prfsl2 = mk_proof prf2 in + (* detect trivial redundancies and contradictions *) + match normalise_proofs (prfsl1@prfsl2) with + | Inr x -> [x] (* This is a contradiction - this should be the end of the proof *) + | Inl l -> (* All the vectors are the same *) + let prfs = + List.fold_left (fun acc e -> + match acc with + | Inr _ -> acc (* I have a contradiction *) + | Inl (oleft,oright) -> merge_proof oleft e oright) (Inl(None,None)) l in + match prfs with + | Inr x -> [x] + | Inl (oleft,oright) -> + match oleft , oright with + | None , None -> [] + | None , Some(prf,cstr,_) | Some(prf,cstr,_) , None -> [prf,cstr] + | Some(prf1,cstr1,_) , Some(prf2,cstr2,_) -> [prf1,cstr1;prf2,cstr2] in + + mk_proof prf + + +end + diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml new file mode 100644 index 00000000..c350ed0f --- /dev/null +++ b/plugins/micromega/micromega.ml @@ -0,0 +1,1703 @@ +(** val negb : bool -> bool **) + +let negb = function + | true -> false + | false -> true + +type nat = + | O + | S of nat + +type comparison = + | Eq + | Lt + | Gt + +(** val compOpp : comparison -> comparison **) + +let compOpp = function + | Eq -> Eq + | Lt -> Gt + | Gt -> Lt + +(** val plus : nat -> nat -> nat **) + +let rec plus n0 m = + match n0 with + | O -> m + | S p -> S (plus p m) + +(** val app : 'a1 list -> 'a1 list -> 'a1 list **) + +let rec app l m = + match l with + | [] -> m + | a :: l1 -> a :: (app l1 m) + +(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) + +let rec nth n0 l default = + match n0 with + | O -> (match l with + | [] -> default + | x :: l' -> x) + | S m -> (match l with + | [] -> default + | x :: t0 -> nth m t0 default) + +(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) + +let rec map f = function + | [] -> [] + | a :: t0 -> (f a) :: (map f t0) + +type positive = + | XI of positive + | XO of positive + | XH + +(** val psucc : positive -> positive **) + +let rec psucc = function + | XI p -> XO (psucc p) + | XO p -> XI p + | XH -> XO XH + +(** val pplus : positive -> positive -> positive **) + +let rec pplus x y = + match x with + | XI p -> + (match y with + | XI q0 -> XO (pplus_carry p q0) + | XO q0 -> XI (pplus p q0) + | XH -> XO (psucc p)) + | XO p -> + (match y with + | XI q0 -> XI (pplus p q0) + | XO q0 -> XO (pplus p q0) + | XH -> XI p) + | XH -> + (match y with + | XI q0 -> XO (psucc q0) + | XO q0 -> XI q0 + | XH -> XO XH) + +(** val pplus_carry : positive -> positive -> positive **) + +and pplus_carry x y = + match x with + | XI p -> + (match y with + | XI q0 -> XI (pplus_carry p q0) + | XO q0 -> XO (pplus_carry p q0) + | XH -> XI (psucc p)) + | XO p -> + (match y with + | XI q0 -> XO (pplus_carry p q0) + | XO q0 -> XI (pplus p q0) + | XH -> XO (psucc p)) + | XH -> + (match y with + | XI q0 -> XI (psucc q0) + | XO q0 -> XO (psucc q0) + | XH -> XI XH) + +(** val p_of_succ_nat : nat -> positive **) + +let rec p_of_succ_nat = function + | O -> XH + | S x -> psucc (p_of_succ_nat x) + +(** val pdouble_minus_one : positive -> positive **) + +let rec pdouble_minus_one = function + | XI p -> XI (XO p) + | XO p -> XI (pdouble_minus_one p) + | XH -> XH + +type positive_mask = + | IsNul + | IsPos of positive + | IsNeg + +(** val pdouble_plus_one_mask : positive_mask -> positive_mask **) + +let pdouble_plus_one_mask = function + | IsNul -> IsPos XH + | IsPos p -> IsPos (XI p) + | IsNeg -> IsNeg + +(** val pdouble_mask : positive_mask -> positive_mask **) + +let pdouble_mask = function + | IsNul -> IsNul + | IsPos p -> IsPos (XO p) + | IsNeg -> IsNeg + +(** val pdouble_minus_two : positive -> positive_mask **) + +let pdouble_minus_two = function + | XI p -> IsPos (XO (XO p)) + | XO p -> IsPos (XO (pdouble_minus_one p)) + | XH -> IsNul + +(** val pminus_mask : positive -> positive -> positive_mask **) + +let rec pminus_mask x y = + match x with + | XI p -> + (match y with + | XI q0 -> pdouble_mask (pminus_mask p q0) + | XO q0 -> pdouble_plus_one_mask (pminus_mask p q0) + | XH -> IsPos (XO p)) + | XO p -> + (match y with + | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0) + | XO q0 -> pdouble_mask (pminus_mask p q0) + | XH -> IsPos (pdouble_minus_one p)) + | XH -> (match y with + | XH -> IsNul + | _ -> IsNeg) + +(** val pminus_mask_carry : positive -> positive -> positive_mask **) + +and pminus_mask_carry x y = + match x with + | XI p -> + (match y with + | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0) + | XO q0 -> pdouble_mask (pminus_mask p q0) + | XH -> IsPos (pdouble_minus_one p)) + | XO p -> + (match y with + | XI q0 -> pdouble_mask (pminus_mask_carry p q0) + | XO q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0) + | XH -> pdouble_minus_two p) + | XH -> IsNeg + +(** val pminus : positive -> positive -> positive **) + +let pminus x y = + match pminus_mask x y with + | IsPos z0 -> z0 + | _ -> XH + +(** val pmult : positive -> positive -> positive **) + +let rec pmult x y = + match x with + | XI p -> pplus y (XO (pmult p y)) + | XO p -> XO (pmult p y) + | XH -> y + +(** val pcompare : positive -> positive -> comparison -> comparison **) + +let rec pcompare x y r = + match x with + | XI p -> + (match y with + | XI q0 -> pcompare p q0 r + | XO q0 -> pcompare p q0 Gt + | XH -> Gt) + | XO p -> + (match y with + | XI q0 -> pcompare p q0 Lt + | XO q0 -> pcompare p q0 r + | XH -> Gt) + | XH -> (match y with + | XH -> r + | _ -> Lt) + +(** val psize : positive -> nat **) + +let rec psize = function + | XI p2 -> S (psize p2) + | XO p2 -> S (psize p2) + | XH -> S O + +type n = + | N0 + | Npos of positive + +(** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) + +let rec pow_pos rmul x = function + | XI i0 -> let p = pow_pos rmul x i0 in rmul x (rmul p p) + | XO i0 -> let p = pow_pos rmul x i0 in rmul p p + | XH -> x + +type z = + | Z0 + | Zpos of positive + | Zneg of positive + +(** val zdouble_plus_one : z -> z **) + +let zdouble_plus_one = function + | Z0 -> Zpos XH + | Zpos p -> Zpos (XI p) + | Zneg p -> Zneg (pdouble_minus_one p) + +(** val zdouble_minus_one : z -> z **) + +let zdouble_minus_one = function + | Z0 -> Zneg XH + | Zpos p -> Zpos (pdouble_minus_one p) + | Zneg p -> Zneg (XI p) + +(** val zdouble : z -> z **) + +let zdouble = function + | Z0 -> Z0 + | Zpos p -> Zpos (XO p) + | Zneg p -> Zneg (XO p) + +(** val zPminus : positive -> positive -> z **) + +let rec zPminus x y = + match x with + | XI p -> + (match y with + | XI q0 -> zdouble (zPminus p q0) + | XO q0 -> zdouble_plus_one (zPminus p q0) + | XH -> Zpos (XO p)) + | XO p -> + (match y with + | XI q0 -> zdouble_minus_one (zPminus p q0) + | XO q0 -> zdouble (zPminus p q0) + | XH -> Zpos (pdouble_minus_one p)) + | XH -> + (match y with + | XI q0 -> Zneg (XO q0) + | XO q0 -> Zneg (pdouble_minus_one q0) + | XH -> Z0) + +(** val zplus : z -> z -> z **) + +let zplus x y = + match x with + | Z0 -> y + | Zpos x' -> + (match y with + | Z0 -> Zpos x' + | Zpos y' -> Zpos (pplus x' y') + | Zneg y' -> + (match pcompare x' y' Eq with + | Eq -> Z0 + | Lt -> Zneg (pminus y' x') + | Gt -> Zpos (pminus x' y'))) + | Zneg x' -> + (match y with + | Z0 -> Zneg x' + | Zpos y' -> + (match pcompare x' y' Eq with + | Eq -> Z0 + | Lt -> Zpos (pminus y' x') + | Gt -> Zneg (pminus x' y')) + | Zneg y' -> Zneg (pplus x' y')) + +(** val zopp : z -> z **) + +let zopp = function + | Z0 -> Z0 + | Zpos x0 -> Zneg x0 + | Zneg x0 -> Zpos x0 + +(** val zminus : z -> z -> z **) + +let zminus m n0 = + zplus m (zopp n0) + +(** val zmult : z -> z -> z **) + +let zmult x y = + match x with + | Z0 -> Z0 + | Zpos x' -> + (match y with + | Z0 -> Z0 + | Zpos y' -> Zpos (pmult x' y') + | Zneg y' -> Zneg (pmult x' y')) + | Zneg x' -> + (match y with + | Z0 -> Z0 + | Zpos y' -> Zneg (pmult x' y') + | Zneg y' -> Zpos (pmult x' y')) + +(** val zcompare : z -> z -> comparison **) + +let zcompare x y = + match x with + | Z0 -> (match y with + | Z0 -> Eq + | Zpos y' -> Lt + | Zneg y' -> Gt) + | Zpos x' -> (match y with + | Zpos y' -> pcompare x' y' Eq + | _ -> Gt) + | Zneg x' -> + (match y with + | Zneg y' -> compOpp (pcompare x' y' Eq) + | _ -> Lt) + +(** val zabs : z -> z **) + +let zabs = function + | Z0 -> Z0 + | Zpos p -> Zpos p + | Zneg p -> Zpos p + +(** val zmax : z -> z -> z **) + +let zmax m n0 = + match zcompare m n0 with + | Lt -> n0 + | _ -> m + +(** val zle_bool : z -> z -> bool **) + +let zle_bool x y = + match zcompare x y with + | Gt -> false + | _ -> true + +(** val zge_bool : z -> z -> bool **) + +let zge_bool x y = + match zcompare x y with + | Lt -> false + | _ -> true + +(** val zgt_bool : z -> z -> bool **) + +let zgt_bool x y = + match zcompare x y with + | Gt -> true + | _ -> false + +(** val zeq_bool : z -> z -> bool **) + +let zeq_bool x y = + match zcompare x y with + | Eq -> true + | _ -> false + +(** val n_of_nat : nat -> n **) + +let n_of_nat = function + | O -> N0 + | S n' -> Npos (p_of_succ_nat n') + +(** val zdiv_eucl_POS : positive -> z -> z * z **) + +let rec zdiv_eucl_POS a b = + match a with + | XI a' -> + let q0 , r = zdiv_eucl_POS a' b in + let r' = zplus (zmult (Zpos (XO XH)) r) (Zpos XH) in + if zgt_bool b r' + then (zmult (Zpos (XO XH)) q0) , r' + else (zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)) , (zminus r' b) + | XO a' -> + let q0 , r = zdiv_eucl_POS a' b in + let r' = zmult (Zpos (XO XH)) r in + if zgt_bool b r' + then (zmult (Zpos (XO XH)) q0) , r' + else (zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)) , (zminus r' b) + | XH -> + if zge_bool b (Zpos (XO XH)) then Z0 , (Zpos XH) else (Zpos XH) , Z0 + +(** val zdiv_eucl : z -> z -> z * z **) + +let zdiv_eucl a b = + match a with + | Z0 -> Z0 , Z0 + | Zpos a' -> + (match b with + | Z0 -> Z0 , Z0 + | Zpos p -> zdiv_eucl_POS a' b + | Zneg b' -> + let q0 , r = zdiv_eucl_POS a' (Zpos b') in + (match r with + | Z0 -> (zopp q0) , Z0 + | _ -> (zopp (zplus q0 (Zpos XH))) , (zplus b r))) + | Zneg a' -> + (match b with + | Z0 -> Z0 , Z0 + | Zpos p -> + let q0 , r = zdiv_eucl_POS a' b in + (match r with + | Z0 -> (zopp q0) , Z0 + | _ -> (zopp (zplus q0 (Zpos XH))) , (zminus b r)) + | Zneg b' -> + let q0 , r = zdiv_eucl_POS a' (Zpos b') in q0 , (zopp r)) + +(** val zdiv : z -> z -> z **) + +let zdiv a b = + let q0 , x = zdiv_eucl a b in q0 + +type 'c pol = + | Pc of 'c + | Pinj of positive * 'c pol + | PX of 'c pol * positive * 'c pol + +(** val p0 : 'a1 -> 'a1 pol **) + +let p0 cO = + Pc cO + +(** val p1 : 'a1 -> 'a1 pol **) + +let p1 cI = + Pc cI + +(** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **) + +let rec peq ceqb p p' = + match p with + | Pc c -> (match p' with + | Pc c' -> ceqb c c' + | _ -> false) + | Pinj (j, q0) -> + (match p' with + | Pinj (j', q') -> + (match pcompare j j' Eq with + | Eq -> peq ceqb q0 q' + | _ -> false) + | _ -> false) + | PX (p2, i, q0) -> + (match p' with + | PX (p'0, i', q') -> + (match pcompare i i' Eq with + | Eq -> if peq ceqb p2 p'0 then peq ceqb q0 q' else false + | _ -> false) + | _ -> false) + +(** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) + +let mkPinj_pred j p = + match j with + | XI j0 -> Pinj ((XO j0), p) + | XO j0 -> Pinj ((pdouble_minus_one j0), p) + | XH -> p + +(** val mkPX : + 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + +let mkPX cO ceqb p i q0 = + match p with + | Pc c -> + if ceqb c cO + then (match q0 with + | Pc c0 -> q0 + | Pinj (j', q1) -> Pinj ((pplus XH j'), q1) + | PX (p2, p3, p4) -> Pinj (XH, q0)) + else PX (p, i, q0) + | Pinj (p2, p3) -> PX (p, i, q0) + | PX (p', i', q') -> + if peq ceqb q' (p0 cO) + then PX (p', (pplus i' i), q0) + else PX (p, i, q0) + +(** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **) + +let mkXi cO cI i = + PX ((p1 cI), i, (p0 cO)) + +(** val mkX : 'a1 -> 'a1 -> 'a1 pol **) + +let mkX cO cI = + mkXi cO cI XH + +(** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) + +let rec popp copp = function + | Pc c -> Pc (copp c) + | Pinj (j, q0) -> Pinj (j, (popp copp q0)) + | PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0)) + +(** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) + +let rec paddC cadd p c = + match p with + | Pc c1 -> Pc (cadd c1 c) + | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c)) + | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c)) + +(** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) + +let rec psubC csub p c = + match p with + | Pc c1 -> Pc (csub c1 c) + | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c)) + | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c)) + +(** val paddI : + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol **) + +let rec paddI cadd pop q0 j = function + | Pc c -> + let p2 = paddC cadd q0 c in + (match p2 with + | Pc c0 -> p2 + | Pinj (j', q1) -> Pinj ((pplus j j'), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Pinj (j', q') -> + (match zPminus j' j with + | Z0 -> + let p2 = pop q' q0 in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Zpos k -> + let p2 = pop (Pinj (k, q')) q0 in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Zneg k -> + let p2 = paddI cadd pop q0 k q' in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1) + | PX (p3, p4, p5) -> Pinj (j', p2))) + | PX (p2, i, q') -> + (match j with + | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q')) + | XO j0 -> PX (p2, i, (paddI cadd pop q0 (pdouble_minus_one j0) q')) + | XH -> PX (p2, i, (pop q' q0))) + +(** val psubI : + ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> + 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + +let rec psubI cadd copp pop q0 j = function + | Pc c -> + let p2 = paddC cadd (popp copp q0) c in + (match p2 with + | Pc c0 -> p2 + | Pinj (j', q1) -> Pinj ((pplus j j'), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Pinj (j', q') -> + (match zPminus j' j with + | Z0 -> + let p2 = pop q' q0 in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Zpos k -> + let p2 = pop (Pinj (k, q')) q0 in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Zneg k -> + let p2 = psubI cadd copp pop q0 k q' in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1) + | PX (p3, p4, p5) -> Pinj (j', p2))) + | PX (p2, i, q') -> + (match j with + | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q')) + | XO j0 -> PX (p2, i, + (psubI cadd copp pop q0 (pdouble_minus_one j0) q')) + | XH -> PX (p2, i, (pop q' q0))) + +(** val paddX : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol + -> positive -> 'a1 pol -> 'a1 pol **) + +let rec paddX cO ceqb pop p' i' p = match p with + | Pc c -> PX (p', i', p) + | Pinj (j, q') -> + (match j with + | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) + | XO j0 -> PX (p', i', (Pinj ((pdouble_minus_one j0), q'))) + | XH -> PX (p', i', q')) + | PX (p2, i, q') -> + (match zPminus i i' with + | Z0 -> mkPX cO ceqb (pop p2 p') i q' + | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' + | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q') + +(** val psubX : + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 + pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + +let rec psubX cO copp ceqb pop p' i' p = match p with + | Pc c -> PX ((popp copp p'), i', p) + | Pinj (j, q') -> + (match j with + | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q'))) + | XO j0 -> PX ((popp copp p'), i', (Pinj ( + (pdouble_minus_one j0), q'))) + | XH -> PX ((popp copp p'), i', q')) + | PX (p2, i, q') -> + (match zPminus i i' with + | Z0 -> mkPX cO ceqb (pop p2 p') i q' + | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' + | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q') + +(** val padd : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol + -> 'a1 pol **) + +let rec padd cO cadd ceqb p = function + | Pc c' -> paddC cadd p c' + | Pinj (j', q') -> paddI cadd (fun x x0 -> padd cO cadd ceqb x x0) q' j' p + | PX (p'0, i', q') -> + (match p with + | Pc c -> PX (p'0, i', (paddC cadd q' c)) + | Pinj (j, q0) -> + (match j with + | XI j0 -> PX (p'0, i', + (padd cO cadd ceqb (Pinj ((XO j0), q0)) q')) + | XO j0 -> PX (p'0, i', + (padd cO cadd ceqb (Pinj ((pdouble_minus_one j0), q0)) + q')) + | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q'))) + | PX (p2, i, q0) -> + (match zPminus i i' with + | Z0 -> + mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i + (padd cO cadd ceqb q0 q') + | Zpos k -> + mkPX cO ceqb + (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' + (padd cO cadd ceqb q0 q') + | Zneg k -> + mkPX cO ceqb + (paddX cO ceqb (fun x x0 -> padd cO cadd ceqb x x0) p'0 + k p2) i (padd cO cadd ceqb q0 q'))) + +(** val psub : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 + -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) + +let rec psub cO cadd csub copp ceqb p = function + | Pc c' -> psubC csub p c' + | Pinj (j', q') -> + psubI cadd copp (fun x x0 -> psub cO cadd csub copp ceqb x x0) q' j' p + | PX (p'0, i', q') -> + (match p with + | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c)) + | Pinj (j, q0) -> + (match j with + | XI j0 -> PX ((popp copp p'0), i', + (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q')) + | XO j0 -> PX ((popp copp p'0), i', + (psub cO cadd csub copp ceqb (Pinj + ((pdouble_minus_one j0), q0)) q')) + | XH -> PX ((popp copp p'0), i', + (psub cO cadd csub copp ceqb q0 q'))) + | PX (p2, i, q0) -> + (match zPminus i i' with + | Z0 -> + mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i + (psub cO cadd csub copp ceqb q0 q') + | Zpos k -> + mkPX cO ceqb + (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) + i' (psub cO cadd csub copp ceqb q0 q') + | Zneg k -> + mkPX cO ceqb + (psubX cO copp ceqb (fun x x0 -> + psub cO cadd csub copp ceqb x x0) p'0 k p2) i + (psub cO cadd csub copp ceqb q0 q'))) + +(** val pmulC_aux : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> + 'a1 pol **) + +let rec pmulC_aux cO cmul ceqb p c = + match p with + | Pc c' -> Pc (cmul c' c) + | Pinj (j, q0) -> + let p2 = pmulC_aux cO cmul ceqb q0 c in + (match p2 with + | Pc c0 -> p2 + | Pinj (j', q1) -> Pinj ((pplus j j'), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | PX (p2, i, q0) -> + mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i + (pmulC_aux cO cmul ceqb q0 c) + +(** val pmulC : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> + 'a1 -> 'a1 pol **) + +let pmulC cO cI cmul ceqb p c = + if ceqb c cO + then p0 cO + else if ceqb c cI then p else pmulC_aux cO cmul ceqb p c + +(** val pmulI : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> + 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + +let rec pmulI cO cI cmul ceqb pmul0 q0 j = function + | Pc c -> + let p2 = pmulC cO cI cmul ceqb q0 c in + (match p2 with + | Pc c0 -> p2 + | Pinj (j', q1) -> Pinj ((pplus j j'), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Pinj (j', q') -> + (match zPminus j' j with + | Z0 -> + let p2 = pmul0 q' q0 in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Zpos k -> + let p2 = pmul0 (Pinj (k, q')) q0 in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) + | PX (p3, p4, p5) -> Pinj (j, p2)) + | Zneg k -> + let p2 = pmulI cO cI cmul ceqb pmul0 q0 k q' in + (match p2 with + | Pc c -> p2 + | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1) + | PX (p3, p4, p5) -> Pinj (j', p2))) + | PX (p', i', q') -> + (match j with + | XI j' -> + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' + (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q') + | XO j' -> + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' + (pmulI cO cI cmul ceqb pmul0 q0 (pdouble_minus_one j') q') + | XH -> + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' + (pmul0 q' q0)) + +(** val pmul : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) + +let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with + | Pc c -> pmulC cO cI cmul ceqb p c + | Pinj (j', q') -> + pmulI cO cI cmul ceqb (fun x x0 -> pmul cO cI cadd cmul ceqb x x0) q' + j' p + | PX (p', i', q') -> + (match p with + | Pc c -> pmulC cO cI cmul ceqb p'' c + | Pinj (j, q0) -> + mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' + (match j with + | XI j0 -> + pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q' + | XO j0 -> + pmul cO cI cadd cmul ceqb (Pinj + ((pdouble_minus_one j0), q0)) q' + | XH -> pmul cO cI cadd cmul ceqb q0 q') + | PX (p2, i, q0) -> + padd cO cadd ceqb + (mkPX cO ceqb + (padd cO cadd ceqb + (mkPX cO ceqb (pmul cO cI cadd cmul ceqb p2 p') i (p0 cO)) + (pmul cO cI cadd cmul ceqb + (match q0 with + | Pc c -> q0 + | Pinj (j', q1) -> Pinj ((pplus XH j'), q1) + | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i' + (p0 cO)) + (mkPX cO ceqb + (pmulI cO cI cmul ceqb (fun x x0 -> + pmul cO cI cadd cmul ceqb x x0) q' XH p2) i + (pmul cO cI cadd cmul ceqb q0 q'))) + +(** val psquare : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 pol -> 'a1 pol **) + +let rec psquare cO cI cadd cmul ceqb = function + | Pc c -> Pc (cmul c c) + | Pinj (j, q0) -> Pinj (j, (psquare cO cI cadd cmul ceqb q0)) + | PX (p2, i, q0) -> + mkPX cO ceqb + (padd cO cadd ceqb + (mkPX cO ceqb (psquare cO cI cadd cmul ceqb p2) i (p0 cO)) + (pmul cO cI cadd cmul ceqb p2 + (let p3 = pmulC cO cI cmul ceqb q0 (cadd cI cI) in + match p3 with + | Pc c -> p3 + | Pinj (j', q1) -> Pinj ((pplus XH j'), q1) + | PX (p4, p5, p6) -> Pinj (XH, p3)))) i + (psquare cO cI cadd cmul ceqb q0) + +type 'c pExpr = + | PEc of 'c + | PEX of positive + | PEadd of 'c pExpr * 'c pExpr + | PEsub of 'c pExpr * 'c pExpr + | PEmul of 'c pExpr * 'c pExpr + | PEopp of 'c pExpr + | PEpow of 'c pExpr * n + +(** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **) + +let mk_X cO cI j = + mkPinj_pred j (mkX cO cI) + +(** val ppow_pos : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 + pol **) + +let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function + | XI p3 -> + subst_l + (pmul cO cI cadd cmul ceqb + (ppow_pos cO cI cadd cmul ceqb subst_l + (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p) + | XO p3 -> + ppow_pos cO cI cadd cmul ceqb subst_l + (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3 + | XH -> subst_l (pmul cO cI cadd cmul ceqb res p) + +(** val ppow_N : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **) + +let ppow_N cO cI cadd cmul ceqb subst_l p = function + | N0 -> p1 cI + | Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 + +(** val norm_aux : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) + +let rec norm_aux cO cI cadd cmul csub copp ceqb = function + | PEc c -> Pc c + | PEX j -> mk_X cO cI j + | PEadd (pe1, pe2) -> + (match pe1 with + | PEopp pe3 -> + psub cO cadd csub copp ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe2) + (norm_aux cO cI cadd cmul csub copp ceqb pe3) + | _ -> + (match pe2 with + | PEopp pe3 -> + psub cO cadd csub copp ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe3) + | _ -> + padd cO cadd ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe2))) + | PEsub (pe1, pe2) -> + psub cO cadd csub copp ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe2) + | PEmul (pe1, pe2) -> + pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe2) + | PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1) + | PEpow (pe1, n0) -> + ppow_N cO cI cadd cmul ceqb (fun p -> p) + (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 + +type 'a bFormula = + | TT + | FF + | X + | A of 'a + | Cj of 'a bFormula * 'a bFormula + | D of 'a bFormula * 'a bFormula + | N of 'a bFormula + | I of 'a bFormula * 'a bFormula + +type 'term' clause = 'term' list + +type 'term' cnf = 'term' clause list + +(** val tt : 'a1 cnf **) + +let tt = + [] + +(** val ff : 'a1 cnf **) + +let ff = + [] :: [] + +(** val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf **) + +let or_clause_cnf t0 f = + map (fun x -> app t0 x) f + +(** val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) + +let rec or_cnf f f' = + match f with + | [] -> tt + | e :: rst -> app (or_cnf rst f') (or_clause_cnf e f') + +(** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) + +let and_cnf f1 f2 = + app f1 f2 + +(** val xcnf : + ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) + +let rec xcnf normalise0 negate0 pol0 = function + | TT -> if pol0 then tt else ff + | FF -> if pol0 then ff else tt + | X -> ff + | A x -> if pol0 then normalise0 x else negate0 x + | Cj (e1, e2) -> + if pol0 + then and_cnf (xcnf normalise0 negate0 pol0 e1) + (xcnf normalise0 negate0 pol0 e2) + else or_cnf (xcnf normalise0 negate0 pol0 e1) + (xcnf normalise0 negate0 pol0 e2) + | D (e1, e2) -> + if pol0 + then or_cnf (xcnf normalise0 negate0 pol0 e1) + (xcnf normalise0 negate0 pol0 e2) + else and_cnf (xcnf normalise0 negate0 pol0 e1) + (xcnf normalise0 negate0 pol0 e2) + | N e -> xcnf normalise0 negate0 (negb pol0) e + | I (e1, e2) -> + if pol0 + then or_cnf (xcnf normalise0 negate0 (negb pol0) e1) + (xcnf normalise0 negate0 pol0 e2) + else and_cnf (xcnf normalise0 negate0 (negb pol0) e1) + (xcnf normalise0 negate0 pol0 e2) + +(** val cnf_checker : + ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **) + +let rec cnf_checker checker f l = + match f with + | [] -> true + | e :: f0 -> + (match l with + | [] -> false + | c :: l0 -> + if checker e c then cnf_checker checker f0 l0 else false) + +(** val tauto_checker : + ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 + bFormula -> 'a3 list -> bool **) + +let tauto_checker normalise0 negate0 checker f w = + cnf_checker checker (xcnf normalise0 negate0 true f) w + +type 'c polC = 'c pol + +type op1 = + | Equal + | NonEqual + | Strict + | NonStrict + +type 'c nFormula = 'c polC * op1 + +(** val opAdd : op1 -> op1 -> op1 option **) + +let opAdd o o' = + match o with + | Equal -> Some o' + | NonEqual -> (match o' with + | Equal -> Some NonEqual + | _ -> None) + | Strict -> (match o' with + | NonEqual -> None + | _ -> Some Strict) + | NonStrict -> + (match o' with + | NonEqual -> None + | Strict -> Some Strict + | _ -> Some NonStrict) + +type 'c psatz = + | PsatzIn of nat + | PsatzSquare of 'c polC + | PsatzMulC of 'c polC * 'c psatz + | PsatzMulE of 'c psatz * 'c psatz + | PsatzAdd of 'c psatz * 'c psatz + | PsatzC of 'c + | PsatzZ + +(** val pexpr_times_nformula : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **) + +let pexpr_times_nformula cO cI cplus ctimes ceqb e = function + | ef , o -> + (match o with + | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef) , Equal) + | _ -> None) + +(** val nformula_times_nformula : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) + +let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 = + let e1 , o1 = f1 in + let e2 , o2 = f2 in + (match o1 with + | Equal -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , Equal) + | NonEqual -> + (match o2 with + | Equal -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , Equal) + | NonEqual -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , + NonEqual) + | _ -> None) + | Strict -> + (match o2 with + | NonEqual -> None + | _ -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , o2)) + | NonStrict -> + (match o2 with + | Equal -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , Equal) + | NonEqual -> None + | _ -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , NonStrict))) + +(** val nformula_plus_nformula : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 + nFormula -> 'a1 nFormula option **) + +let nformula_plus_nformula cO cplus ceqb f1 f2 = + let e1 , o1 = f1 in + let e2 , o2 = f2 in + (match opAdd o1 o2 with + | Some x -> Some ((padd cO cplus ceqb e1 e2) , x) + | None -> None) + +(** val eval_Psatz : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 + nFormula option **) + +let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function + | PsatzIn n0 -> Some (nth n0 l ((Pc cO) , Equal)) + | PsatzSquare e0 -> Some ((psquare cO cI cplus ctimes ceqb e0) , NonStrict) + | PsatzMulC (re, e0) -> + (match eval_Psatz cO cI cplus ctimes ceqb cleb l e0 with + | Some x -> pexpr_times_nformula cO cI cplus ctimes ceqb re x + | None -> None) + | PsatzMulE (f1, f2) -> + (match eval_Psatz cO cI cplus ctimes ceqb cleb l f1 with + | Some x -> + (match eval_Psatz cO cI cplus ctimes ceqb cleb l f2 with + | Some x' -> + nformula_times_nformula cO cI cplus ctimes ceqb x x' + | None -> None) + | None -> None) + | PsatzAdd (f1, f2) -> + (match eval_Psatz cO cI cplus ctimes ceqb cleb l f1 with + | Some x -> + (match eval_Psatz cO cI cplus ctimes ceqb cleb l f2 with + | Some x' -> nformula_plus_nformula cO cplus ceqb x x' + | None -> None) + | None -> None) + | PsatzC c -> + if (&&) (cleb cO c) (negb (ceqb cO c)) + then Some ((Pc c) , Strict) + else None + | PsatzZ -> Some ((Pc cO) , Equal) + +(** val check_inconsistent : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> + bool **) + +let check_inconsistent cO ceqb cleb = function + | e , op -> + (match e with + | Pc c -> + (match op with + | Equal -> negb (ceqb c cO) + | NonEqual -> ceqb c cO + | Strict -> cleb c cO + | NonStrict -> (&&) (cleb c cO) (negb (ceqb c cO))) + | _ -> false) + +(** val check_normalised_formulas : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> + bool **) + +let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm = + match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with + | Some f -> check_inconsistent cO ceqb cleb f + | None -> false + +type op2 = + | OpEq + | OpNEq + | OpLe + | OpGe + | OpLt + | OpGt + +type 'c formula = { flhs : 'c pExpr; fop : op2; frhs : 'c pExpr } + +(** val flhs : 'a1 formula -> 'a1 pExpr **) + +let flhs x = x.flhs + +(** val fop : 'a1 formula -> op2 **) + +let fop x = x.fop + +(** val frhs : 'a1 formula -> 'a1 pExpr **) + +let frhs x = x.frhs + +(** val norm : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) + +let norm cO cI cplus ctimes cminus copp ceqb pe = + norm_aux cO cI cplus ctimes cminus copp ceqb pe + +(** val psub0 : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 + -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) + +let psub0 cO cplus cminus copp ceqb p p' = + psub cO cplus cminus copp ceqb p p' + +(** val padd0 : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol + -> 'a1 pol **) + +let padd0 cO cplus ceqb p p' = + padd cO cplus ceqb p p' + +(** val xnormalise : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 + nFormula list **) + +let xnormalise cO cI cplus ctimes cminus copp ceqb t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in + let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in + let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in + (match o with + | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) :: + (((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: []) + | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Equal) :: [] + | OpLe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) :: [] + | OpGe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: [] + | OpLt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , NonStrict) :: + [] + | OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , NonStrict) :: + []) + +(** val cnf_normalise : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 + nFormula cnf **) + +let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 = + map (fun x -> x :: []) (xnormalise cO cI cplus ctimes cminus copp ceqb t0) + +(** val xnegate : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 + nFormula list **) + +let xnegate cO cI cplus ctimes cminus copp ceqb t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in + let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in + let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in + (match o with + | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Equal) :: [] + | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) :: + (((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: []) + | OpLe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , NonStrict) :: + [] + | OpGe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , NonStrict) :: + [] + | OpLt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: [] + | OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) :: []) + +(** val cnf_negate : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 + nFormula cnf **) + +let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 = + map (fun x -> x :: []) (xnegate cO cI cplus ctimes cminus copp ceqb t0) + +(** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) + +let rec xdenorm jmp = function + | Pc c -> PEc c + | Pinj (j, p2) -> xdenorm (pplus j jmp) p2 + | PX (p2, j, q0) -> PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp), + (Npos j))))), (xdenorm (psucc jmp) q0)) + +(** val denorm : 'a1 pol -> 'a1 pExpr **) + +let denorm p = + xdenorm XH p + +(** val simpl_cone : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> + 'a1 psatz **) + +let simpl_cone cO cI ctimes ceqb e = match e with + | PsatzSquare t0 -> + (match t0 with + | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c) + | _ -> PsatzSquare t0) + | PsatzMulE (t1, t2) -> + (match t1 with + | PsatzMulE (x, x0) -> + (match x with + | PsatzC p2 -> + (match t2 with + | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x0) + | PsatzZ -> PsatzZ + | _ -> e) + | _ -> + (match x0 with + | PsatzC p2 -> + (match t2 with + | PsatzC c -> PsatzMulE ((PsatzC + (ctimes c p2)), x) + | PsatzZ -> PsatzZ + | _ -> e) + | _ -> + (match t2 with + | PsatzC c -> + if ceqb cI c + then t1 + else PsatzMulE (t1, t2) + | PsatzZ -> PsatzZ + | _ -> e))) + | PsatzC c -> + (match t2 with + | PsatzMulE (x, x0) -> + (match x with + | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x0) + | _ -> + (match x0 with + | PsatzC p2 -> PsatzMulE ((PsatzC + (ctimes c p2)), x) + | _ -> + if ceqb cI c + then t2 + else PsatzMulE (t1, t2))) + | PsatzAdd (y, z0) -> PsatzAdd ((PsatzMulE ((PsatzC c), y)), + (PsatzMulE ((PsatzC c), z0))) + | PsatzC c0 -> PsatzC (ctimes c c0) + | PsatzZ -> PsatzZ + | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)) + | PsatzZ -> PsatzZ + | _ -> + (match t2 with + | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) + | PsatzZ -> PsatzZ + | _ -> e)) + | PsatzAdd (t1, t2) -> + (match t1 with + | PsatzZ -> t2 + | _ -> (match t2 with + | PsatzZ -> t1 + | _ -> PsatzAdd (t1, t2))) + | _ -> e + +type q = { qnum : z; qden : positive } + +(** val qnum : q -> z **) + +let qnum x = x.qnum + +(** val qden : q -> positive **) + +let qden x = x.qden + +(** val qeq_bool : q -> q -> bool **) + +let qeq_bool x y = + zeq_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden)) + +(** val qle_bool : q -> q -> bool **) + +let qle_bool x y = + zle_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden)) + +(** val qplus : q -> q -> q **) + +let qplus x y = + { qnum = (zplus (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden))); + qden = (pmult x.qden y.qden) } + +(** val qmult : q -> q -> q **) + +let qmult x y = + { qnum = (zmult x.qnum y.qnum); qden = (pmult x.qden y.qden) } + +(** val qopp : q -> q **) + +let qopp x = + { qnum = (zopp x.qnum); qden = x.qden } + +(** val qminus : q -> q -> q **) + +let qminus x y = + qplus x (qopp y) + +(** val qinv : q -> q **) + +let qinv x = + match x.qnum with + | Z0 -> { qnum = Z0; qden = XH } + | Zpos p -> { qnum = (Zpos x.qden); qden = p } + | Zneg p -> { qnum = (Zneg x.qden); qden = p } + +(** val qpower_positive : q -> positive -> q **) + +let qpower_positive q0 p = + pow_pos qmult q0 p + +(** val qpower : q -> z -> q **) + +let qpower q0 = function + | Z0 -> { qnum = (Zpos XH); qden = XH } + | Zpos p -> qpower_positive q0 p + | Zneg p -> qinv (qpower_positive q0 p) + +(** val pgcdn : nat -> positive -> positive -> positive **) + +let rec pgcdn n0 a b = + match n0 with + | O -> XH + | S n1 -> + (match a with + | XI a' -> + (match b with + | XI b' -> + (match pcompare a' b' Eq with + | Eq -> a + | Lt -> pgcdn n1 (pminus b' a') a + | Gt -> pgcdn n1 (pminus a' b') b) + | XO b0 -> pgcdn n1 a b0 + | XH -> XH) + | XO a0 -> + (match b with + | XI p -> pgcdn n1 a0 b + | XO b0 -> XO (pgcdn n1 a0 b0) + | XH -> XH) + | XH -> XH) + +(** val pgcd : positive -> positive -> positive **) + +let pgcd a b = + pgcdn (plus (psize a) (psize b)) a b + +(** val zgcd : z -> z -> z **) + +let zgcd a b = + match a with + | Z0 -> zabs b + | Zpos a0 -> + (match b with + | Z0 -> zabs a + | Zpos b0 -> Zpos (pgcd a0 b0) + | Zneg b0 -> Zpos (pgcd a0 b0)) + | Zneg a0 -> + (match b with + | Z0 -> zabs a + | Zpos b0 -> Zpos (pgcd a0 b0) + | Zneg b0 -> Zpos (pgcd a0 b0)) + +type 'a t = + | Empty + | Leaf of 'a + | Node of 'a t * 'a * 'a t + +(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) + +let rec find default vm p = + match vm with + | Empty -> default + | Leaf i -> i + | Node (l, e, r) -> + (match p with + | XI p2 -> find default r p2 + | XO p2 -> find default l p2 + | XH -> e) + +type zWitness = z psatz + +(** val zWeakChecker : z nFormula list -> z psatz -> bool **) + +let zWeakChecker x x0 = + check_normalised_formulas Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0 + +(** val psub1 : z pol -> z pol -> z pol **) + +let psub1 p p' = + psub0 Z0 zplus zminus zopp zeq_bool p p' + +(** val padd1 : z pol -> z pol -> z pol **) + +let padd1 p p' = + padd0 Z0 zplus zeq_bool p p' + +(** val norm0 : z pExpr -> z pol **) + +let norm0 pe = + norm Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool pe + +(** val xnormalise0 : z formula -> z nFormula list **) + +let xnormalise0 t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in + let lhs0 = norm0 lhs in + let rhs0 = norm0 rhs in + (match o with + | OpEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) :: + (((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: []) + | OpNEq -> ((psub1 lhs0 rhs0) , Equal) :: [] + | OpLe -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) :: [] + | OpGe -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: [] + | OpLt -> ((psub1 lhs0 rhs0) , NonStrict) :: [] + | OpGt -> ((psub1 rhs0 lhs0) , NonStrict) :: []) + +(** val normalise : z formula -> z nFormula cnf **) + +let normalise t0 = + map (fun x -> x :: []) (xnormalise0 t0) + +(** val xnegate0 : z formula -> z nFormula list **) + +let xnegate0 t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in + let lhs0 = norm0 lhs in + let rhs0 = norm0 rhs in + (match o with + | OpEq -> ((psub1 lhs0 rhs0) , Equal) :: [] + | OpNEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) :: + (((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: []) + | OpLe -> ((psub1 rhs0 lhs0) , NonStrict) :: [] + | OpGe -> ((psub1 lhs0 rhs0) , NonStrict) :: [] + | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: [] + | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) :: []) + +(** val negate : z formula -> z nFormula cnf **) + +let negate t0 = + map (fun x -> x :: []) (xnegate0 t0) + +(** val ceiling : z -> z -> z **) + +let ceiling a b = + let q0 , r = zdiv_eucl a b in + (match r with + | Z0 -> q0 + | _ -> zplus q0 (Zpos XH)) + +type zArithProof = + | DoneProof + | RatProof of zWitness * zArithProof + | CutProof of zWitness * zArithProof + | EnumProof of zWitness * zWitness * zArithProof list + +(** val zgcdM : z -> z -> z **) + +let zgcdM x y = + zmax (zgcd x y) (Zpos XH) + +(** val zgcd_pol : z polC -> z * z **) + +let rec zgcd_pol = function + | Pc c -> Z0 , c + | Pinj (p2, p3) -> zgcd_pol p3 + | PX (p2, p3, q0) -> + let g1 , c1 = zgcd_pol p2 in + let g2 , c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2) , c2 + +(** val zdiv_pol : z polC -> z -> z polC **) + +let rec zdiv_pol p x = + match p with + | Pc c -> Pc (zdiv c x) + | Pinj (j, p2) -> Pinj (j, (zdiv_pol p2 x)) + | PX (p2, j, q0) -> PX ((zdiv_pol p2 x), j, (zdiv_pol q0 x)) + +(** val makeCuttingPlane : z polC -> z polC * z **) + +let makeCuttingPlane p = + let g , c = zgcd_pol p in + if zgt_bool g Z0 + then (zdiv_pol (psubC zminus p c) g) , (zopp (ceiling (zopp c) g)) + else p , Z0 + +(** val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option **) + +let genCuttingPlane = function + | e , op -> + (match op with + | Equal -> + let g , c = zgcd_pol e in + if (&&) (zgt_bool g Z0) + ((&&) (zgt_bool c Z0) (negb (zeq_bool (zgcd g c) g))) + then None + else Some ((e , Z0) , op) + | NonEqual -> Some ((e , Z0) , op) + | Strict -> + let p , c = makeCuttingPlane (psubC zminus e (Zpos XH)) in + Some ((p , c) , NonStrict) + | NonStrict -> + let p , c = makeCuttingPlane e in Some ((p , c) , NonStrict)) + +(** val nformula_of_cutting_plane : + ((z polC * z) * op1) -> z nFormula **) + +let nformula_of_cutting_plane = function + | e_z , o -> let e , z0 = e_z in (padd1 e (Pc z0)) , o + +(** val is_pol_Z0 : z polC -> bool **) + +let is_pol_Z0 = function + | Pc z0 -> (match z0 with + | Z0 -> true + | _ -> false) + | _ -> false + +(** val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option **) + +let eval_Psatz0 x x0 = + eval_Psatz Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0 + +(** val check_inconsistent0 : z nFormula -> bool **) + +let check_inconsistent0 f = + check_inconsistent Z0 zeq_bool zle_bool f + +(** val zChecker : z nFormula list -> zArithProof -> bool **) + +let rec zChecker l = function + | DoneProof -> false + | RatProof (w, pf0) -> + (match eval_Psatz0 l w with + | Some f -> + if check_inconsistent0 f then true else zChecker (f :: l) pf0 + | None -> false) + | CutProof (w, pf0) -> + (match eval_Psatz0 l w with + | Some f -> + (match genCuttingPlane f with + | Some cp -> + zChecker ((nformula_of_cutting_plane cp) :: l) pf0 + | None -> true) + | None -> false) + | EnumProof (w1, w2, pf0) -> + (match eval_Psatz0 l w1 with + | Some f1 -> + (match eval_Psatz0 l w2 with + | Some f2 -> + (match genCuttingPlane f1 with + | Some p -> + let p2 , op3 = p in + let e1 , z1 = p2 in + (match genCuttingPlane f2 with + | Some p3 -> + let p4 , op4 = p3 in + let e2 , z2 = p4 in + (match op3 with + | NonStrict -> + (match op4 with + | NonStrict -> + if is_pol_Z0 (padd1 e1 e2) + then + let rec label pfs lb ub = + + match pfs with + | + [] -> zgt_bool lb ub + | + pf1 :: rsr -> + (&&) + (zChecker + (((psub1 e1 (Pc lb)) , + Equal) :: l) pf1) + (label rsr + (zplus lb (Zpos XH)) ub) + in label pf0 (zopp z1) z2 + else false + | _ -> false) + | _ -> false) + | None -> false) + | None -> false) + | None -> false) + | None -> false) + +(** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) + +let zTautoChecker f w = + tauto_checker normalise negate zChecker f w + +(** val n_of_Z : z -> n **) + +let n_of_Z = function + | Zpos p -> Npos p + | _ -> N0 + +type qWitness = q psatz + +(** val qWeakChecker : q nFormula list -> q psatz -> bool **) + +let qWeakChecker x x0 = + check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); + qden = XH } qplus qmult qeq_bool qle_bool x x0 + +(** val qnormalise : q formula -> q nFormula cnf **) + +let qnormalise t0 = + cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } + qplus qmult qminus qopp qeq_bool t0 + +(** val qnegate : q formula -> q nFormula cnf **) + +let qnegate t0 = + cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus + qmult qminus qopp qeq_bool t0 + +(** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) + +let qTautoChecker f w = + tauto_checker qnormalise qnegate qWeakChecker f w + +type rWitness = z psatz + +(** val rWeakChecker : z nFormula list -> z psatz -> bool **) + +let rWeakChecker x x0 = + check_normalised_formulas Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0 + +(** val rnormalise : z formula -> z nFormula cnf **) + +let rnormalise t0 = + cnf_normalise Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool t0 + +(** val rnegate : z formula -> z nFormula cnf **) + +let rnegate t0 = + cnf_negate Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool t0 + +(** val rTautoChecker : z formula bFormula -> rWitness list -> bool **) + +let rTautoChecker f w = + tauto_checker rnormalise rnegate rWeakChecker f w + diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli new file mode 100644 index 00000000..3e3ae2c3 --- /dev/null +++ b/plugins/micromega/micromega.mli @@ -0,0 +1,442 @@ +val negb : bool -> bool + +type nat = + | O + | S of nat + +type comparison = + | Eq + | Lt + | Gt + +val compOpp : comparison -> comparison + +val plus : nat -> nat -> nat + +val app : 'a1 list -> 'a1 list -> 'a1 list + +val nth : nat -> 'a1 list -> 'a1 -> 'a1 + +val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list + +type positive = + | XI of positive + | XO of positive + | XH + +val psucc : positive -> positive + +val pplus : positive -> positive -> positive + +val pplus_carry : positive -> positive -> positive + +val p_of_succ_nat : nat -> positive + +val pdouble_minus_one : positive -> positive + +type positive_mask = + | IsNul + | IsPos of positive + | IsNeg + +val pdouble_plus_one_mask : positive_mask -> positive_mask + +val pdouble_mask : positive_mask -> positive_mask + +val pdouble_minus_two : positive -> positive_mask + +val pminus_mask : positive -> positive -> positive_mask + +val pminus_mask_carry : positive -> positive -> positive_mask + +val pminus : positive -> positive -> positive + +val pmult : positive -> positive -> positive + +val pcompare : positive -> positive -> comparison -> comparison + +val psize : positive -> nat + +type n = + | N0 + | Npos of positive + +val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 + +type z = + | Z0 + | Zpos of positive + | Zneg of positive + +val zdouble_plus_one : z -> z + +val zdouble_minus_one : z -> z + +val zdouble : z -> z + +val zPminus : positive -> positive -> z + +val zplus : z -> z -> z + +val zopp : z -> z + +val zminus : z -> z -> z + +val zmult : z -> z -> z + +val zcompare : z -> z -> comparison + +val zabs : z -> z + +val zmax : z -> z -> z + +val zle_bool : z -> z -> bool + +val zge_bool : z -> z -> bool + +val zgt_bool : z -> z -> bool + +val zeq_bool : z -> z -> bool + +val n_of_nat : nat -> n + +val zdiv_eucl_POS : positive -> z -> z * z + +val zdiv_eucl : z -> z -> z * z + +val zdiv : z -> z -> z + +type 'c pol = + | Pc of 'c + | Pinj of positive * 'c pol + | PX of 'c pol * positive * 'c pol + +val p0 : 'a1 -> 'a1 pol + +val p1 : 'a1 -> 'a1 pol + +val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool + +val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol + +val mkPX : + 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + +val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol + +val mkX : 'a1 -> 'a1 -> 'a1 pol + +val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol + +val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol + +val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol + +val paddI : + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol + +val psubI : + ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> + 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + +val paddX : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol + -> positive -> 'a1 pol -> 'a1 pol + +val psubX : + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 + pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + +val padd : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> + 'a1 pol + +val psub : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 + -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + +val pmulC_aux : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 + pol + +val pmulC : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + -> 'a1 pol + +val pmulI : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> + 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + +val pmul : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + +val psquare : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 pol -> 'a1 pol + +type 'c pExpr = + | PEc of 'c + | PEX of positive + | PEadd of 'c pExpr * 'c pExpr + | PEsub of 'c pExpr * 'c pExpr + | PEmul of 'c pExpr * 'c pExpr + | PEopp of 'c pExpr + | PEpow of 'c pExpr * n + +val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol + +val ppow_pos : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol + +val ppow_N : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol + +val norm_aux : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + +type 'a bFormula = + | TT + | FF + | X + | A of 'a + | Cj of 'a bFormula * 'a bFormula + | D of 'a bFormula * 'a bFormula + | N of 'a bFormula + | I of 'a bFormula * 'a bFormula + +type 'term' clause = 'term' list + +type 'term' cnf = 'term' clause list + +val tt : 'a1 cnf + +val ff : 'a1 cnf + +val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf + +val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf + +val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf + +val xcnf : + ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf + +val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool + +val tauto_checker : + ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 + bFormula -> 'a3 list -> bool + +type 'c polC = 'c pol + +type op1 = + | Equal + | NonEqual + | Strict + | NonStrict + +type 'c nFormula = 'c polC * op1 + +val opAdd : op1 -> op1 -> op1 option + +type 'c psatz = + | PsatzIn of nat + | PsatzSquare of 'c polC + | PsatzMulC of 'c polC * 'c psatz + | PsatzMulE of 'c psatz * 'c psatz + | PsatzAdd of 'c psatz * 'c psatz + | PsatzC of 'c + | PsatzZ + +val pexpr_times_nformula : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option + +val nformula_times_nformula : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option + +val nformula_plus_nformula : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 + nFormula -> 'a1 nFormula option + +val eval_Psatz : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 + nFormula option + +val check_inconsistent : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool + +val check_normalised_formulas : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + +type op2 = + | OpEq + | OpNEq + | OpLe + | OpGe + | OpLt + | OpGt + +type 'c formula = { flhs : 'c pExpr; fop : op2; frhs : 'c pExpr } + +val flhs : 'a1 formula -> 'a1 pExpr + +val fop : 'a1 formula -> op2 + +val frhs : 'a1 formula -> 'a1 pExpr + +val norm : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + +val psub0 : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 + -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + +val padd0 : + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> + 'a1 pol + +val xnormalise : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula + list + +val cnf_normalise : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula + cnf + +val xnegate : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula + list + +val cnf_negate : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> + 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula + cnf + +val xdenorm : positive -> 'a1 pol -> 'a1 pExpr + +val denorm : 'a1 pol -> 'a1 pExpr + +val simpl_cone : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> + 'a1 psatz + +type q = { qnum : z; qden : positive } + +val qnum : q -> z + +val qden : q -> positive + +val qeq_bool : q -> q -> bool + +val qle_bool : q -> q -> bool + +val qplus : q -> q -> q + +val qmult : q -> q -> q + +val qopp : q -> q + +val qminus : q -> q -> q + +val qinv : q -> q + +val qpower_positive : q -> positive -> q + +val qpower : q -> z -> q + +val pgcdn : nat -> positive -> positive -> positive + +val pgcd : positive -> positive -> positive + +val zgcd : z -> z -> z + +type 'a t = + | Empty + | Leaf of 'a + | Node of 'a t * 'a * 'a t + +val find : 'a1 -> 'a1 t -> positive -> 'a1 + +type zWitness = z psatz + +val zWeakChecker : z nFormula list -> z psatz -> bool + +val psub1 : z pol -> z pol -> z pol + +val padd1 : z pol -> z pol -> z pol + +val norm0 : z pExpr -> z pol + +val xnormalise0 : z formula -> z nFormula list + +val normalise : z formula -> z nFormula cnf + +val xnegate0 : z formula -> z nFormula list + +val negate : z formula -> z nFormula cnf + +val ceiling : z -> z -> z + +type zArithProof = + | DoneProof + | RatProof of zWitness * zArithProof + | CutProof of zWitness * zArithProof + | EnumProof of zWitness * zWitness * zArithProof list + +val zgcdM : z -> z -> z + +val zgcd_pol : z polC -> z * z + +val zdiv_pol : z polC -> z -> z polC + +val makeCuttingPlane : z polC -> z polC * z + +val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option + +val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula + +val is_pol_Z0 : z polC -> bool + +val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option + +val check_inconsistent0 : z nFormula -> bool + +val zChecker : z nFormula list -> zArithProof -> bool + +val zTautoChecker : z formula bFormula -> zArithProof list -> bool + +val n_of_Z : z -> n + +type qWitness = q psatz + +val qWeakChecker : q nFormula list -> q psatz -> bool + +val qnormalise : q formula -> q nFormula cnf + +val qnegate : q formula -> q nFormula cnf + +val qTautoChecker : q formula bFormula -> qWitness list -> bool + +type rWitness = z psatz + +val rWeakChecker : z nFormula list -> z psatz -> bool + +val rnormalise : z formula -> z nFormula cnf + +val rnegate : z formula -> z nFormula cnf + +val rTautoChecker : z formula bFormula -> rWitness list -> bool + diff --git a/plugins/micromega/micromega_plugin.mllib b/plugins/micromega/micromega_plugin.mllib new file mode 100644 index 00000000..debc296e --- /dev/null +++ b/plugins/micromega/micromega_plugin.mllib @@ -0,0 +1,9 @@ +Sos_types +Mutils +Micromega +Mfourier +Certificate +Persistent_cache +Coq_micromega +G_micromega +Micromega_plugin_mod diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml new file mode 100644 index 00000000..ec06fa58 --- /dev/null +++ b/plugins/micromega/mutils.ml @@ -0,0 +1,402 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + (try rst () + with _ -> raise x + ); raise x + +let map_option f x = + match x with + | None -> None + | Some v -> Some (f v) + +let from_option = function + | None -> failwith "from_option" + | Some v -> v + +let rec try_any l x = + match l with + | [] -> None + | (f,s)::l -> match f x with + | None -> try_any l x + | x -> x + +let iteri f l = + let rec xiter i l = + match l with + | [] -> () + | e::l -> f i e ; xiter (i+1) l in + xiter 0 l + +let mapi f l = + let rec xmap i l = + match l with + | [] -> [] + | e::l -> (f i e)::xmap (i+1) l in + xmap 0 l + +let rec map3 f l1 l2 l3 = + match l1 , l2 ,l3 with + | [] , [] , [] -> [] + | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3) + | _ -> raise (Invalid_argument "map3") + + + +let rec is_sublist l1 l2 = + match l1 ,l2 with + | [] ,_ -> true + | e::l1', [] -> false + | e::l1' , e'::l2' -> + if e = e' then is_sublist l1' l2' + else is_sublist l1 l2' + + + +let list_try_find f = + let rec try_find_f = function + | [] -> failwith "try_find" + | h::t -> try f h with Failure _ -> try_find_f t + in + try_find_f + +let rec list_fold_right_elements f l = + let rec aux = function + | [] -> invalid_arg "list_fold_right_elements" + | [x] -> x + | x::l -> f x (aux l) in + aux l + +let interval n m = + let rec interval_n (l,m) = + if n > m then l else interval_n (m::l,pred m) + in + interval_n ([],m) + +open Num +open Big_int + +let ppcm x y = + let g = gcd_big_int x y in + let x' = div_big_int x g in + let y' = div_big_int y g in + mult_big_int g (mult_big_int x' y') + + +let denominator = function + | Int _ | Big_int _ -> unit_big_int + | Ratio r -> Ratio.denominator_ratio r + +let numerator = function + | Ratio r -> Ratio.numerator_ratio r + | Int i -> Big_int.big_int_of_int i + | Big_int i -> i + +let rec ppcm_list c l = + match l with + | [] -> c + | e::l -> ppcm_list (ppcm c (denominator e)) l + +let rec rec_gcd_list c l = + match l with + | [] -> c + | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l + +let rec gcd_list l = + let res = rec_gcd_list zero_big_int l in + if compare_big_int res zero_big_int = 0 + then unit_big_int else res + + + +let rats_to_ints l = + let c = ppcm_list unit_big_int l in + List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) + (denominator x))) l + +(* Nasty reordering of lists - useful to trim certificate down *) +let mapi f l = + let rec xmapi i l = + match l with + | [] -> [] + | e::l -> (f e i)::(xmapi (i+1) l) in + xmapi 0 l + + +let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l) + +(* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) +let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l)) + +let assoc_pos_assoc l = + let rec xpos i l = + match l with + | [] -> [] + | (x,l) ::rst -> let (l',j) = assoc_pos i l in + (x,l')::(xpos j rst) in + xpos 0 l + +let filter_pos f l = + (* Could sort ... take care of duplicates... *) + let rec xfilter l = + match l with + | [] -> [] + | (x,e)::l -> + if List.exists (fun ee -> List.mem ee f) (List.map snd e) + then (x,e)::(xfilter l) + else xfilter l in + xfilter l + +let select_pos lpos l = + let rec xselect i lpos l = + match lpos with + | [] -> [] + | j::rpos -> + match l with + | [] -> failwith "select_pos" + | e::l -> + if i = j + then e:: (xselect (i+1) rpos l) + else xselect (i+1) lpos l in + xselect 0 lpos l + + +module CoqToCaml = +struct + open Micromega + + let rec nat = function + | O -> 0 + | S n -> (nat n) + 1 + + + let rec positive p = + match p with + | XH -> 1 + | XI p -> 1+ 2*(positive p) + | XO p -> 2*(positive p) + + + let n nt = + match nt with + | N0 -> 0 + | Npos p -> positive p + + + let rec index i = (* Swap left-right ? *) + match i with + | XH -> 1 + | XI i -> 1+(2*(index i)) + | XO i -> 2*(index i) + + + let z x = + match x with + | Z0 -> 0 + | Zpos p -> (positive p) + | Zneg p -> - (positive p) + + open Big_int + + let rec positive_big_int p = + match p with + | XH -> unit_big_int + | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p)) + | XO p -> (mult_int_big_int 2 (positive_big_int p)) + + + let z_big_int x = + match x with + | Z0 -> zero_big_int + | Zpos p -> (positive_big_int p) + | Zneg p -> minus_big_int (positive_big_int p) + + + let num x = Num.Big_int (z_big_int x) + + let q_to_num {qnum = x ; qden = y} = + Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) + +end + + +module CamlToCoq = +struct + open Micromega + + let rec nat = function + | 0 -> O + | n -> S (nat (n-1)) + + + let rec positive n = + if n=1 then XH + else if n land 1 = 1 then XI (positive (n lsr 1)) + else XO (positive (n lsr 1)) + + let n nt = + if nt < 0 + then assert false + else if nt = 0 then N0 + else Npos (positive nt) + + let rec index n = + if n=1 then XH + else if n land 1 = 1 then XI (index (n lsr 1)) + else XO (index (n lsr 1)) + + + let idx n = + (*a.k.a path_of_int *) + (* returns the list of digits of n in reverse order with + initial 1 removed *) + 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 b c -> (if b then XI c else XO c)) + (List.rev (digits_of_int n)) + (XH) + + let z x = + match compare x 0 with + | 0 -> Z0 + | 1 -> Zpos (positive x) + | _ -> (* this should be -1 *) + Zneg (positive (-x)) + + open Big_int + + let positive_big_int n = + let two = big_int_of_int 2 in + let rec _pos n = + if eq_big_int n unit_big_int then XH + else + let (q,m) = quomod_big_int n two in + if eq_big_int unit_big_int m + then XI (_pos q) + else XO (_pos q) in + _pos n + + let bigint x = + match sign_big_int x with + | 0 -> Z0 + | 1 -> Zpos (positive_big_int x) + | _ -> Zneg (positive_big_int (minus_big_int x)) + + let q n = + {Micromega.qnum = bigint (numerator n) ; + Micromega.qden = positive_big_int (denominator n)} + +end + +module Cmp = +struct + + let rec compare_lexical l = + match l with + | [] -> 0 (* Equal *) + | f::l -> + let cmp = f () in + if cmp = 0 then compare_lexical l else cmp + + let rec compare_list cmp l1 l2 = + match l1 , l2 with + | [] , [] -> 0 + | [] , _ -> -1 + | _ , [] -> 1 + | e1::l1 , e2::l2 -> + let c = cmp e1 e2 in + if c = 0 then compare_list cmp l1 l2 else c + + let hash_list hash l = + let rec _hash_list l h = + match l with + | [] -> h lxor (Hashtbl.hash []) + | e::l -> _hash_list l ((hash e) lxor h) in + + _hash_list l 0 +end + +module type Tag = +sig + type t + + val from : int -> t + val next : t -> t + val pp : out_channel -> t -> unit + val compare : t -> t -> int +end + +module Tag : Tag = +struct + type t = int + let from i = i + let next i = i + 1 + let pp o i = output_string o (string_of_int i) + let compare : int -> int -> int = Pervasives.compare +end + +module TagSet = Set.Make(Tag) + + +let command exe_path args vl = + (* creating pipes for stdin, stdout, stderr *) + let (stdin_read,stdin_write) = Unix.pipe () + and (stdout_read,stdout_write) = Unix.pipe () + and (stderr_read,stderr_write) = Unix.pipe () in + + + (* Create the process *) + let pid = Unix.create_process exe_path args stdin_read stdout_write stderr_write in + + (* Write the data on the stdin of the created process *) + let outch = Unix.out_channel_of_descr stdin_write in + output_value outch vl ; + flush outch ; + + (* Wait for its completion *) + let _pid,status = Unix.waitpid [] pid in + + finally + (fun () -> + (* Recover the result *) + match status with + | Unix.WEXITED 0 -> + let inch = Unix.in_channel_of_descr stdout_read in + begin try Marshal.from_channel inch with x -> failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x)) end + | Unix.WEXITED i -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) + | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) + | Unix.WSTOPPED i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) + (fun () -> + (* Cleanup *) + List.iter (fun x -> try Unix.close x with _ -> ()) [stdin_read; stdin_write; stdout_read ; stdout_write ; stderr_read; stderr_write] + ) + + + + + + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml new file mode 100644 index 00000000..f17e1c35 --- /dev/null +++ b/plugins/micromega/persistent_cache.ml @@ -0,0 +1,180 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* string -> 'a t + (** [create i f] creates an empty persistent table + with initial size i + associated with file [f] *) + + + val open_in : string -> 'a t + (** [open_in f] rebuilds a table from the records stored in file [f]. + As marshaling is not type-safe, it migth segault. + *) + + val find : 'a t -> key -> 'a + (** find has the specification of Hashtable.find *) + + val add : 'a t -> key -> 'a -> unit + (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. + (and writes the binding to the file associated with [tbl].) + If [key] is already bound, raises KeyAlreadyBound *) + + val close : 'a t -> unit + (** [close tbl] is closing the table. + Once closed, a table cannot be used. + i.e, copy, find,add will raise UnboundTable *) + + val memo : string -> (key -> 'a) -> (key -> 'a) + (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. + Note that the cache will only be loaded when the function is used for the first time *) + + end + +open Hashtbl + +module PHashtable(Key:HashedType) : PHashtable with type key = Key.t = +struct + + type key = Key.t + + module Table = Hashtbl.Make(Key) + + + + exception InvalidTableFormat + exception UnboundTable + + + type mode = Closed | Open + + + type 'a t = + { + outch : out_channel ; + mutable status : mode ; + htbl : 'a Table.t + } + + +let create i f = + { + outch = open_out_bin f ; + status = Open ; + htbl = Table.create i + } + +let finally f rst = + try + let res = f () in + rst () ; res + with x -> + (try rst () + with _ -> raise x + ); raise x + + +let read_key_elem inch = + try + Some (Marshal.from_channel inch) + with + | End_of_file -> None + | _ -> raise InvalidTableFormat + +let open_in f = + let flags = [Open_rdonly;Open_binary;Open_creat] in + let inch = open_in_gen flags 0o666 f in + let htbl = Table.create 10 in + + let rec xload () = + match read_key_elem inch with + | None -> () + | Some (key,elem) -> + Table.add htbl key elem ; + xload () in + + try + finally (fun () -> xload () ) (fun () -> close_in inch) ; + { + outch = begin + let flags = [Open_append;Open_binary;Open_creat] in + open_out_gen flags 0o666 f + end ; + status = Open ; + htbl = htbl + } + with InvalidTableFormat -> + (* Try to keep as many entries as possible *) + begin + let flags = [Open_wronly; Open_trunc;Open_binary;Open_creat] in + let outch = open_out_gen flags 0o666 f in + Table.iter (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; + { outch = outch ; + status = Open ; + htbl = htbl + } + end + + +let close t = + let {outch = outch ; status = status ; htbl = tbl} = t in + match t.status with + | Closed -> () (* don't do it twice *) + | Open -> + close_out outch ; + Table.clear tbl ; + t.status <- Closed + +let add t k e = + let {outch = outch ; status = status ; htbl = tbl} = t in + if status = Closed + then raise UnboundTable + else + begin + Table.add tbl k e ; + Marshal.to_channel outch (k,e) [Marshal.No_sharing] + end + +let find t k = + let {outch = outch ; status = status ; htbl = tbl} = t in + if status = Closed + then raise UnboundTable + else + let res = Table.find tbl k in + res + +let memo cache f = + let tbl = lazy (open_in cache) in + fun x -> + let tbl = Lazy.force tbl in + try + find tbl x + with + Not_found -> + let res = f x in + add tbl x res ; + res + +end + + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml new file mode 100644 index 00000000..3029496b --- /dev/null +++ b/plugins/micromega/sos.ml @@ -0,0 +1,1859 @@ +(* ========================================================================= *) +(* - This code originates from John Harrison's HOL LIGHT 2.30 *) +(* (see file LICENSE.sos for license, copyright and disclaimer) *) +(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL *) +(* independent bits *) +(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *) +(* ========================================================================= *) + +(* ========================================================================= *) +(* Nonlinear universal reals procedure using SOS decomposition. *) +(* ========================================================================= *) +open Num;; +open List;; +open Sos_types;; +open Sos_lib;; + +(* +prioritize_real();; +*) + +let debugging = ref false;; + +exception Sanity;; + +exception Unsolvable;; + +(* ------------------------------------------------------------------------- *) +(* Turn a rational into a decimal string with d sig digits. *) +(* ------------------------------------------------------------------------- *) + +let decimalize = + let rec normalize y = + if abs_num y =/ Int 1 then normalize (y // Int 10) + 1 + else 0 in + fun d x -> + if x =/ Int 0 then "0.0" else + let y = abs_num x in + let e = normalize y in + let z = pow10(-e) */ y +/ Int 1 in + let k = round_num(pow10 d */ z) in + (if x a + | h::t -> itern (k + 1) t f (f h k a);; + +let rec iter (m,n) f a = + if n < m then a + else iter (m+1,n) f (f m a);; + +(* ------------------------------------------------------------------------- *) +(* The main types. *) +(* ------------------------------------------------------------------------- *) + +type vector = int*(int,num)func;; + +type matrix = (int*int)*(int*int,num)func;; + +type monomial = (vname,int)func;; + +type poly = (monomial,num)func;; + +(* ------------------------------------------------------------------------- *) +(* Assignment avoiding zeros. *) +(* ------------------------------------------------------------------------- *) + +let (|-->) x y a = if y =/ Int 0 then a else (x |-> y) a;; + +(* ------------------------------------------------------------------------- *) +(* This can be generic. *) +(* ------------------------------------------------------------------------- *) + +let element (d,v) i = tryapplyd v i (Int 0);; + +let mapa f (d,v) = + d,foldl (fun a i c -> (i |--> f(c)) a) undefined v;; + +let is_zero (d,v) = + match v with + Empty -> true + | _ -> false;; + +(* ------------------------------------------------------------------------- *) +(* Vectors. Conventionally indexed 1..n. *) +(* ------------------------------------------------------------------------- *) + +let vector_0 n = (n,undefined:vector);; + +let dim (v:vector) = fst v;; + +let vector_const c n = + if c =/ Int 0 then vector_0 n + else (n,itlist (fun k -> k |-> c) (1--n) undefined :vector);; + +let vector_1 = vector_const (Int 1);; + +let vector_cmul c (v:vector) = + let n = dim v in + if c =/ Int 0 then vector_0 n + else n,mapf (fun x -> c */ x) (snd v) + +let vector_neg (v:vector) = (fst v,mapf minus_num (snd v) :vector);; + +let vector_add (v1:vector) (v2:vector) = + let m = dim v1 and n = dim v2 in + if m <> n then failwith "vector_add: incompatible dimensions" else + (n,combine (+/) (fun x -> x =/ Int 0) (snd v1) (snd v2) :vector);; + +let vector_sub v1 v2 = vector_add v1 (vector_neg v2);; + +let vector_dot (v1:vector) (v2:vector) = + let m = dim v1 and n = dim v2 in + if m <> n then failwith "vector_add: incompatible dimensions" else + foldl (fun a i x -> x +/ a) (Int 0) + (combine ( */ ) (fun x -> x =/ Int 0) (snd v1) (snd v2));; + +let vector_of_list l = + let n = length l in + (n,itlist2 (|->) (1--n) l undefined :vector);; + +(* ------------------------------------------------------------------------- *) +(* Matrices; again rows and columns indexed from 1. *) +(* ------------------------------------------------------------------------- *) + +let matrix_0 (m,n) = ((m,n),undefined:matrix);; + +let dimensions (m:matrix) = fst m;; + +let matrix_const c (m,n as mn) = + if m <> n then failwith "matrix_const: needs to be square" + else if c =/ Int 0 then matrix_0 mn + else (mn,itlist (fun k -> (k,k) |-> c) (1--n) undefined :matrix);; + +let matrix_1 = matrix_const (Int 1);; + +let matrix_cmul c (m:matrix) = + let (i,j) = dimensions m in + if c =/ Int 0 then matrix_0 (i,j) + else (i,j),mapf (fun x -> c */ x) (snd m);; + +let matrix_neg (m:matrix) = (dimensions m,mapf minus_num (snd m) :matrix);; + +let matrix_add (m1:matrix) (m2:matrix) = + let d1 = dimensions m1 and d2 = dimensions m2 in + if d1 <> d2 then failwith "matrix_add: incompatible dimensions" + else (d1,combine (+/) (fun x -> x =/ Int 0) (snd m1) (snd m2) :matrix);; + +let matrix_sub m1 m2 = matrix_add m1 (matrix_neg m2);; + +let row k (m:matrix) = + let i,j = dimensions m in + (j, + foldl (fun a (i,j) c -> if i = k then (j |-> c) a else a) undefined (snd m) + : vector);; + +let column k (m:matrix) = + let i,j = dimensions m in + (i, + foldl (fun a (i,j) c -> if j = k then (i |-> c) a else a) undefined (snd m) + : vector);; + +let transp (m:matrix) = + let i,j = dimensions m in + ((j,i),foldl (fun a (i,j) c -> ((j,i) |-> c) a) undefined (snd m) :matrix);; + +let diagonal (v:vector) = + let n = dim v in + ((n,n),foldl (fun a i c -> ((i,i) |-> c) a) undefined (snd v) : matrix);; + +let matrix_of_list l = + let m = length l in + if m = 0 then matrix_0 (0,0) else + let n = length (hd l) in + (m,n),itern 1 l (fun v i -> itern 1 v (fun c j -> (i,j) |-> c)) undefined;; + +(* ------------------------------------------------------------------------- *) +(* Monomials. *) +(* ------------------------------------------------------------------------- *) + +let monomial_eval assig (m:monomial) = + foldl (fun a x k -> a */ power_num (apply assig x) (Int k)) + (Int 1) m;; + +let monomial_1 = (undefined:monomial);; + +let monomial_var x = (x |=> 1 :monomial);; + +let (monomial_mul:monomial->monomial->monomial) = + combine (+) (fun x -> false);; + +let monomial_pow (m:monomial) k = + if k = 0 then monomial_1 + else mapf (fun x -> k * x) m;; + +let monomial_divides (m1:monomial) (m2:monomial) = + foldl (fun a x k -> tryapplyd m2 x 0 >= k & a) true m1;; + +let monomial_div (m1:monomial) (m2:monomial) = + let m = combine (+) (fun x -> x = 0) m1 (mapf (fun x -> -x) m2) in + if foldl (fun a x k -> k >= 0 & a) true m then m + else failwith "monomial_div: non-divisible";; + +let monomial_degree x (m:monomial) = tryapplyd m x 0;; + +let monomial_lcm (m1:monomial) (m2:monomial) = + (itlist (fun x -> x |-> max (monomial_degree x m1) (monomial_degree x m2)) + (union (dom m1) (dom m2)) undefined :monomial);; + +let monomial_multidegree (m:monomial) = foldl (fun a x k -> k + a) 0 m;; + +let monomial_variables m = dom m;; + +(* ------------------------------------------------------------------------- *) +(* Polynomials. *) +(* ------------------------------------------------------------------------- *) + +let eval assig (p:poly) = + foldl (fun a m c -> a +/ c */ monomial_eval assig m) (Int 0) p;; + +let poly_0 = (undefined:poly);; + +let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 & a) true p;; + +let poly_var x = ((monomial_var x) |=> Int 1 :poly);; + +let poly_const c = + if c =/ Int 0 then poly_0 else (monomial_1 |=> c);; + +let poly_cmul c (p:poly) = + if c =/ Int 0 then poly_0 + else mapf (fun x -> c */ x) p;; + +let poly_neg (p:poly) = (mapf minus_num p :poly);; + +let poly_add (p1:poly) (p2:poly) = + (combine (+/) (fun x -> x =/ Int 0) p1 p2 :poly);; + +let poly_sub p1 p2 = poly_add p1 (poly_neg p2);; + +let poly_cmmul (c,m) (p:poly) = + if c =/ Int 0 then poly_0 + else if m = monomial_1 then mapf (fun d -> c */ d) p + else foldl (fun a m' d -> (monomial_mul m m' |-> c */ d) a) poly_0 p;; + +let poly_mul (p1:poly) (p2:poly) = + foldl (fun a m c -> poly_add (poly_cmmul (c,m) p2) a) poly_0 p1;; + +let poly_div (p1:poly) (p2:poly) = + if not(poly_isconst p2) then failwith "poly_div: non-constant" else + let c = eval undefined p2 in + if c =/ Int 0 then failwith "poly_div: division by zero" + else poly_cmul (Int 1 // c) p1;; + +let poly_square p = poly_mul p p;; + +let rec poly_pow p k = + if k = 0 then poly_const (Int 1) + else if k = 1 then p + else let q = poly_square(poly_pow p (k / 2)) in + if k mod 2 = 1 then poly_mul p q else q;; + +let poly_exp p1 p2 = + if not(poly_isconst p2) then failwith "poly_exp: not a constant" else + poly_pow p1 (Num.int_of_num (eval undefined p2));; + +let degree x (p:poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p;; + +let multidegree (p:poly) = + foldl (fun a m c -> max (monomial_multidegree m) a) 0 p;; + +let poly_variables (p:poly) = + foldr (fun m c -> union (monomial_variables m)) p [];; + +(* ------------------------------------------------------------------------- *) +(* Order monomials for human presentation. *) +(* ------------------------------------------------------------------------- *) + +let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or x1 = x2 & k1 > k2;; + +let humanorder_monomial = + let rec ord l1 l2 = match (l1,l2) with + _,[] -> true + | [],_ -> false + | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or h1 = h2 & ord t1 t2 in + fun m1 m2 -> m1 = m2 or + ord (sort humanorder_varpow (graph m1)) + (sort humanorder_varpow (graph m2));; + +(* ------------------------------------------------------------------------- *) +(* Conversions to strings. *) +(* ------------------------------------------------------------------------- *) + +let string_of_vector min_size max_size (v:vector) = + let n_raw = dim v in + if n_raw = 0 then "[]" else + let n = max min_size (min n_raw max_size) in + let xs = map ((o) string_of_num (element v)) (1--n) in + "[" ^ end_itlist (fun s t -> s ^ ", " ^ t) xs ^ + (if n_raw > max_size then ", ...]" else "]");; + +let string_of_matrix max_size (m:matrix) = + let i_raw,j_raw = dimensions m in + let i = min max_size i_raw and j = min max_size j_raw in + let rstr = map (fun k -> string_of_vector j j (row k m)) (1--i) in + "["^end_itlist(fun s t -> s^";\n "^t) rstr ^ + (if j > max_size then "\n ...]" else "]");; + +let string_of_vname (v:vname): string = (v: string);; + +let rec string_of_term t = + match t with + Opp t1 -> "(- " ^ string_of_term t1 ^ ")" +| Add (t1, t2) -> + "(" ^ (string_of_term t1) ^ " + " ^ (string_of_term t2) ^ ")" +| Sub (t1, t2) -> + "(" ^ (string_of_term t1) ^ " - " ^ (string_of_term t2) ^ ")" +| Mul (t1, t2) -> + "(" ^ (string_of_term t1) ^ " * " ^ (string_of_term t2) ^ ")" +| Inv t1 -> "(/ " ^ string_of_term t1 ^ ")" +| Div (t1, t2) -> + "(" ^ (string_of_term t1) ^ " / " ^ (string_of_term t2) ^ ")" +| Pow (t1, n1) -> + "(" ^ (string_of_term t1) ^ " ^ " ^ (string_of_int n1) ^ ")" +| Zero -> "0" +| Var v -> "x" ^ (string_of_vname v) +| Const x -> string_of_num x;; + + +let string_of_varpow x k = + if k = 1 then string_of_vname x else string_of_vname x^"^"^string_of_int k;; + +let string_of_monomial m = + if m = monomial_1 then "1" else + let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a) + (sort humanorder_varpow (graph m)) [] in + end_itlist (fun s t -> s^"*"^t) vps;; + +let string_of_cmonomial (c,m) = + if m = monomial_1 then string_of_num c + else if c =/ Int 1 then string_of_monomial m + else string_of_num c ^ "*" ^ string_of_monomial m;; + +let string_of_poly (p:poly) = + if p = poly_0 then "<<0>>" else + let cms = sort (fun (m1,_) (m2,_) -> humanorder_monomial m1 m2) (graph p) in + let s = + List.fold_left (fun a (m,c) -> + if c >";; + +(* ------------------------------------------------------------------------- *) +(* Printers. *) +(* ------------------------------------------------------------------------- *) + +let print_vector v = Format.print_string(string_of_vector 0 20 v);; + +let print_matrix m = Format.print_string(string_of_matrix 20 m);; + +let print_monomial m = Format.print_string(string_of_monomial m);; + +let print_poly m = Format.print_string(string_of_poly m);; + +(* +#install_printer print_vector;; +#install_printer print_matrix;; +#install_printer print_monomial;; +#install_printer print_poly;; +*) + +(* ------------------------------------------------------------------------- *) +(* Conversion from term. *) +(* ------------------------------------------------------------------------- *) + +let rec poly_of_term t = match t with + Zero -> poly_0 +| Const n -> poly_const n +| Var x -> poly_var x +| Opp t1 -> poly_neg (poly_of_term t1) +| Inv t1 -> + let p = poly_of_term t1 in + if poly_isconst p then poly_const(Int 1 // eval undefined p) + else failwith "poly_of_term: inverse of non-constant polyomial" +| Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r) +| Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r) +| Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r) +| Div (l, r) -> + let p = poly_of_term l and q = poly_of_term r in + if poly_isconst q then poly_cmul (Int 1 // eval undefined q) p + else failwith "poly_of_term: division by non-constant polynomial" +| Pow (t, n) -> + poly_pow (poly_of_term t) n;; + +(* ------------------------------------------------------------------------- *) +(* String of vector (just a list of space-separated numbers). *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_vector (v:vector) = + let n = dim v in + let strs = map (o (decimalize 20) (element v)) (1--n) in + end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; + +(* ------------------------------------------------------------------------- *) +(* String for block diagonal matrix numbered k. *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_blockdiagonal k m = + let pfx = string_of_int k ^" " in + let ents = + foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in + let entss = sort (increasing fst) ents in + itlist (fun ((b,i,j),c) a -> + pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ + " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; + +(* ------------------------------------------------------------------------- *) +(* String for a matrix numbered k, in SDPA sparse format. *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_matrix k (m:matrix) = + let pfx = string_of_int k ^ " 1 " in + let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) + (snd m) [] in + let mss = sort (increasing fst) ms in + itlist (fun ((i,j),c) a -> + pfx ^ string_of_int i ^ " " ^ string_of_int j ^ + " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; + +(* ------------------------------------------------------------------------- *) +(* String in SDPA sparse format for standard SDP problem: *) +(* *) +(* X = v_1 * [M_1] + ... + v_m * [M_m] - [M_0] must be PSD *) +(* Minimize obj_1 * v_1 + ... obj_m * v_m *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_problem comment obj mats = + let m = length mats - 1 + and n,_ = dimensions (hd mats) in + "\"" ^ comment ^ "\"\n" ^ + string_of_int m ^ "\n" ^ + "1\n" ^ + string_of_int n ^ "\n" ^ + sdpa_of_vector obj ^ + itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) + (1--length mats) mats "";; + +(* ------------------------------------------------------------------------- *) +(* More parser basics. *) +(* ------------------------------------------------------------------------- *) + +let word s = + end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t)) + (map a (explode s));; +let token s = + many (some isspace) ++ word s ++ many (some isspace) + >> (fun ((_,t),_) -> t);; + +let decimal = + let numeral = some isnum in + let decimalint = atleast 1 numeral >> ((o) Num.num_of_string implode) in + let decimalfrac = atleast 1 numeral + >> (fun s -> Num.num_of_string(implode s) // pow10 (length s)) in + let decimalsig = + decimalint ++ possibly (a "." ++ decimalfrac >> snd) + >> (function (h,[x]) -> h +/ x | (h,_) -> h) in + let signed prs = + a "-" ++ prs >> ((o) minus_num snd) + || a "+" ++ prs >> snd + || prs in + let exponent = (a "e" || a "E") ++ signed decimalint >> snd in + signed decimalsig ++ possibly exponent + >> (function (h,[x]) -> h */ power_num (Int 10) x | (h,_) -> h);; + +let mkparser p s = + let x,rst = p(explode s) in + if rst = [] then x else failwith "mkparser: unparsed input";; + +let parse_decimal = mkparser decimal;; + +(* ------------------------------------------------------------------------- *) +(* Parse back a vector. *) +(* ------------------------------------------------------------------------- *) + +let parse_sdpaoutput,parse_csdpoutput = + let vector = + token "{" ++ listof decimal (token ",") "decimal" ++ token "}" + >> (fun ((_,v),_) -> vector_of_list v) in + let rec skipupto dscr prs inp = + (dscr ++ prs >> snd + || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in + let ignore inp = (),[] in + let sdpaoutput = + skipupto (word "xVec" ++ token "=") + (vector ++ ignore >> fst) in + let csdpoutput = + (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++ + (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in + mkparser sdpaoutput,mkparser csdpoutput;; + +(* ------------------------------------------------------------------------- *) +(* Also parse the SDPA output to test success (CSDP yields a return code). *) +(* ------------------------------------------------------------------------- *) + +let sdpa_run_succeeded = + let rec skipupto dscr prs inp = + (dscr ++ prs >> snd + || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in + let prs = skipupto (word "phase.value" ++ token "=") + (possibly (a "p") ++ possibly (a "d") ++ + (word "OPT" || word "FEAS")) in + fun s -> try ignore (prs (explode s)); true with Noparse -> false;; + +(* ------------------------------------------------------------------------- *) +(* The default parameters. Unfortunately this goes to a fixed file. *) +(* ------------------------------------------------------------------------- *) + +let sdpa_default_parameters = +"100 unsigned int maxIteration; +1.0E-7 double 0.0 < epsilonStar; +1.0E2 double 0.0 < lambdaStar; +2.0 double 1.0 < omegaStar; +-1.0E5 double lowerBound; +1.0E5 double upperBound; +0.1 double 0.0 <= betaStar < 1.0; +0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar; +0.9 double 0.0 < gammaStar < 1.0; +1.0E-7 double 0.0 < epsilonDash; +";; + +(* ------------------------------------------------------------------------- *) +(* These were suggested by Makoto Yamashita for problems where we are *) +(* right at the edge of the semidefinite cone, as sometimes happens. *) +(* ------------------------------------------------------------------------- *) + +let sdpa_alt_parameters = +"1000 unsigned int maxIteration; +1.0E-7 double 0.0 < epsilonStar; +1.0E4 double 0.0 < lambdaStar; +2.0 double 1.0 < omegaStar; +-1.0E5 double lowerBound; +1.0E5 double upperBound; +0.1 double 0.0 <= betaStar < 1.0; +0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar; +0.9 double 0.0 < gammaStar < 1.0; +1.0E-7 double 0.0 < epsilonDash; +";; + +let sdpa_params = sdpa_alt_parameters;; + +(* ------------------------------------------------------------------------- *) +(* CSDP parameters; so far I'm sticking with the defaults. *) +(* ------------------------------------------------------------------------- *) + +let csdp_default_parameters = +"axtol=1.0e-8 +atytol=1.0e-8 +objtol=1.0e-8 +pinftol=1.0e8 +dinftol=1.0e8 +maxiter=100 +minstepfrac=0.9 +maxstepfrac=0.97 +minstepp=1.0e-8 +minstepd=1.0e-8 +usexzgap=1 +tweakgap=0 +affine=0 +printlevel=1 +";; + +let csdp_params = csdp_default_parameters;; + +(* ------------------------------------------------------------------------- *) +(* Now call CSDP on a problem and parse back the output. *) +(* ------------------------------------------------------------------------- *) + +let run_csdp dbg obj mats = + let input_file = Filename.temp_file "sos" ".dat-s" in + let output_file = + String.sub input_file 0 (String.length input_file - 6) ^ ".out" + and params_file = Filename.concat (!temp_path) "param.csdp" in + file_of_string input_file (sdpa_of_problem "" obj mats); + file_of_string params_file csdp_params; + let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^ + " " ^ output_file ^ + (if dbg then "" else "> /dev/null")) in + let op = string_of_file output_file in + let res = parse_csdpoutput op in + ((if dbg then () + else (Sys.remove input_file; Sys.remove output_file)); + rv,res);; + +let csdp obj mats = + let rv,res = run_csdp (!debugging) obj mats in + (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible" + else if rv = 3 then () + (* Format.print_string "csdp warning: Reduced accuracy"; + Format.print_newline() *) + else if rv <> 0 then failwith("csdp: error "^string_of_int rv) + else ()); + res;; + +(* ------------------------------------------------------------------------- *) +(* Try some apparently sensible scaling first. Note that this is purely to *) +(* get a cleaner translation to floating-point, and doesn't affect any of *) +(* the results, in principle. In practice it seems a lot better when there *) +(* are extreme numbers in the original problem. *) +(* ------------------------------------------------------------------------- *) + +let scale_then = + let common_denominator amat acc = + foldl (fun a m c -> lcm_num (denominator c) a) acc amat + and maximal_element amat acc = + foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in + fun solver obj mats -> + let cd1 = itlist common_denominator mats (Int 1) + and cd2 = common_denominator (snd obj) (Int 1) in + let mats' = map (mapf (fun x -> cd1 */ x)) mats + and obj' = vector_cmul cd2 obj in + let max1 = itlist maximal_element mats' (Int 0) + and max2 = maximal_element (snd obj') (Int 0) in + let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0)) + and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in + let mats'' = map (mapf (fun x -> x */ scal1)) mats' + and obj'' = vector_cmul scal2 obj' in + solver obj'' mats'';; + +(* ------------------------------------------------------------------------- *) +(* Round a vector to "nice" rationals. *) +(* ------------------------------------------------------------------------- *) + +let nice_rational n x = round_num (n */ x) // n;; + +let nice_vector n = mapa (nice_rational n);; + +(* ------------------------------------------------------------------------- *) +(* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *) +(* one tests A [-1;x1;..;xn] >= 0 (i.e. left column is negated constants). *) +(* ------------------------------------------------------------------------- *) + +let linear_program_basic a = + let m,n = dimensions a in + let mats = map (fun j -> diagonal (column j a)) (1--n) + and obj = vector_const (Int 1) m in + let rv,res = run_csdp false obj mats in + if rv = 1 or rv = 2 then false + else if rv = 0 then true + else failwith "linear_program: An error occurred in the SDP solver";; + +(* ------------------------------------------------------------------------- *) +(* Alternative interface testing A x >= b for matrix A, vector b. *) +(* ------------------------------------------------------------------------- *) + +let linear_program a b = + let m,n = dimensions a in + if dim b <> m then failwith "linear_program: incompatible dimensions" else + let mats = diagonal b :: map (fun j -> diagonal (column j a)) (1--n) + and obj = vector_const (Int 1) m in + let rv,res = run_csdp false obj mats in + if rv = 1 or rv = 2 then false + else if rv = 0 then true + else failwith "linear_program: An error occurred in the SDP solver";; + +(* ------------------------------------------------------------------------- *) +(* Test whether a point is in the convex hull of others. Rather than use *) +(* computational geometry, express as linear inequalities and call CSDP. *) +(* This is a bit lazy of me, but it's easy and not such a bottleneck so far. *) +(* ------------------------------------------------------------------------- *) + +let in_convex_hull pts pt = + let pts1 = (1::pt) :: map (fun x -> 1::x) pts in + let pts2 = map (fun p -> map (fun x -> -x) p @ p) pts1 in + let n = length pts + 1 + and v = 2 * (length pt + 1) in + let m = v + n - 1 in + let mat = + (m,n), + itern 1 pts2 (fun pts j -> itern 1 pts (fun x i -> (i,j) |-> Int x)) + (iter (1,n) (fun i -> (v + i,i+1) |-> Int 1) undefined) in + linear_program_basic mat;; + +(* ------------------------------------------------------------------------- *) +(* Filter down a set of points to a minimal set with the same convex hull. *) +(* ------------------------------------------------------------------------- *) + +let minimal_convex_hull = + let augment1 = function + | [] -> assert false + | (m::ms) -> if in_convex_hull ms m then ms else ms@[m] in + let augment m ms = funpow 3 augment1 (m::ms) in + fun mons -> + let mons' = itlist augment (tl mons) [hd mons] in + funpow (length mons') augment1 mons';; + +(* ------------------------------------------------------------------------- *) +(* Stuff for "equations" (generic A->num functions). *) +(* ------------------------------------------------------------------------- *) + +let equation_cmul c eq = + if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq;; + +let equation_add eq1 eq2 = combine (+/) (fun x -> x =/ Int 0) eq1 eq2;; + +let equation_eval assig eq = + let value v = apply assig v in + foldl (fun a v c -> a +/ value(v) */ c) (Int 0) eq;; + +(* ------------------------------------------------------------------------- *) +(* Eliminate among linear equations: return unconstrained variables and *) +(* assignments for the others in terms of them. We give one pseudo-variable *) +(* "one" that's used for a constant term. *) +(* ------------------------------------------------------------------------- *) + +let failstore = ref [];; + +let eliminate_equations = + let rec extract_first p l = + match l with + [] -> failwith "extract_first" + | h::t -> if p(h) then h,t else + let k,s = extract_first p t in + k,h::s in + let rec eliminate vars dun eqs = + match vars with + [] -> if forall is_undefined eqs then dun + else (failstore := [vars,dun,eqs]; raise Unsolvable) + | v::vs -> + try let eq,oeqs = extract_first (fun e -> defined e v) eqs in + let a = apply eq v in + let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in + let elim e = + let b = tryapplyd e v (Int 0) in + if b =/ Int 0 then e else + equation_add e (equation_cmul (minus_num b // a) eq) in + eliminate vs ((v |-> eq') (mapf elim dun)) (map elim oeqs) + with Failure _ -> eliminate vs dun eqs in + fun one vars eqs -> + let assig = eliminate vars undefined eqs in + let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in + setify vs,assig;; + +(* ------------------------------------------------------------------------- *) +(* Eliminate all variables, in an essentially arbitrary order. *) +(* ------------------------------------------------------------------------- *) + +let eliminate_all_equations one = + let choose_variable eq = + let (v,_) = choose eq in + if v = one then + let eq' = undefine v eq in + if is_undefined eq' then failwith "choose_variable" else + let (w,_) = choose eq' in w + else v in + let rec eliminate dun eqs = + match eqs with + [] -> dun + | eq::oeqs -> + if is_undefined eq then eliminate dun oeqs else + let v = choose_variable eq in + let a = apply eq v in + let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in + let elim e = + let b = tryapplyd e v (Int 0) in + if b =/ Int 0 then e else + equation_add e (equation_cmul (minus_num b // a) eq) in + eliminate ((v |-> eq') (mapf elim dun)) (map elim oeqs) in + fun eqs -> + let assig = eliminate undefined eqs in + let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in + setify vs,assig;; + +(* ------------------------------------------------------------------------- *) +(* Solve equations by assigning arbitrary numbers. *) +(* ------------------------------------------------------------------------- *) + +let solve_equations one eqs = + let vars,assigs = eliminate_all_equations one eqs in + let vfn = itlist (fun v -> (v |-> Int 0)) vars (one |=> Int(-1)) in + let ass = + combine (+/) (fun c -> false) (mapf (equation_eval vfn) assigs) vfn in + if forall (fun e -> equation_eval ass e =/ Int 0) eqs + then undefine one ass else raise Sanity;; + +(* ------------------------------------------------------------------------- *) +(* Hence produce the "relevant" monomials: those whose squares lie in the *) +(* Newton polytope of the monomials in the input. (This is enough according *) +(* to Reznik: "Extremal PSD forms with few terms", Duke Math. Journal, *) +(* vol 45, pp. 363--374, 1978. *) +(* *) +(* These are ordered in sort of decreasing degree. In particular the *) +(* constant monomial is last; this gives an order in diagonalization of the *) +(* quadratic form that will tend to display constants. *) +(* ------------------------------------------------------------------------- *) + +let newton_polytope pol = + let vars = poly_variables pol in + let mons = map (fun m -> map (fun x -> monomial_degree x m) vars) (dom pol) + and ds = map (fun x -> (degree x pol + 1) / 2) vars in + let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]] + and mons' = minimal_convex_hull mons in + let all' = + filter (fun m -> in_convex_hull mons' (map (fun x -> 2 * x) m)) all in + map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a) + vars m monomial_1) (rev all');; + +(* ------------------------------------------------------------------------- *) +(* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *) +(* ------------------------------------------------------------------------- *) + +let diag m = + let nn = dimensions m in + let n = fst nn in + if snd nn <> n then failwith "diagonalize: non-square matrix" else + let rec diagonalize i m = + if is_zero m then [] else + let a11 = element m (i,i) in + if a11 a1k // a11) v in + let m' = + (n,n), + iter (i+1,n) (fun j -> + iter (i+1,n) (fun k -> + ((j,k) |--> (element m (j,k) -/ element v j */ element v' k)))) + undefined in + (a11,v')::diagonalize (i + 1) m' in + diagonalize 1 m;; + +(* ------------------------------------------------------------------------- *) +(* Adjust a diagonalization to collect rationals at the start. *) +(* ------------------------------------------------------------------------- *) + +let deration d = + if d = [] then Int 0,d else + let adj(c,l) = + let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) // + foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in + (c // (a */ a)),mapa (fun x -> a */ x) l in + let d' = map adj d in + let a = itlist ((o) lcm_num ( (o) denominator fst)) d' (Int 1) // + itlist ((o) gcd_num ( (o) numerator fst)) d' (Int 0) in + (Int 1 // a),map (fun (c,l) -> (a */ c,l)) d';; + +(* ------------------------------------------------------------------------- *) +(* Enumeration of monomials with given multidegree bound. *) +(* ------------------------------------------------------------------------- *) + +let rec enumerate_monomials d vars = + if d < 0 then [] + else if d = 0 then [undefined] + else if vars = [] then [monomial_1] else + let alts = + map (fun k -> let oths = enumerate_monomials (d - k) (tl vars) in + map (fun ks -> if k = 0 then ks else (hd vars |-> k) ks) oths) + (0--d) in + end_itlist (@) alts;; + +(* ------------------------------------------------------------------------- *) +(* Enumerate products of distinct input polys with degree <= d. *) +(* We ignore any constant input polynomials. *) +(* Give the output polynomial and a record of how it was derived. *) +(* ------------------------------------------------------------------------- *) + +let rec enumerate_products d pols = + if d = 0 then [poly_const num_1,Rational_lt num_1] else if d < 0 then [] else + match pols with + [] -> [poly_const num_1,Rational_lt num_1] + | (p,b)::ps -> let e = multidegree p in + if e = 0 then enumerate_products d ps else + enumerate_products d ps @ + map (fun (q,c) -> poly_mul p q,Product(b,c)) + (enumerate_products (d - e) ps);; + +(* ------------------------------------------------------------------------- *) +(* Multiply equation-parametrized poly by regular poly and add accumulator. *) +(* ------------------------------------------------------------------------- *) + +let epoly_pmul p q acc = + foldl (fun a m1 c -> + foldl (fun b m2 e -> + let m = monomial_mul m1 m2 in + let es = tryapplyd b m undefined in + (m |-> equation_add (equation_cmul c e) es) b) + a q) acc p;; + +(* ------------------------------------------------------------------------- *) +(* Usual operations on equation-parametrized poly. *) +(* ------------------------------------------------------------------------- *) + +let epoly_cmul c l = + if c =/ Int 0 then undefined else mapf (equation_cmul c) l;; + +let epoly_neg = epoly_cmul (Int(-1));; + +let epoly_add = combine equation_add is_undefined;; + +let epoly_sub p q = epoly_add p (epoly_neg q);; + +(* ------------------------------------------------------------------------- *) +(* Convert regular polynomial. Note that we treat (0,0,0) as -1. *) +(* ------------------------------------------------------------------------- *) + +let epoly_of_poly p = + foldl (fun a m c -> (m |-> ((0,0,0) |=> minus_num c)) a) undefined p;; + +(* ------------------------------------------------------------------------- *) +(* String for block diagonal matrix numbered k. *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_blockdiagonal k m = + let pfx = string_of_int k ^" " in + let ents = + foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in + let entss = sort (increasing fst) ents in + itlist (fun ((b,i,j),c) a -> + pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ + " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; + +(* ------------------------------------------------------------------------- *) +(* SDPA for problem using block diagonal (i.e. multiple SDPs) *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_blockproblem comment nblocks blocksizes obj mats = + let m = length mats - 1 in + "\"" ^ comment ^ "\"\n" ^ + string_of_int m ^ "\n" ^ + string_of_int nblocks ^ "\n" ^ + (end_itlist (fun s t -> s^" "^t) (map string_of_int blocksizes)) ^ + "\n" ^ + sdpa_of_vector obj ^ + itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) + (1--length mats) mats "";; + +(* ------------------------------------------------------------------------- *) +(* Hence run CSDP on a problem in block diagonal form. *) +(* ------------------------------------------------------------------------- *) + +let run_csdp dbg nblocks blocksizes obj mats = + let input_file = Filename.temp_file "sos" ".dat-s" in + let output_file = + String.sub input_file 0 (String.length input_file - 6) ^ ".out" + and params_file = Filename.concat (!temp_path) "param.csdp" in + file_of_string input_file + (sdpa_of_blockproblem "" nblocks blocksizes obj mats); + file_of_string params_file csdp_params; + let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^ + " " ^ output_file ^ + (if dbg then "" else "> /dev/null")) in + let op = string_of_file output_file in + let res = parse_csdpoutput op in + ((if dbg then () + else (Sys.remove input_file; Sys.remove output_file)); + rv,res);; + +let csdp nblocks blocksizes obj mats = + let rv,res = run_csdp (!debugging) nblocks blocksizes obj mats in + (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible" + else if rv = 3 then () + (*Format.print_string "csdp warning: Reduced accuracy"; + Format.print_newline() *) + else if rv <> 0 then failwith("csdp: error "^string_of_int rv) + else ()); + res;; + +(* ------------------------------------------------------------------------- *) +(* 3D versions of matrix operations to consider blocks separately. *) +(* ------------------------------------------------------------------------- *) + +let bmatrix_add = combine (+/) (fun x -> x =/ Int 0);; + +let bmatrix_cmul c bm = + if c =/ Int 0 then undefined + else mapf (fun x -> c */ x) bm;; + +let bmatrix_neg = bmatrix_cmul (Int(-1));; + +let bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);; + +(* ------------------------------------------------------------------------- *) +(* Smash a block matrix into components. *) +(* ------------------------------------------------------------------------- *) + +let blocks blocksizes bm = + map (fun (bs,b0) -> + let m = foldl + (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a) + undefined bm in + (((bs,bs),m):matrix)) + (zip blocksizes (1--length blocksizes));; + +(* ------------------------------------------------------------------------- *) +(* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *) +(* ------------------------------------------------------------------------- *) + +let real_positivnullstellensatz_general linf d eqs leqs pol = + let vars = itlist ((o) union poly_variables) (pol::eqs @ map fst leqs) [] in + let monoid = + if linf then + (poly_const num_1,Rational_lt num_1):: + (filter (fun (p,c) -> multidegree p <= d) leqs) + else enumerate_products d leqs in + let nblocks = length monoid in + let mk_idmultiplier k p = + let e = d - multidegree p in + let mons = enumerate_monomials e vars in + let nons = zip mons (1--length mons) in + mons, + itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in + let mk_sqmultiplier k (p,c) = + let e = (d - multidegree p) / 2 in + let mons = enumerate_monomials e vars in + let nons = zip mons (1--length mons) in + mons, + itlist (fun (m1,n1) -> + itlist (fun (m2,n2) a -> + let m = monomial_mul m1 m2 in + if n1 > n2 then a else + let c = if n1 = n2 then Int 1 else Int 2 in + let e = tryapplyd a m undefined in + (m |-> equation_add ((k,n1,n2) |=> c) e) a) + nons) + nons undefined in + let sqmonlist,sqs = unzip(map2 mk_sqmultiplier (1--length monoid) monoid) + and idmonlist,ids = unzip(map2 mk_idmultiplier (1--length eqs) eqs) in + let blocksizes = map length sqmonlist in + let bigsum = + itlist2 (fun p q a -> epoly_pmul p q a) eqs ids + (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs + (epoly_of_poly(poly_neg pol))) in + let eqns = foldl (fun a m e -> e::a) [] bigsum in + let pvs,assig = eliminate_all_equations (0,0,0) eqns in + let qvars = (0,0,0)::pvs in + let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in + let mk_matrix v = + foldl (fun m (b,i,j) ass -> if b < 0 then m else + let c = tryapplyd ass v (Int 0) in + if c =/ Int 0 then m else + ((b,j,i) |-> c) (((b,i,j) |-> c) m)) + undefined allassig in + let diagents = foldl + (fun a (b,i,j) e -> if b > 0 & i = j then equation_add e a else a) + undefined allassig in + let mats = map mk_matrix qvars + and obj = length pvs, + itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0))) + undefined in + let raw_vec = if pvs = [] then vector_0 0 + else scale_then (csdp nblocks blocksizes) obj mats in + let find_rounding d = + (if !debugging then + (Format.print_string("Trying rounding with limit "^string_of_num d); + Format.print_newline()) + else ()); + let vec = nice_vector d raw_vec in + let blockmat = iter (1,dim vec) + (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a) + (bmatrix_neg (el 0 mats)) in + let allmats = blocks blocksizes blockmat in + vec,map diag allmats in + let vec,ratdias = + if pvs = [] then find_rounding num_1 + else tryfind find_rounding (map Num.num_of_int (1--31) @ + map pow2 (5--66)) in + let newassigs = + itlist (fun k -> el (k - 1) pvs |-> element vec k) + (1--dim vec) ((0,0,0) |=> Int(-1)) in + let finalassigs = + foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs + allassig in + let poly_of_epoly p = + foldl (fun a v e -> (v |--> equation_eval finalassigs e) a) + undefined p in + let mk_sos mons = + let mk_sq (c,m) = + c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a) + (1--length mons) undefined in + map mk_sq in + let sqs = map2 mk_sos sqmonlist ratdias + and cfs = map poly_of_epoly ids in + let msq = filter (fun (a,b) -> b <> []) (map2 (fun a b -> a,b) monoid sqs) in + let eval_sq sqs = itlist + (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in + let sanity = + itlist (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq + (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs + (poly_neg pol)) in + if not(is_undefined sanity) then raise Sanity else + cfs,map (fun (a,b) -> snd a,b) msq;; + +(* ------------------------------------------------------------------------- *) +(* Iterative deepening. *) +(* ------------------------------------------------------------------------- *) + +let rec deepen f n = + try print_string "Searching with depth limit "; + print_int n; print_newline(); f n + with Failure _ -> deepen f (n + 1);; + +(* ------------------------------------------------------------------------- *) +(* The ordering so we can create canonical HOL polynomials. *) +(* ------------------------------------------------------------------------- *) + +let dest_monomial mon = sort (increasing fst) (graph mon);; + +let monomial_order = + let rec lexorder l1 l2 = + match (l1,l2) with + [],[] -> true + | vps,[] -> false + | [],vps -> true + | ((x1,n1)::vs1),((x2,n2)::vs2) -> + if x1 < x2 then true + else if x2 < x1 then false + else if n1 < n2 then false + else if n2 < n1 then true + else lexorder vs1 vs2 in + fun m1 m2 -> + if m2 = monomial_1 then true else if m1 = monomial_1 then false else + let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in + let deg1 = itlist ((o) (+) snd) mon1 0 + and deg2 = itlist ((o) (+) snd) mon2 0 in + if deg1 < deg2 then false else if deg1 > deg2 then true + else lexorder mon1 mon2;; + +let dest_poly p = + map (fun (m,c) -> c,dest_monomial m) + (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));; + +(* ------------------------------------------------------------------------- *) +(* Map back polynomials and their composites to HOL. *) +(* ------------------------------------------------------------------------- *) + +let term_of_varpow = + fun x k -> + if k = 1 then Var x else Pow (Var x, k);; + +let term_of_monomial = + fun m -> if m = monomial_1 then Const num_1 else + let m' = dest_monomial m in + let vps = itlist (fun (x,k) a -> term_of_varpow x k :: a) m' [] in + end_itlist (fun s t -> Mul (s,t)) vps;; + +let term_of_cmonomial = + fun (m,c) -> + if m = monomial_1 then Const c + else if c =/ num_1 then term_of_monomial m + else Mul (Const c,term_of_monomial m);; + +let term_of_poly = + fun p -> + if p = poly_0 then Zero else + let cms = map term_of_cmonomial + (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in + end_itlist (fun t1 t2 -> Add (t1,t2)) cms;; + +let term_of_sqterm (c,p) = + Product(Rational_lt c,Square(term_of_poly p));; + +let term_of_sos (pr,sqs) = + if sqs = [] then pr + else Product(pr,end_itlist (fun a b -> Sum(a,b)) (map term_of_sqterm sqs));; + +(* ------------------------------------------------------------------------- *) +(* Interface to HOL. *) +(* ------------------------------------------------------------------------- *) +(* +let REAL_NONLINEAR_PROVER translator (eqs,les,lts) = + let eq0 = map (poly_of_term o lhand o concl) eqs + and le0 = map (poly_of_term o lhand o concl) les + and lt0 = map (poly_of_term o lhand o concl) lts in + let eqp0 = map (fun (t,i) -> t,Axiom_eq i) (zip eq0 (0--(length eq0 - 1))) + and lep0 = map (fun (t,i) -> t,Axiom_le i) (zip le0 (0--(length le0 - 1))) + and ltp0 = map (fun (t,i) -> t,Axiom_lt i) (zip lt0 (0--(length lt0 - 1))) in + let keq,eq = partition (fun (p,_) -> multidegree p = 0) eqp0 + and klep,lep = partition (fun (p,_) -> multidegree p = 0) lep0 + and kltp,ltp = partition (fun (p,_) -> multidegree p = 0) ltp0 in + let trivial_axiom (p,ax) = + match ax with + Axiom_eq n when eval undefined p <>/ num_0 -> el n eqs + | Axiom_le n when eval undefined p el n les + | Axiom_lt n when eval undefined p <=/ num_0 -> el n lts + | _ -> failwith "not a trivial axiom" in + try let th = tryfind trivial_axiom (keq @ klep @ kltp) in + CONV_RULE (LAND_CONV REAL_POLY_CONV THENC REAL_RAT_RED_CONV) th + with Failure _ -> + let pol = itlist poly_mul (map fst ltp) (poly_const num_1) in + let leq = lep @ ltp in + let tryall d = + let e = multidegree pol in + let k = if e = 0 then 0 else d / e in + let eq' = map fst eq in + tryfind (fun i -> d,i,real_positivnullstellensatz_general false d eq' leq + (poly_neg(poly_pow pol i))) + (0--k) in + let d,i,(cert_ideal,cert_cone) = deepen tryall 0 in + let proofs_ideal = + map2 (fun q (p,ax) -> Eqmul(term_of_poly q,ax)) cert_ideal eq + and proofs_cone = map term_of_sos cert_cone + and proof_ne = + if ltp = [] then Rational_lt num_1 else + let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in + funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in + let proof = end_itlist (fun s t -> Sum(s,t)) + (proof_ne :: proofs_ideal @ proofs_cone) in + print_string("Translating proof certificate to HOL"); + print_newline(); + translator (eqs,les,lts) proof;; +*) +(* ------------------------------------------------------------------------- *) +(* A wrapper that tries to substitute away variables first. *) +(* ------------------------------------------------------------------------- *) +(* +let REAL_NONLINEAR_SUBST_PROVER = + let zero = `&0:real` + and mul_tm = `( * ):real->real->real` + and shuffle1 = + CONV_RULE(REWR_CONV(REAL_ARITH `a + x = (y:real) <=> x = y - a`)) + and shuffle2 = + CONV_RULE(REWR_CONV(REAL_ARITH `x + a = (y:real) <=> x = y - a`)) in + let rec substitutable_monomial fvs tm = + match tm with + Var(_,Tyapp("real",[])) when not (mem tm fvs) -> Int 1,tm + | Comb(Comb(Const("real_mul",_),c),(Var(_,_) as t)) + when is_ratconst c & not (mem t fvs) + -> rat_of_term c,t + | Comb(Comb(Const("real_add",_),s),t) -> + (try substitutable_monomial (union (frees t) fvs) s + with Failure _ -> substitutable_monomial (union (frees s) fvs) t) + | _ -> failwith "substitutable_monomial" + and isolate_variable v th = + match lhs(concl th) with + x when x = v -> th + | Comb(Comb(Const("real_add",_),(Var(_,Tyapp("real",[])) as x)),t) + when x = v -> shuffle2 th + | Comb(Comb(Const("real_add",_),s),t) -> + isolate_variable v(shuffle1 th) in + let make_substitution th = + let (c,v) = substitutable_monomial [] (lhs(concl th)) in + let th1 = AP_TERM (mk_comb(mul_tm,term_of_rat(Int 1 // c))) th in + let th2 = CONV_RULE(BINOP_CONV REAL_POLY_MUL_CONV) th1 in + CONV_RULE (RAND_CONV REAL_POLY_CONV) (isolate_variable v th2) in + fun translator -> + let rec substfirst(eqs,les,lts) = + try let eth = tryfind make_substitution eqs in + let modify = + CONV_RULE(LAND_CONV(SUBS_CONV[eth] THENC REAL_POLY_CONV)) in + substfirst(filter (fun t -> lhand(concl t) <> zero) (map modify eqs), + map modify les,map modify lts) + with Failure _ -> REAL_NONLINEAR_PROVER translator (eqs,les,lts) in + substfirst;; +*) +(* ------------------------------------------------------------------------- *) +(* Overall function. *) +(* ------------------------------------------------------------------------- *) +(* +let REAL_SOS = + let init = GEN_REWRITE_CONV ONCE_DEPTH_CONV [DECIMAL] + and pure = GEN_REAL_ARITH REAL_NONLINEAR_SUBST_PROVER in + fun tm -> let th = init tm in EQ_MP (SYM th) (pure(rand(concl th)));; +*) +(* ------------------------------------------------------------------------- *) +(* Add hacks for division. *) +(* ------------------------------------------------------------------------- *) +(* +let REAL_SOSFIELD = + let inv_tm = `inv:real->real` in + let prenex_conv = + TOP_DEPTH_CONV BETA_CONV THENC + PURE_REWRITE_CONV[FORALL_SIMP; EXISTS_SIMP; real_div; + REAL_INV_INV; REAL_INV_MUL; GSYM REAL_POW_INV] THENC + NNFC_CONV THENC DEPTH_BINOP_CONV `(/\)` CONDS_CELIM_CONV THENC + PRENEX_CONV + and setup_conv = NNF_CONV THENC WEAK_CNF_CONV THENC CONJ_CANON_CONV + and core_rule t = + try REAL_ARITH t + with Failure _ -> try REAL_RING t + with Failure _ -> REAL_SOS t + and is_inv = + let is_div = is_binop `(/):real->real->real` in + fun tm -> (is_div tm or (is_comb tm & rator tm = inv_tm)) & + not(is_ratconst(rand tm)) in + let BASIC_REAL_FIELD tm = + let is_freeinv t = is_inv t & free_in t tm in + let itms = setify(map rand (find_terms is_freeinv tm)) in + let hyps = map (fun t -> SPEC t REAL_MUL_RINV) itms in + let tm' = itlist (fun th t -> mk_imp(concl th,t)) hyps tm in + let itms' = map (curry mk_comb inv_tm) itms in + let gvs = map (genvar o type_of) itms' in + let tm'' = subst (zip gvs itms') tm' in + let th1 = setup_conv tm'' in + let cjs = conjuncts(rand(concl th1)) in + let ths = map core_rule cjs in + let th2 = EQ_MP (SYM th1) (end_itlist CONJ ths) in + rev_itlist (C MP) hyps (INST (zip itms' gvs) th2) in + fun tm -> + let th0 = prenex_conv tm in + let tm0 = rand(concl th0) in + let avs,bod = strip_forall tm0 in + let th1 = setup_conv bod in + let ths = map BASIC_REAL_FIELD (conjuncts(rand(concl th1))) in + EQ_MP (SYM th0) (GENL avs (EQ_MP (SYM th1) (end_itlist CONJ ths)));; +*) +(* ------------------------------------------------------------------------- *) +(* Integer version. *) +(* ------------------------------------------------------------------------- *) +(* +let INT_SOS = + let atom_CONV = + let pth = prove + (`(~(x <= y) <=> y + &1 <= x:int) /\ + (~(x < y) <=> y <= x) /\ + (~(x = y) <=> x + &1 <= y \/ y + &1 <= x) /\ + (x < y <=> x + &1 <= y)`, + REWRITE_TAC[INT_NOT_LE; INT_NOT_LT; INT_NOT_EQ; INT_LT_DISCRETE]) in + GEN_REWRITE_CONV I [pth] + and bub_CONV = GEN_REWRITE_CONV TOP_SWEEP_CONV + [int_eq; int_le; int_lt; int_ge; int_gt; + int_of_num_th; int_neg_th; int_add_th; int_mul_th; + int_sub_th; int_pow_th; int_abs_th; int_max_th; int_min_th] in + let base_CONV = TRY_CONV atom_CONV THENC bub_CONV in + let NNF_NORM_CONV = GEN_NNF_CONV false + (base_CONV,fun t -> base_CONV t,base_CONV(mk_neg t)) in + let init_CONV = + GEN_REWRITE_CONV DEPTH_CONV [FORALL_SIMP; EXISTS_SIMP] THENC + GEN_REWRITE_CONV DEPTH_CONV [INT_GT; INT_GE] THENC + CONDS_ELIM_CONV THENC NNF_NORM_CONV in + let p_tm = `p:bool` + and not_tm = `(~)` in + let pth = TAUT(mk_eq(mk_neg(mk_neg p_tm),p_tm)) in + fun tm -> + let th0 = INST [tm,p_tm] pth + and th1 = NNF_NORM_CONV(mk_neg tm) in + let th2 = REAL_SOS(mk_neg(rand(concl th1))) in + EQ_MP th0 (EQ_MP (AP_TERM not_tm (SYM th1)) th2);; +*) +(* ------------------------------------------------------------------------- *) +(* Natural number version. *) +(* ------------------------------------------------------------------------- *) +(* +let SOS_RULE tm = + let avs = frees tm in + let tm' = list_mk_forall(avs,tm) in + let th1 = NUM_TO_INT_CONV tm' in + let th2 = INT_SOS (rand(concl th1)) in + SPECL avs (EQ_MP (SYM th1) th2);; +*) +(* ------------------------------------------------------------------------- *) +(* Now pure SOS stuff. *) +(* ------------------------------------------------------------------------- *) + +(*prioritize_real();;*) + +(* ------------------------------------------------------------------------- *) +(* Some combinatorial helper functions. *) +(* ------------------------------------------------------------------------- *) + +let rec allpermutations l = + if l = [] then [[]] else + itlist (fun h acc -> map (fun t -> h::t) + (allpermutations (subtract l [h])) @ acc) l [];; + +let allvarorders l = + map (fun vlis x -> index x vlis) (allpermutations l);; + +let changevariables_monomial zoln (m:monomial) = + foldl (fun a x k -> (assoc x zoln |-> k) a) monomial_1 m;; + +let changevariables zoln pol = + foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a) + poly_0 pol;; + +(* ------------------------------------------------------------------------- *) +(* Return to original non-block matrices. *) +(* ------------------------------------------------------------------------- *) + +let sdpa_of_vector (v:vector) = + let n = dim v in + let strs = map (o (decimalize 20) (element v)) (1--n) in + end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; + +let sdpa_of_blockdiagonal k m = + let pfx = string_of_int k ^" " in + let ents = + foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in + let entss = sort (increasing fst) ents in + itlist (fun ((b,i,j),c) a -> + pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ + " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; + +let sdpa_of_matrix k (m:matrix) = + let pfx = string_of_int k ^ " 1 " in + let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) + (snd m) [] in + let mss = sort (increasing fst) ms in + itlist (fun ((i,j),c) a -> + pfx ^ string_of_int i ^ " " ^ string_of_int j ^ + " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; + +let sdpa_of_problem comment obj mats = + let m = length mats - 1 + and n,_ = dimensions (hd mats) in + "\"" ^ comment ^ "\"\n" ^ + string_of_int m ^ "\n" ^ + "1\n" ^ + string_of_int n ^ "\n" ^ + sdpa_of_vector obj ^ + itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) + (1--length mats) mats "";; + +let run_csdp dbg obj mats = + let input_file = Filename.temp_file "sos" ".dat-s" in + let output_file = + String.sub input_file 0 (String.length input_file - 6) ^ ".out" + and params_file = Filename.concat (!temp_path) "param.csdp" in + file_of_string input_file (sdpa_of_problem "" obj mats); + file_of_string params_file csdp_params; + let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^ + " " ^ output_file ^ + (if dbg then "" else "> /dev/null")) in + let op = string_of_file output_file in + let res = parse_csdpoutput op in + ((if dbg then () + else (Sys.remove input_file; Sys.remove output_file)); + rv,res);; + +let csdp obj mats = + let rv,res = run_csdp (!debugging) obj mats in + (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible" + else if rv = 3 then () +(* (Format.print_string "csdp warning: Reduced accuracy"; + Format.print_newline()) *) + else if rv <> 0 then failwith("csdp: error "^string_of_int rv) + else ()); + res;; + +(* ------------------------------------------------------------------------- *) +(* Sum-of-squares function with some lowbrow symmetry reductions. *) +(* ------------------------------------------------------------------------- *) + +let sumofsquares_general_symmetry tool pol = + let vars = poly_variables pol + and lpps = newton_polytope pol in + let n = length lpps in + let sym_eqs = + let invariants = filter + (fun vars' -> + is_undefined(poly_sub pol (changevariables (zip vars vars') pol))) + (allpermutations vars) in + let lpns = zip lpps (1--length lpps) in + let lppcs = + filter (fun (m,(n1,n2)) -> n1 <= n2) + (allpairs + (fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in + let clppcs = end_itlist (@) + (map (fun ((m1,m2),(n1,n2)) -> + map (fun vars' -> + (changevariables_monomial (zip vars vars') m1, + changevariables_monomial (zip vars vars') m2),(n1,n2)) + invariants) + lppcs) in + let clppcs_dom = setify(map fst clppcs) in + let clppcs_cls = map (fun d -> filter (fun (e,_) -> e = d) clppcs) + clppcs_dom in + let eqvcls = map (o setify (map snd)) clppcs_cls in + let mk_eq cls acc = + match cls with + [] -> raise Sanity + | [h] -> acc + | h::t -> map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in + itlist mk_eq eqvcls [] in + let eqs = foldl (fun a x y -> y::a) [] + (itern 1 lpps (fun m1 n1 -> + itern 1 lpps (fun m2 n2 f -> + let m = monomial_mul m1 m2 in + if n1 > n2 then f else + let c = if n1 = n2 then Int 1 else Int 2 in + (m |-> ((n1,n2) |-> c) (tryapplyd f m undefined)) f)) + (foldl (fun a m c -> (m |-> ((0,0)|=>c)) a) + undefined pol)) @ + sym_eqs in + let pvs,assig = eliminate_all_equations (0,0) eqs in + let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in + let qvars = (0,0)::pvs in + let diagents = + end_itlist equation_add (map (fun i -> apply allassig (i,i)) (1--n)) in + let mk_matrix v = + ((n,n), + foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in + if c =/ Int 0 then m else + ((j,i) |-> c) (((i,j) |-> c) m)) + undefined allassig :matrix) in + let mats = map mk_matrix qvars + and obj = length pvs, + itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0))) + undefined in + let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in + let find_rounding d = + (if !debugging then + (Format.print_string("Trying rounding with limit "^string_of_num d); + Format.print_newline()) + else ()); + let vec = nice_vector d raw_vec in + let mat = iter (1,dim vec) + (fun i a -> matrix_add (matrix_cmul (element vec i) (el i mats)) a) + (matrix_neg (el 0 mats)) in + deration(diag mat) in + let rat,dia = + if pvs = [] then + let mat = matrix_neg (el 0 mats) in + deration(diag mat) + else + tryfind find_rounding (map Num.num_of_int (1--31) @ + map pow2 (5--66)) in + let poly_of_lin(d,v) = + d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in + let lins = map poly_of_lin dia in + let sqs = map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in + let sos = poly_cmul rat (end_itlist poly_add sqs) in + if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;; + +let sumofsquares = sumofsquares_general_symmetry csdp;; + +(* ------------------------------------------------------------------------- *) +(* Pure HOL SOS conversion. *) +(* ------------------------------------------------------------------------- *) +(* +let SOS_CONV = + let mk_square = + let pow_tm = `(pow)` and two_tm = `2` in + fun tm -> mk_comb(mk_comb(pow_tm,tm),two_tm) + and mk_prod = mk_binop `( * )` + and mk_sum = mk_binop `(+)` in + fun tm -> + let k,sos = sumofsquares(poly_of_term tm) in + let mk_sqtm(c,p) = + mk_prod (term_of_rat(k */ c)) (mk_square(term_of_poly p)) in + let tm' = end_itlist mk_sum (map mk_sqtm sos) in + let th = REAL_POLY_CONV tm and th' = REAL_POLY_CONV tm' in + TRANS th (SYM th');; +*) +(* ------------------------------------------------------------------------- *) +(* Attempt to prove &0 <= x by direct SOS decomposition. *) +(* ------------------------------------------------------------------------- *) +(* +let PURE_SOS_TAC = + let tac = + MATCH_ACCEPT_TAC(REWRITE_RULE[GSYM REAL_POW_2] REAL_LE_SQUARE) ORELSE + MATCH_ACCEPT_TAC REAL_LE_SQUARE ORELSE + (MATCH_MP_TAC REAL_LE_ADD THEN CONJ_TAC) ORELSE + (MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC) ORELSE + CONV_TAC(RAND_CONV REAL_RAT_REDUCE_CONV THENC REAL_RAT_LE_CONV) in + REPEAT GEN_TAC THEN REWRITE_TAC[real_ge] THEN + GEN_REWRITE_TAC I [GSYM REAL_SUB_LE] THEN + CONV_TAC(RAND_CONV SOS_CONV) THEN + REPEAT tac THEN NO_TAC;; + +let PURE_SOS tm = prove(tm,PURE_SOS_TAC);; +*) +(* ------------------------------------------------------------------------- *) +(* Examples. *) +(* ------------------------------------------------------------------------- *) + +(***** + +time REAL_SOS + `a1 >= &0 /\ a2 >= &0 /\ + (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + &2) /\ + (a1 * b1 + a2 * b2 = &0) + ==> a1 * a2 - b1 * b2 >= &0`;; + +time REAL_SOS `&3 * x + &7 * a < &4 /\ &3 < &2 * x ==> a < &0`;; + +time REAL_SOS + `b pow 2 < &4 * a * c ==> ~(a * x pow 2 + b * x + c = &0)`;; + +time REAL_SOS + `(a * x pow 2 + b * x + c = &0) ==> b pow 2 >= &4 * a * c`;; + +time REAL_SOS + `&0 <= x /\ x <= &1 /\ &0 <= y /\ y <= &1 + ==> x pow 2 + y pow 2 < &1 \/ + (x - &1) pow 2 + y pow 2 < &1 \/ + x pow 2 + (y - &1) pow 2 < &1 \/ + (x - &1) pow 2 + (y - &1) pow 2 < &1`;; + +time REAL_SOS + `&0 <= b /\ &0 <= c /\ &0 <= x /\ &0 <= y /\ + (x pow 2 = c) /\ (y pow 2 = a pow 2 * c + b) + ==> a * c <= y * x`;; + +time REAL_SOS + `&0 <= x /\ &0 <= y /\ &0 <= z /\ x + y + z <= &3 + ==> x * y + x * z + y * z >= &3 * x * y * z`;; + +time REAL_SOS + `(x pow 2 + y pow 2 + z pow 2 = &1) ==> (x + y + z) pow 2 <= &3`;; + +time REAL_SOS + `(w pow 2 + x pow 2 + y pow 2 + z pow 2 = &1) + ==> (w + x + y + z) pow 2 <= &4`;; + +time REAL_SOS + `x >= &1 /\ y >= &1 ==> x * y >= x + y - &1`;; + +time REAL_SOS + `x > &1 /\ y > &1 ==> x * y > x + y - &1`;; + +time REAL_SOS + `abs(x) <= &1 + ==> abs(&64 * x pow 7 - &112 * x pow 5 + &56 * x pow 3 - &7 * x) <= &1`;; + +time REAL_SOS + `abs(x - z) <= e /\ abs(y - z) <= e /\ &0 <= u /\ &0 <= v /\ (u + v = &1) + ==> abs((u * x + v * y) - z) <= e`;; + +(* ------------------------------------------------------------------------- *) +(* One component of denominator in dodecahedral example. *) +(* ------------------------------------------------------------------------- *) + +time REAL_SOS + `&2 <= x /\ x <= &125841 / &50000 /\ + &2 <= y /\ y <= &125841 / &50000 /\ + &2 <= z /\ z <= &125841 / &50000 + ==> &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= &0`;; + +(* ------------------------------------------------------------------------- *) +(* Over a larger but simpler interval. *) +(* ------------------------------------------------------------------------- *) + +time REAL_SOS + `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4 + ==> &0 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;; + +(* ------------------------------------------------------------------------- *) +(* We can do 12. I think 12 is a sharp bound; see PP's certificate. *) +(* ------------------------------------------------------------------------- *) + +time REAL_SOS + `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4 + ==> &12 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;; + +(* ------------------------------------------------------------------------- *) +(* Gloptipoly example. *) +(* ------------------------------------------------------------------------- *) + +(*** This works but normalization takes minutes + +time REAL_SOS + `(x - y - &2 * x pow 4 = &0) /\ &0 <= x /\ x <= &2 /\ &0 <= y /\ y <= &3 + ==> y pow 2 - &7 * y - &12 * x + &17 >= &0`;; + + ***) + +(* ------------------------------------------------------------------------- *) +(* Inequality from sci.math (see "Leon-Sotelo, por favor"). *) +(* ------------------------------------------------------------------------- *) + +time REAL_SOS + `&0 <= x /\ &0 <= y /\ (x * y = &1) + ==> x + y <= x pow 2 + y pow 2`;; + +time REAL_SOS + `&0 <= x /\ &0 <= y /\ (x * y = &1) + ==> x * y * (x + y) <= x pow 2 + y pow 2`;; + +time REAL_SOS + `&0 <= x /\ &0 <= y ==> x * y * (x + y) pow 2 <= (x pow 2 + y pow 2) pow 2`;; + +(* ------------------------------------------------------------------------- *) +(* Some examples over integers and natural numbers. *) +(* ------------------------------------------------------------------------- *) + +time SOS_RULE `!m n. 2 * m + n = (n + m) + m`;; +time SOS_RULE `!n. ~(n = 0) ==> (0 MOD n = 0)`;; +time SOS_RULE `!m n. m < n ==> (m DIV n = 0)`;; +time SOS_RULE `!n:num. n <= n * n`;; +time SOS_RULE `!m n. n * (m DIV n) <= m`;; +time SOS_RULE `!n. ~(n = 0) ==> (0 DIV n = 0)`;; +time SOS_RULE `!m n p. ~(p = 0) /\ m <= n ==> m DIV p <= n DIV p`;; +time SOS_RULE `!a b n. ~(a = 0) ==> (n <= b DIV a <=> a * n <= b)`;; + +(* ------------------------------------------------------------------------- *) +(* This is particularly gratifying --- cf hideous manual proof in arith.ml *) +(* ------------------------------------------------------------------------- *) + +(*** This doesn't now seem to work as well as it did; what changed? + +time SOS_RULE + `!a b c d. ~(b = 0) /\ b * c < (a + 1) * d ==> c DIV d <= a DIV b`;; + + ***) + +(* ------------------------------------------------------------------------- *) +(* Key lemma for injectivity of Cantor-type pairing functions. *) +(* ------------------------------------------------------------------------- *) + +time SOS_RULE + `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) + ==> (x1 + y1 = x2 + y2)`;; + +time SOS_RULE + `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) /\ + (x1 + y1 = x2 + y2) + ==> (x1 = x2) /\ (y1 = y2)`;; + +time SOS_RULE + `!x1 y1 x2 y2. + (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 = + ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) + ==> (x1 + y1 = x2 + y2)`;; + +time SOS_RULE + `!x1 y1 x2 y2. + (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 = + ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) /\ + (x1 + y1 = x2 + y2) + ==> (x1 = x2) /\ (y1 = y2)`;; + +(* ------------------------------------------------------------------------- *) +(* Reciprocal multiplication (actually just ARITH_RULE does these). *) +(* ------------------------------------------------------------------------- *) + +time SOS_RULE `x <= 127 ==> ((86 * x) DIV 256 = x DIV 3)`;; + +time SOS_RULE `x < 2 EXP 16 ==> ((104858 * x) DIV (2 EXP 20) = x DIV 10)`;; + +(* ------------------------------------------------------------------------- *) +(* This is more impressive since it's really nonlinear. See REMAINDER_DECODE *) +(* ------------------------------------------------------------------------- *) + +time SOS_RULE `0 < m /\ m < n ==> ((m * ((n * x) DIV m + 1)) DIV n = x)`;; + +(* ------------------------------------------------------------------------- *) +(* Some conversion examples. *) +(* ------------------------------------------------------------------------- *) + +time SOS_CONV + `&2 * x pow 4 + &2 * x pow 3 * y - x pow 2 * y pow 2 + &5 * y pow 4`;; + +time SOS_CONV + `x pow 4 - (&2 * y * z + &1) * x pow 2 + + (y pow 2 * z pow 2 + &2 * y * z + &2)`;; + +time SOS_CONV `&4 * x pow 4 + + &4 * x pow 3 * y - &7 * x pow 2 * y pow 2 - &2 * x * y pow 3 + + &10 * y pow 4`;; + +time SOS_CONV `&4 * x pow 4 * y pow 6 + x pow 2 - x * y pow 2 + y pow 2`;; + +time SOS_CONV + `&4096 * (x pow 4 + x pow 2 + z pow 6 - &3 * x pow 2 * z pow 2) + &729`;; + +time SOS_CONV + `&120 * x pow 2 - &63 * x pow 4 + &10 * x pow 6 + + &30 * x * y - &120 * y pow 2 + &120 * y pow 4 + &31`;; + +time SOS_CONV + `&9 * x pow 2 * y pow 4 + &9 * x pow 2 * z pow 4 + &36 * x pow 2 * y pow 3 + + &36 * x pow 2 * y pow 2 - &48 * x * y * z pow 2 + &4 * y pow 4 + + &4 * z pow 4 - &16 * y pow 3 + &16 * y pow 2`;; + +time SOS_CONV + `(x pow 2 + y pow 2 + z pow 2) * + (x pow 4 * y pow 2 + x pow 2 * y pow 4 + + z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2)`;; + +time SOS_CONV + `x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3`;; + +(*** I think this will work, but normalization is slow + +time SOS_CONV + `&100 * (x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z) + &212`;; + + ***) + +time SOS_CONV + `&100 * ((&2 * x - &2) pow 2 + (x pow 3 - &8 * x - &2) pow 2) - &588`;; + +time SOS_CONV + `x pow 2 * (&120 - &63 * x pow 2 + &10 * x pow 4) + &30 * x * y + + &30 * y pow 2 * (&4 * y pow 2 - &4) + &31`;; + +(* ------------------------------------------------------------------------- *) +(* Example of basic rule. *) +(* ------------------------------------------------------------------------- *) + +time PURE_SOS + `!x. x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3 + >= &1 / &7`;; + +time PURE_SOS + `&0 <= &98 * x pow 12 + + -- &980 * x pow 10 + + &3038 * x pow 8 + + -- &2968 * x pow 6 + + &1022 * x pow 4 + + -- &84 * x pow 2 + + &2`;; + +time PURE_SOS + `!x. &0 <= &2 * x pow 14 + + -- &84 * x pow 12 + + &1022 * x pow 10 + + -- &2968 * x pow 8 + + &3038 * x pow 6 + + -- &980 * x pow 4 + + &98 * x pow 2`;; + +(* ------------------------------------------------------------------------- *) +(* From Zeng et al, JSC vol 37 (2004), p83-99. *) +(* All of them work nicely with pure SOS_CONV, except (maybe) the one noted. *) +(* ------------------------------------------------------------------------- *) + +PURE_SOS + `x pow 6 + y pow 6 + z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2 >= &0`;; + +PURE_SOS `x pow 4 + y pow 4 + z pow 4 + &1 - &4*x*y*z >= &0`;; + +PURE_SOS `x pow 4 + &2*x pow 2*z + x pow 2 - &2*x*y*z + &2*y pow 2*z pow 2 + +&2*y*z pow 2 + &2*z pow 2 - &2*x + &2* y*z + &1 >= &0`;; + +(**** This is harder. Interestingly, this fails the pure SOS test, it seems. + Yet only on rounding(!?) Poor Newton polytope optimization or something? + But REAL_SOS does finally converge on the second run at level 12! + +REAL_SOS +`x pow 4*y pow 4 - &2*x pow 5*y pow 3*z pow 2 + x pow 6*y pow 2*z pow 4 + &2*x +pow 2*y pow 3*z - &4* x pow 3*y pow 2*z pow 3 + &2*x pow 4*y*z pow 5 + z pow +2*y pow 2 - &2*z pow 4*y*x + z pow 6*x pow 2 >= &0`;; + + ****) + +PURE_SOS +`x pow 4 + &4*x pow 2*y pow 2 + &2*x*y*z pow 2 + &2*x*y*w pow 2 + y pow 4 + z +pow 4 + w pow 4 + &2*z pow 2*w pow 2 + &2*x pow 2*w + &2*y pow 2*w + &2*x*y + +&3*w pow 2 + &2*z pow 2 + &1 >= &0`;; + +PURE_SOS +`w pow 6 + &2*z pow 2*w pow 3 + x pow 4 + y pow 4 + z pow 4 + &2*x pow 2*w + +&2*x pow 2*z + &3*x pow 2 + w pow 2 + &2*z*w + z pow 2 + &2*z + &2*w + &1 >= +&0`;; + +*****) diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli new file mode 100644 index 00000000..e38caba0 --- /dev/null +++ b/plugins/micromega/sos.mli @@ -0,0 +1,36 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool + +val poly_neg : poly -> poly + +val poly_mul : poly -> poly -> poly + +val poly_pow : poly -> int -> poly + +val poly_const : Num.num -> poly + +val poly_of_term : term -> poly + +val term_of_poly : poly -> term + +val term_of_sos : positivstellensatz * (Num.num * poly) list -> + positivstellensatz + +val string_of_poly : poly -> string + +val real_positivnullstellensatz_general : bool -> int -> poly list -> + (poly * positivstellensatz) list -> + poly -> poly list * (positivstellensatz * (Num.num * poly) list) list + +val sumofsquares : poly -> Num.num * ( Num.num * poly) list diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml new file mode 100644 index 00000000..baf90d4d --- /dev/null +++ b/plugins/micromega/sos_lib.ml @@ -0,0 +1,621 @@ +(* ========================================================================= *) +(* - This code originates from John Harrison's HOL LIGHT 2.30 *) +(* (see file LICENSE.sos for license, copyright and disclaimer) *) +(* This code is the HOL LIGHT library code used by sos.ml *) +(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL *) +(* independent bits *) +(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *) +(* ========================================================================= *) +open Sos_types +open Num +open List + +let debugging = ref false;; + +(* ------------------------------------------------------------------------- *) +(* Comparisons that are reflexive on NaN and also short-circuiting. *) +(* ------------------------------------------------------------------------- *) + +let (=?) = fun x y -> Pervasives.compare x y = 0;; +let ( Pervasives.compare x y < 0;; +let (<=?) = fun x y -> Pervasives.compare x y <= 0;; +let (>?) = fun x y -> Pervasives.compare x y > 0;; +let (>=?) = fun x y -> Pervasives.compare x y >= 0;; + +(* ------------------------------------------------------------------------- *) +(* Combinators. *) +(* ------------------------------------------------------------------------- *) + +let (o) = fun f g x -> f(g x);; + +(* ------------------------------------------------------------------------- *) +(* Some useful functions on "num" type. *) +(* ------------------------------------------------------------------------- *) + + +let num_0 = Int 0 +and num_1 = Int 1 +and num_2 = Int 2 +and num_10 = Int 10;; + +let pow2 n = power_num num_2 (Int n);; +let pow10 n = power_num num_10 (Int n);; + +let numdom r = + let r' = Ratio.normalize_ratio (ratio_of_num r) in + num_of_big_int(Ratio.numerator_ratio r'), + num_of_big_int(Ratio.denominator_ratio r');; + +let numerator = (o) fst numdom +and denominator = (o) snd numdom;; + +let gcd_num n1 n2 = + num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));; + +let lcm_num x y = + if x =/ num_0 & y =/ num_0 then num_0 + else abs_num((x */ y) // gcd_num x y);; + + +(* ------------------------------------------------------------------------- *) +(* List basics. *) +(* ------------------------------------------------------------------------- *) + +let rec el n l = + if n = 0 then hd l else el (n - 1) (tl l);; + + +(* ------------------------------------------------------------------------- *) +(* Various versions of list iteration. *) +(* ------------------------------------------------------------------------- *) + +let rec itlist f l b = + match l with + [] -> b + | (h::t) -> f h (itlist f t b);; + +let rec end_itlist f l = + match l with + [] -> failwith "end_itlist" + | [x] -> x + | (h::t) -> f h (end_itlist f t);; + +let rec itlist2 f l1 l2 b = + match (l1,l2) with + ([],[]) -> b + | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b) + | _ -> failwith "itlist2";; + +(* ------------------------------------------------------------------------- *) +(* All pairs arising from applying a function over two lists. *) +(* ------------------------------------------------------------------------- *) + +let rec allpairs f l1 l2 = + match l1 with + h1::t1 -> itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) + | [] -> [];; + +(* ------------------------------------------------------------------------- *) +(* String operations (surely there is a better way...) *) +(* ------------------------------------------------------------------------- *) + +let implode l = itlist (^) l "";; + +let explode s = + let rec exap n l = + if n < 0 then l else + exap (n - 1) ((String.sub s n 1)::l) in + exap (String.length s - 1) [];; + + +(* ------------------------------------------------------------------------- *) +(* Attempting function or predicate applications. *) +(* ------------------------------------------------------------------------- *) + +let can f x = try (f x; true) with Failure _ -> false;; + + +(* ------------------------------------------------------------------------- *) +(* Repetition of a function. *) +(* ------------------------------------------------------------------------- *) + +let rec funpow n f x = + if n < 1 then x else funpow (n-1) f (f x);; + + + +(* ------------------------------------------------------------------------- *) +(* Replication and sequences. *) +(* ------------------------------------------------------------------------- *) + +let rec replicate x n = + if n < 1 then [] + else x::(replicate x (n - 1));; + +let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; + +(* ------------------------------------------------------------------------- *) +(* Various useful list operations. *) +(* ------------------------------------------------------------------------- *) + +let rec forall p l = + match l with + [] -> true + | h::t -> p(h) & forall p t;; + +let rec tryfind f l = + match l with + [] -> failwith "tryfind" + | (h::t) -> try f h with Failure _ -> tryfind f t;; + +let index x = + let rec ind n l = + match l with + [] -> failwith "index" + | (h::t) -> if x =? h then n else ind (n + 1) t in + ind 0;; + +(* ------------------------------------------------------------------------- *) +(* "Set" operations on lists. *) +(* ------------------------------------------------------------------------- *) + +let rec mem x lis = + match lis with + [] -> false + | (h::t) -> x =? h or mem x t;; + +let insert x l = + if mem x l then l else x::l;; + +let union l1 l2 = itlist insert l1 l2;; + +let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;; + +(* ------------------------------------------------------------------------- *) +(* Merging and bottom-up mergesort. *) +(* ------------------------------------------------------------------------- *) + +let rec merge ord l1 l2 = + match l1 with + [] -> l2 + | h1::t1 -> match l2 with + [] -> l1 + | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2) + else h2::(merge ord l1 t2);; + + +(* ------------------------------------------------------------------------- *) +(* Common measure predicates to use with "sort". *) +(* ------------------------------------------------------------------------- *) + +let increasing f x y = f x ? f y;; + +(* ------------------------------------------------------------------------- *) +(* Zipping, unzipping etc. *) +(* ------------------------------------------------------------------------- *) + +let rec zip l1 l2 = + match (l1,l2) with + ([],[]) -> [] + | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2) + | _ -> failwith "zip";; + +let rec unzip = + function [] -> [],[] + | ((a,b)::rest) -> let alist,blist = unzip rest in + (a::alist,b::blist);; + +(* ------------------------------------------------------------------------- *) +(* Iterating functions over lists. *) +(* ------------------------------------------------------------------------- *) + +let rec do_list f l = + match l with + [] -> () + | (h::t) -> (f h; do_list f t);; + +(* ------------------------------------------------------------------------- *) +(* Sorting. *) +(* ------------------------------------------------------------------------- *) + +let rec sort cmp lis = + match lis with + [] -> [] + | piv::rest -> + let r,l = partition (cmp piv) rest in + (sort cmp l) @ (piv::(sort cmp r));; + +(* ------------------------------------------------------------------------- *) +(* Removing adjacent (NB!) equal elements from list. *) +(* ------------------------------------------------------------------------- *) + +let rec uniq l = + match l with + x::(y::_ as t) -> let t' = uniq t in + if x =? y then t' else + if t'==t then l else x::t' + | _ -> l;; + +(* ------------------------------------------------------------------------- *) +(* Convert list into set by eliminating duplicates. *) +(* ------------------------------------------------------------------------- *) + +let setify s = uniq (sort (<=?) s);; + +(* ------------------------------------------------------------------------- *) +(* Polymorphic finite partial functions via Patricia trees. *) +(* *) +(* The point of this strange representation is that it is canonical (equal *) +(* functions have the same encoding) yet reasonably efficient on average. *) +(* *) +(* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *) +(* ------------------------------------------------------------------------- *) + +type ('a,'b)func = + Empty + | Leaf of int * ('a*'b)list + | Branch of int * int * ('a,'b)func * ('a,'b)func;; + +(* ------------------------------------------------------------------------- *) +(* Undefined function. *) +(* ------------------------------------------------------------------------- *) + +let undefined = Empty;; + +(* ------------------------------------------------------------------------- *) +(* In case of equality comparison worries, better use this. *) +(* ------------------------------------------------------------------------- *) + +let is_undefined f = + match f with + Empty -> true + | _ -> false;; + +(* ------------------------------------------------------------------------- *) +(* Operation analagous to "map" for lists. *) +(* ------------------------------------------------------------------------- *) + +let mapf = + let rec map_list f l = + match l with + [] -> [] + | (x,y)::t -> (x,f(y))::(map_list f t) in + let rec mapf f t = + match t with + Empty -> Empty + | Leaf(h,l) -> Leaf(h,map_list f l) + | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in + mapf;; + +(* ------------------------------------------------------------------------- *) +(* Operations analogous to "fold" for lists. *) +(* ------------------------------------------------------------------------- *) + +let foldl = + let rec foldl_list f a l = + match l with + [] -> a + | (x,y)::t -> foldl_list f (f a x y) t in + let rec foldl f a t = + match t with + Empty -> a + | Leaf(h,l) -> foldl_list f a l + | Branch(p,b,l,r) -> foldl f (foldl f a l) r in + foldl;; + +let foldr = + let rec foldr_list f l a = + match l with + [] -> a + | (x,y)::t -> f x y (foldr_list f t a) in + let rec foldr f t a = + match t with + Empty -> a + | Leaf(h,l) -> foldr_list f l a + | Branch(p,b,l,r) -> foldr f l (foldr f r a) in + foldr;; + +(* ------------------------------------------------------------------------- *) +(* Redefinition and combination. *) +(* ------------------------------------------------------------------------- *) + +let (|->),combine = + let ldb x y = let z = x lxor y in z land (-z) in + let newbranch p1 t1 p2 t2 = + let b = ldb p1 p2 in + let p = p1 land (b - 1) in + if p1 land b = 0 then Branch(p,b,t1,t2) + else Branch(p,b,t2,t1) in + let rec define_list (x,y as xy) l = + match l with + (a,b as ab)::t -> + if x =? a then xy::t + else if x [xy] + and combine_list op z l1 l2 = + match (l1,l2) with + [],_ -> l2 + | _,[] -> l1 + | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) -> + if x1 ) x y = + let k = Hashtbl.hash x in + let rec upd t = + match t with + Empty -> Leaf (k,[x,y]) + | Leaf(h,l) -> + if h = k then Leaf(h,define_list (x,y) l) + else newbranch h t k (Leaf(k,[x,y])) + | Branch(p,b,l,r) -> + if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y])) + else if k land b = 0 then Branch(p,b,upd l,r) + else Branch(p,b,l,upd r) in + upd in + let rec combine op z t1 t2 = + match (t1,t2) with + Empty,_ -> t2 + | _,Empty -> t1 + | Leaf(h1,l1),Leaf(h2,l2) -> + if h1 = h2 then + let l = combine_list op z l1 l2 in + if l = [] then Empty else Leaf(h1,l) + else newbranch h1 t1 h2 t2 + | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) | + (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) -> + if k land (b - 1) = p then + if k land b = 0 then + let l' = combine op z lf l in + if is_undefined l' then r else Branch(p,b,l',r) + else + let r' = combine op z lf r in + if is_undefined r' then l else Branch(p,b,l,r') + else + newbranch k lf p br + | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) -> + if b1 < b2 then + if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2 + else if p2 land b1 = 0 then + let l = combine op z l1 t2 in + if is_undefined l then r1 else Branch(p1,b1,l,r1) + else + let r = combine op z r1 t2 in + if is_undefined r then l1 else Branch(p1,b1,l1,r) + else if b2 < b1 then + if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2 + else if p1 land b2 = 0 then + let l = combine op z t1 l2 in + if is_undefined l then r2 else Branch(p2,b2,l,r2) + else + let r = combine op z t1 r2 in + if is_undefined r then l2 else Branch(p2,b2,l2,r) + else if p1 = p2 then + let l = combine op z l1 l2 and r = combine op z r1 r2 in + if is_undefined l then r + else if is_undefined r then l else Branch(p1,b1,l,r) + else + newbranch p1 t1 p2 t2 in + (|->),combine;; + +(* ------------------------------------------------------------------------- *) +(* Special case of point function. *) +(* ------------------------------------------------------------------------- *) + +let (|=>) = fun x y -> (x |-> y) undefined;; + + +(* ------------------------------------------------------------------------- *) +(* Grab an arbitrary element. *) +(* ------------------------------------------------------------------------- *) + +let rec choose t = + match t with + Empty -> failwith "choose: completely undefined function" + | Leaf(h,l) -> hd l + | Branch(b,p,t1,t2) -> choose t1;; + +(* ------------------------------------------------------------------------- *) +(* Application. *) +(* ------------------------------------------------------------------------- *) + +let applyd = + let rec apply_listd l d x = + match l with + (a,b)::t -> if x =? a then b + else if x >? a then apply_listd t d x else d x + | [] -> d x in + fun f d x -> + let k = Hashtbl.hash x in + let rec look t = + match t with + Leaf(h,l) when h = k -> apply_listd l d x + | Branch(p,b,l,r) -> look (if k land b = 0 then l else r) + | _ -> d x in + look f;; + +let apply f = applyd f (fun x -> failwith "apply");; + +let tryapplyd f a d = applyd f (fun x -> d) a;; + +let defined f x = try apply f x; true with Failure _ -> false;; + +(* ------------------------------------------------------------------------- *) +(* Undefinition. *) +(* ------------------------------------------------------------------------- *) + +let undefine = + let rec undefine_list x l = + match l with + (a,b as ab)::t -> + if x =? a then t + else if x [] in + fun x -> + let k = Hashtbl.hash x in + let rec und t = + match t with + Leaf(h,l) when h = k -> + let l' = undefine_list x l in + if l' == l then t + else if l' = [] then Empty + else Leaf(h,l') + | Branch(p,b,l,r) when k land (b - 1) = p -> + if k land b = 0 then + let l' = und l in + if l' == l then t + else if is_undefined l' then r + else Branch(p,b,l',r) + else + let r' = und r in + if r' == r then t + else if is_undefined r' then l + else Branch(p,b,l,r') + | _ -> t in + und;; + + +(* ------------------------------------------------------------------------- *) +(* Mapping to sorted-list representation of the graph, domain and range. *) +(* ------------------------------------------------------------------------- *) + +let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);; + +let dom f = setify(foldl (fun a x y -> x::a) [] f);; + +let ran f = setify(foldl (fun a x y -> y::a) [] f);; + +(* ------------------------------------------------------------------------- *) +(* More parser basics. *) +(* ------------------------------------------------------------------------- *) + +exception Noparse;; + + +let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = + let charcode s = Char.code(String.get s 0) in + let spaces = " \t\n\r" + and separators = ",;" + and brackets = "()[]{}" + and symbs = "\\!@#$%^&*-+|\\<=>/?~.:" + and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ" + and nums = "0123456789" in + let allchars = spaces^separators^brackets^symbs^alphas^nums in + let csetsize = itlist ((o) max charcode) (explode allchars) 256 in + let ctable = Array.make csetsize 0 in + do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces); + do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators); + do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets); + do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs); + do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas); + do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums); + let isspace c = Array.get ctable (charcode c) = 1 + and issep c = Array.get ctable (charcode c) = 2 + and isbra c = Array.get ctable (charcode c) = 4 + and issymb c = Array.get ctable (charcode c) = 8 + and isalpha c = Array.get ctable (charcode c) = 16 + and isnum c = Array.get ctable (charcode c) = 32 + and isalnum c = Array.get ctable (charcode c) >= 16 in + isspace,issep,isbra,issymb,isalpha,isnum,isalnum;; + +let (||) parser1 parser2 input = + try parser1 input + with Noparse -> parser2 input;; + +let (++) parser1 parser2 input = + let result1,rest1 = parser1 input in + let result2,rest2 = parser2 rest1 in + (result1,result2),rest2;; + +let rec many prs input = + try let result,next = prs input in + let results,rest = many prs next in + (result::results),rest + with Noparse -> [],input;; + +let (>>) prs treatment input = + let result,rest = prs input in + treatment(result),rest;; + +let fix err prs input = + try prs input + with Noparse -> failwith (err ^ " expected");; + +let rec listof prs sep err = + prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);; + +let possibly prs input = + try let x,rest = prs input in [x],rest + with Noparse -> [],input;; + +let some p = + function + [] -> raise Noparse + | (h::t) -> if p h then (h,t) else raise Noparse;; + +let a tok = some (fun item -> item = tok);; + +let rec atleast n prs i = + (if n <= 0 then many prs + else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;; + +let finished input = + if input = [] then 0,input else failwith "Unparsed input";; + +(* ------------------------------------------------------------------------- *) + +let temp_path = ref Filename.temp_dir_name;; + +(* ------------------------------------------------------------------------- *) +(* Convenient conversion between files and (lists of) strings. *) +(* ------------------------------------------------------------------------- *) + +let strings_of_file filename = + let fd = try Pervasives.open_in filename + with Sys_error _ -> + failwith("strings_of_file: can't open "^filename) in + let rec suck_lines acc = + try let l = Pervasives.input_line fd in + suck_lines (l::acc) + with End_of_file -> rev acc in + let data = suck_lines [] in + (Pervasives.close_in fd; data);; + +let string_of_file filename = + end_itlist (fun s t -> s^"\n"^t) (strings_of_file filename);; + +let file_of_string filename s = + let fd = Pervasives.open_out filename in + output_string fd s; close_out fd;; + + +(* ------------------------------------------------------------------------- *) +(* Iterative deepening. *) +(* ------------------------------------------------------------------------- *) + +let rec deepen f n = + try (*print_string "Searching with depth limit "; + print_int n; print_newline();*) f n + with Failure _ -> deepen f (n + 1);; + +exception TooDeep + +let deepen_until limit f n = + match compare limit 0 with + | 0 -> raise TooDeep + | -1 -> deepen f n + | _ -> + let rec d_until f n = + try(* if !debugging + then (print_string "Searching with depth limit "; + print_int n; print_newline()) ;*) f n + with Failure x -> + (*if !debugging then (Printf.printf "solver error : %s\n" x) ; *) + if n = limit then raise TooDeep else d_until f (n + 1) in + d_until f n diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml new file mode 100644 index 00000000..fe481ecc --- /dev/null +++ b/plugins/micromega/sos_types.ml @@ -0,0 +1,68 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* output_string o "0" + | Const n -> output_string o (string_of_num n) + | Var n -> Printf.fprintf o "v%s" n + | Inv t -> Printf.fprintf o "1/(%a)" output_term t + | Opp t -> Printf.fprintf o "- (%a)" output_term t + | Add(t1,t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2 + | Sub(t1,t2) -> Printf.fprintf o "(%a)-(%a)" output_term t1 output_term t2 + | Mul(t1,t2) -> Printf.fprintf o "(%a)*(%a)" output_term t1 output_term t2 + | Div(t1,t2) -> Printf.fprintf o "(%a)/(%a)" output_term t1 output_term t2 + | Pow(t1,i) -> Printf.fprintf o "(%a)^(%i)" output_term t1 i +(* ------------------------------------------------------------------------- *) +(* Data structure for Positivstellensatz refutations. *) +(* ------------------------------------------------------------------------- *) + +type positivstellensatz = + Axiom_eq of int + | Axiom_le of int + | Axiom_lt of int + | Rational_eq of num + | Rational_le of num + | Rational_lt of num + | Square of term + | Monoid of int list + | Eqmul of term * positivstellensatz + | Sum of positivstellensatz * positivstellensatz + | Product of positivstellensatz * positivstellensatz;; + + +let rec output_psatz o = function + | Axiom_eq i -> Printf.fprintf o "Aeq(%i)" i + | Axiom_le i -> Printf.fprintf o "Ale(%i)" i + | Axiom_lt i -> Printf.fprintf o "Alt(%i)" i + | Rational_eq n -> Printf.fprintf o "eq(%s)" (string_of_num n) + | Rational_le n -> Printf.fprintf o "le(%s)" (string_of_num n) + | Rational_lt n -> Printf.fprintf o "lt(%s)" (string_of_num n) + | Square t -> Printf.fprintf o "(%a)^2" output_term t + | Monoid l -> Printf.fprintf o "monoid" + | Eqmul (t,ps) -> Printf.fprintf o "%a * %a" output_term t output_psatz ps + | Sum (t1,t2) -> Printf.fprintf o "%a + %a" output_psatz t1 output_psatz t2 + | Product (t1,t2) -> Printf.fprintf o "%a * %a" output_psatz t1 output_psatz t2 diff --git a/plugins/micromega/vo.itarget b/plugins/micromega/vo.itarget new file mode 100644 index 00000000..30201308 --- /dev/null +++ b/plugins/micromega/vo.itarget @@ -0,0 +1,13 @@ +CheckerMaker.vo +EnvRing.vo +Env.vo +OrderedRing.vo +Psatz.vo +QMicromega.vo +Refl.vo +RingMicromega.vo +RMicromega.vo +Tauto.vo +VarMap.vo +ZCoeff.vo +ZMicromega.vo diff --git a/plugins/nsatz/NsatzR.v b/plugins/nsatz/NsatzR.v new file mode 100644 index 00000000..c68c9584 --- /dev/null +++ b/plugins/nsatz/NsatzR.v @@ -0,0 +1,407 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* x = y. +intros x y H; replace x with ((x - y) + y); + [rewrite H | idtac]; ring. +Qed. + +Lemma psos_r1: forall x y, x = y -> x - y = 0. +intros x y H; rewrite H; ring. +Qed. + +Lemma nsatzR_not1: forall x y:R, x<>y -> exists z:R, z*(x-y)-1=0. +intros. +exists (1/(x-y)). +field. +unfold not. +unfold not in H. +intros. +apply H. +replace x with ((x-y)+y). +rewrite H0. +ring. +ring. +Qed. + +Lemma nsatzR_not1_0: forall x:R, x<>0 -> exists z:R, z*x-1=0. +intros. +exists (1/(x)). +field. +auto. +Qed. + + +Ltac equalities_to_goal := + lazymatch goal with + | H: (@eq R ?x 0) |- _ => try revert H + | H: (@eq R 0 ?x) |- _ => + try generalize (sym_equal H); clear H + | H: (@eq R ?x ?y) |- _ => + try generalize (psos_r1 _ _ H); clear H + end. + +Lemma nsatzR_not2: 1<>0. +auto with *. +Qed. + +Lemma nsatzR_diff: forall x y:R, x<>y -> x-y<>0. +intros. +intro; apply H. +replace x with (x-y+y) by ring. +rewrite H0; ring. +Qed. + +(* Removes x<>0 from hypothesis *) +Ltac nsatzR_not_hyp:= + match goal with + | H: ?x<>?y |- _ => + match y with + |0 => + let H1:=fresh "Hnsatz" in + let y:=fresh "x" in + destruct (@nsatzR_not1_0 _ H) as (y,H1); clear H + |_ => generalize (@nsatzR_diff _ _ H); clear H; intro + end + end. + +Ltac nsatzR_not_goal := + match goal with + | |- ?x<>?y :> R => red; intro; apply nsatzR_not2 + | |- False => apply nsatzR_not2 + end. + +Ltac nsatzR_begin := + intros; + repeat nsatzR_not_hyp; + try nsatzR_not_goal; + try apply psos_r1b; + repeat equalities_to_goal. + +(* code de Benjamin *) + +Definition PolZ := Pol Z. +Definition PEZ := PExpr Z. + +Definition P0Z : PolZ := @P0 Z 0%Z. + +Definition PolZadd : PolZ -> PolZ -> PolZ := + @Padd Z 0%Z Zplus Zeq_bool. + +Definition PolZmul : PolZ -> PolZ -> PolZ := + @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool. + +Definition PolZeq := @Peq Z Zeq_bool. + +Definition norm := + @norm_aux Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool. + +Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := + match la, lp with + | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp) + | _, _ => P0Z + end. + +Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := + match lla with + | List.nil => lp + | la::lla => compute_list lla ((mult_l la lp)::lp) + end. + +Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := + let (lla, lq) := certif in + let lp := List.map norm lpe in + PolZeq (norm qe) (mult_l lq (compute_list lla lp)). + + +(* Correction *) +Definition PhiR : list R -> PolZ -> R := + (Pphi 0 Rplus Rmult (gen_phiZ 0 1 Rplus Rmult Ropp)). + +Definition PEevalR : list R -> PEZ -> R := + PEeval 0 Rplus Rmult Rminus Ropp (gen_phiZ 0 1 Rplus Rmult Ropp) + Nnat.nat_of_N pow. + +Lemma P0Z_correct : forall l, PhiR l P0Z = 0. +Proof. trivial. Qed. + + +Lemma PolZadd_correct : forall P' P l, + PhiR l (PolZadd P P') = (PhiR l P + PhiR l P'). +Proof. + refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (F_R Rfield)) + (gen_phiZ_morph Rset Rext (F_R Rfield))). +Qed. + +Lemma PolZmul_correct : forall P P' l, + PhiR l (PolZmul P P') = (PhiR l P * PhiR l P'). +Proof. + refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext (F_R Rfield)) + (gen_phiZ_morph Rset Rext (F_R Rfield))). +Qed. + +Lemma norm_correct : + forall (l : list R) (pe : PEZ), PEevalR l pe = PhiR l (norm pe). +Proof. + intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext (F_R Rfield)) + (gen_phiZ_morph Rset Rext (F_R Rfield)) R_power_theory) with (lmp:= List.nil). + compute;trivial. +Qed. + +Lemma PolZeq_correct : forall P P' l, + PolZeq P P' = true -> + PhiR l P = PhiR l P'. +Proof. + intros;apply + (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (F_R Rfield)));trivial. +Qed. + +Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := + match l with + | List.nil => True + | a::l => Interp a = 0 /\ Cond0 A Interp l + end. + +Lemma mult_l_correct : forall l la lp, + Cond0 PolZ (PhiR l) lp -> + PhiR l (mult_l la lp) = 0. +Proof. + induction la;simpl;intros;trivial. + destruct lp;trivial. + simpl in H;destruct H. + rewrite PolZadd_correct, PolZmul_correct, H, IHla;[ring | trivial]. +Qed. + +Lemma compute_list_correct : forall l lla lp, + Cond0 PolZ (PhiR l) lp -> + Cond0 PolZ (PhiR l) (compute_list lla lp). +Proof. + induction lla;simpl;intros;trivial. + apply IHlla;simpl;split;trivial. + apply mult_l_correct;trivial. +Qed. + +Lemma check_correct : + forall l lpe qe certif, + check lpe qe certif = true -> + Cond0 PEZ (PEevalR l) lpe -> + PEevalR l qe = 0. +Proof. + unfold check;intros l lpe qe (lla, lq) H2 H1. + apply PolZeq_correct with (l:=l) in H2. + rewrite norm_correct, H2. + apply mult_l_correct. + apply compute_list_correct. + clear H2 lq lla qe;induction lpe;simpl;trivial. + simpl in H1;destruct H1. + rewrite <- norm_correct;auto. +Qed. + +(* fin du code de Benjamin *) + +Lemma nsatzR_l3:forall c p r, ~c=0 -> c*p^r=0 -> p=0. +intros. +elim (Rmult_integral _ _ H0);intros. + absurd (c=0);auto. + + clear H0; induction r; simpl in *. + contradict H1; discrR. + + elim (Rmult_integral _ _ H1); auto. +Qed. + + +Ltac generalise_eq_hyps:= + repeat + (match goal with + |h : (?p = ?q)|- _ => revert h + end). + +Ltac lpol_goal t := + match t with + | ?a = 0 -> ?b => + let r:= lpol_goal b in + constr:(a::r) + | ?a = 0 => constr:(a::nil) + end. + +Fixpoint IPR p {struct p}: R := + match p with + xH => 1 + | xO xH => 1 + 1 + | xO p1 => 2 * (IPR p1) + | xI xH => 1 + (1 + 1) + | xI p1 => 1 + 2 * (IPR p1) + end. + +Definition IZR1 z := + match z with Z0 => 0 + | Zpos p => IPR p + | Zneg p => -(IPR p) + end. + +Fixpoint interpret3 t fv {struct t}: R := + match t with + | (PEadd t1 t2) => + let v1 := interpret3 t1 fv in + let v2 := interpret3 t2 fv in (v1 + v2) + | (PEmul t1 t2) => + let v1 := interpret3 t1 fv in + let v2 := interpret3 t2 fv in (v1 * v2) + | (PEsub t1 t2) => + let v1 := interpret3 t1 fv in + let v2 := interpret3 t2 fv in (v1 - v2) + | (PEopp t1) => + let v1 := interpret3 t1 fv in (-v1) + | (PEpow t1 t2) => + let v1 := interpret3 t1 fv in v1 ^(Nnat.nat_of_N t2) + | (PEc t1) => (IZR1 t1) + | (PEX n) => List.nth (pred (nat_of_P n)) fv 0 + end. + +(* lp est incluse dans fv. La met en tete. *) + +Ltac parametres_en_tete fv lp := + match fv with + | (@nil _) => lp + | (@cons _ ?x ?fv1) => + let res := AddFvTail x lp in + parametres_en_tete fv1 res + end. + +Ltac append1 a l := + match l with + | (@nil _) => constr:(cons a l) + | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l') + end. + +Ltac rev l := + match l with + |(@nil _) => l + | (cons ?x ?l) => let l' := rev l in append1 x l' + end. + + +Ltac nsatz_call_n info nparam p rr lp kont := + nsatz_compute (PEc info :: PEc nparam :: PEpow p rr :: lp); + match goal with + | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => + intros _; + set (lci:=lci0); + set (lq:=lq0); + kont c rr lq lci + end. + +Ltac nsatz_call radicalmax info nparam p lp kont := + let rec try_n n := + lazymatch n with + | 0%N => fail + | _ => +(* idtac "Trying power: " n;*) + (let r := eval compute in (Nminus radicalmax (Npred n)) in + nsatz_call_n info nparam p r lp kont) || + let n' := eval compute in (Npred n) in try_n n' + end in + try_n radicalmax. + + +Ltac nsatzR_gen radicalmax info lparam lvar n RNG lH _rl := + get_Pre RNG (); + let mkFV := Ring_tac.get_RingFV RNG in + let mkPol := Ring_tac.get_RingMeta RNG in + generalise_eq_hyps; + let t := Get_goal in + let lpol := lpol_goal t in + intros; + let fv := + match lvar with + | nil => + let fv1 := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in + let fv1 := list_fold_right mkFV fv1 lpol in + rev fv1 + (* heuristique: les dernieres variables auront le poid le plus fort *) + | _ => lvar + end in + check_fv fv; + (*idtac "variables:";idtac fv;*) + let nparam := eval compute in (Z_of_nat (List.length lparam)) in + let fv := parametres_en_tete fv lparam in + idtac "variables:"; idtac fv; + (* idtac "nparam:"; idtac nparam;*) + let lpol := list_fold_right + ltac:(fun p l => let p' := mkPol p fv in constr:(p'::l)) + (@nil (PExpr Z)) + lpol in + let lpol := eval compute in (List.rev lpol) in + (*idtac lpol;*) + let SplitPolyList kont := + match lpol with + | ?p2::?lp2 => kont p2 lp2 + | _ => idtac "polynomial not in the ideal" + end in + SplitPolyList ltac:(fun p lp => + set (p21:=p) ; + set (lp21:=lp); + nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => + set (q := PEmul c (PEpow p21 r)); + let Hg := fresh "Hg" in + assert (Hg:check lp21 q (lci,lq) = true); + [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" + | let Hg2 := fresh "Hg" in + assert (Hg2: interpret3 q fv = 0); + [ simpl; apply (@check_correct fv lp21 q (lci,lq) Hg); simpl; + repeat (split;[assumption|idtac]); exact I + | simpl in Hg2; simpl; + apply nsatzR_l3 with (interpret3 c fv) (Nnat.nat_of_N r);simpl; + [ discrR || idtac "could not prove discrimination result" + | exact Hg2] + ] + ])). + +Ltac nsatzRpv radicalmax info lparam lvar:= + nsatzR_begin; + intros; + let G := Get_goal in + ring_lookup + (PackRing ltac:(nsatzR_gen radicalmax info lparam lvar ring_subst_niter)) + [] G. + +Ltac nsatzR := nsatzRpv 6%N 1%Z (@nil R) (@nil R). +Ltac nsatzRradical radicalmax := nsatzRpv radicalmax 1%Z (@nil R) (@nil R). +Ltac nsatzRparameters lparam := nsatzRpv 6%N 1%Z lparam (@nil R). + +Tactic Notation "nsatz" := nsatzR. +Tactic Notation "nsatz" "with" "lexico" := + nsatzRpv 6%N 2%Z (@nil R) (@nil R). +Tactic Notation "nsatz" "with" "lexico" "sugar":= + nsatzRpv 6%N 3%Z (@nil R) (@nil R). +Tactic Notation "nsatz" "without" "sugar":= + nsatzRpv 6%N 0%Z (@nil R) (@nil R). + + diff --git a/plugins/nsatz/NsatzZ.v b/plugins/nsatz/NsatzZ.v new file mode 100644 index 00000000..a65efac2 --- /dev/null +++ b/plugins/nsatz/NsatzZ.v @@ -0,0 +1,73 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* IZR x = IZR y. +Proof IZR_eq. (* or f_equal ... *) + +Lemma nsatzZconclR: forall x y:Z, IZR x = IZR y -> x = y. +Proof eq_IZR. + +Lemma nsatzZhypnotR: forall x y:Z, x<>y -> IZR x <> IZR y. +Proof IZR_neq. + +Lemma nsatzZconclnotR: forall x y:Z, IZR x <> IZR y -> x <> y. +Proof. +intros x y H. contradict H. f_equal. assumption. +Qed. + +Ltac nsatzZtoR1 := + repeat + (match goal with + | H:(@eq Z ?x ?y) |- _ => + generalize (@nsatzZhypR _ _ H); clear H; intro H + | |- (@eq Z ?x ?y) => apply nsatzZconclR + | H:not (@eq Z ?x ?y) |- _ => + generalize (@nsatzZhypnotR _ _ H); clear H; intro H + | |- not (@eq Z ?x ?y) => apply nsatzZconclnotR + end). + +Lemma nsatzZR1: forall x y:Z, IZR(x+y) = (IZR x + IZR y)%R. +Proof plus_IZR. + +Lemma nsatzZR2: forall x y:Z, IZR(x*y) = (IZR x * IZR y)%R. +Proof mult_IZR. + +Lemma nsatzZR3: forall x y:Z, IZR(x-y) = (IZR x - IZR y)%R. +Proof. +intros; symmetry. apply Z_R_minus. +Qed. + +Lemma nsatzZR4: forall (x:Z) p, IZR(x ^ Zpos p) = (IZR x ^ nat_of_P p)%R. +Proof. +intros. rewrite pow_IZR. +do 2 f_equal. +apply Zpos_eq_Z_of_nat_o_nat_of_P. +Qed. + +Ltac nsatzZtoR2:= + repeat + (rewrite nsatzZR1 in * || + rewrite nsatzZR2 in * || + rewrite nsatzZR3 in * || + rewrite nsatzZR4 in *). + +Ltac nsatzZ_begin := + intros; + nsatzZtoR1; + nsatzZtoR2; + simpl in *. + (*cbv beta iota zeta delta [nat_of_P Pmult_nat plus mult] in *.*) + +Ltac nsatzZ := + nsatzZ_begin; (*idtac "nsatzZ_begin;";*) + nsatzR. diff --git a/plugins/nsatz/Nsatz_domain.v b/plugins/nsatz/Nsatz_domain.v new file mode 100644 index 00000000..11f905f9 --- /dev/null +++ b/plugins/nsatz/Nsatz_domain.v @@ -0,0 +1,558 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A -> A}. +Notation "x + y" := (addition x y). +Class Multiplication (A : Type) := {multiplication : A -> A -> A}. +Notation "x * y" := (multiplication x y). +Class Subtraction (A : Type) := {subtraction : A -> A -> A}. +Notation "x - y" := (subtraction x y). +Class Opposite (A : Type) := {opposite : A -> A}. +Notation "- x" := (opposite x). + +Class Ring (R:Type) := { + ring0: R; ring1: R; + ring_plus: R->R->R; ring_mult: R->R->R; + ring_sub: R->R->R; ring_opp: R->R; + ring_ring: + ring_theory ring0 ring1 ring_plus ring_mult ring_sub + ring_opp (@eq R)}. + +Class Domain (R : Type) := { + domain_ring:> Ring R; + domain_axiom_product: + forall x y, ring_mult x y = ring0 -> x = ring0 \/ y = ring0; + domain_axiom_one_zero: ring1 <> ring0}. + +Ltac ring2 := simpl; ring. + +Section domain. + +Variable R: Type. +Variable Rd: Domain R. +Add Ring Rr: (@ring_ring R (@domain_ring R Rd)). + +Instance zero_ring : Zero R := {zero := ring0}. +Instance one_ring : One R := {one := ring1}. +Instance addition_ring : Addition R := {addition x y := ring_plus x y}. +Instance multiplication_ring : Multiplication R := {multiplication x y := ring_mult x y}. +Instance subtraction_ring : Subtraction R := {subtraction x y := ring_sub x y}. +Instance opposite_ring : Opposite R := {opposite x := ring_opp x}. + +Lemma psos_r1b: forall x y:R, x - y = 0 -> x = y. +intros x y H; replace x with ((x - y) + y); + [rewrite H | idtac]; ring2. +Qed. + +Lemma psos_r1: forall x y, x = y -> x - y = 0. +intros x y H; rewrite H; ring2. +Qed. + + +Lemma nsatzR_diff: forall x y:R, x<>y -> x - y<>0. +intros. +intro; apply H. +replace x with ((x - y) + y) by ring2. +rewrite H0; ring2. +Qed. + +(* code de Benjamin *) +Require Import ZArith. + +Definition PolZ := Pol Z. +Definition PEZ := PExpr Z. + +Definition P0Z : PolZ := @P0 Z 0%Z. + +Definition PolZadd : PolZ -> PolZ -> PolZ := + @Padd Z 0%Z Zplus Zeq_bool. + +Definition PolZmul : PolZ -> PolZ -> PolZ := + @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool. + +Definition PolZeq := @Peq Z Zeq_bool. + +Definition norm := + @norm_aux Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool. + +Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := + match la, lp with + | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp) + | _, _ => P0Z + end. + +Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := + match lla with + | List.nil => lp + | la::lla => compute_list lla ((mult_l la lp)::lp) + end. + +Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := + let (lla, lq) := certif in + let lp := List.map norm lpe in + PolZeq (norm qe) (mult_l lq (compute_list lla lp)). + + +(* Correction *) +Definition PhiR : list R -> PolZ -> R := + (Pphi 0 ring_plus ring_mult (gen_phiZ 0 1 ring_plus ring_mult ring_opp)). + +Definition pow (r : R) (n : nat) := pow_N 1 ring_mult r (Nnat.N_of_nat n). + +Definition PEevalR : list R -> PEZ -> R := + PEeval 0 ring_plus ring_mult ring_sub ring_opp + (gen_phiZ 0 1 ring_plus ring_mult ring_opp) + Nnat.nat_of_N pow. + +Lemma P0Z_correct : forall l, PhiR l P0Z = 0. +Proof. trivial. Qed. + +Lemma Rext: ring_eq_ext ring_plus ring_mult ring_opp eq. +apply mk_reqe. intros. rewrite H; rewrite H0; trivial. + intros. rewrite H; rewrite H0; trivial. +intros. rewrite H; trivial. Qed. + +Lemma Rset : Setoid_Theory R eq. +apply Eqsth. +Qed. + +Lemma PolZadd_correct : forall P' P l, + PhiR l (PolZadd P P') = ((PhiR l P) + (PhiR l P')). +Proof. + refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd))) + (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))). +Qed. + +Lemma PolZmul_correct : forall P P' l, + PhiR l (PolZmul P P') = ((PhiR l P) * (PhiR l P')). +Proof. + refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd))) + (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))). +Qed. + +Lemma R_power_theory + : power_theory 1 ring_mult eq Nnat.nat_of_N pow. +apply mkpow_th. unfold pow. intros. rewrite Nnat.N_of_nat_of_N. trivial. Qed. + +Lemma norm_correct : + forall (l : list R) (pe : PEZ), PEevalR l pe = PhiR l (norm pe). +Proof. + intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd))) + (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))) R_power_theory) + with (lmp:= List.nil). + compute;trivial. +Qed. + +Lemma PolZeq_correct : forall P P' l, + PolZeq P P' = true -> + PhiR l P = PhiR l P'. +Proof. + intros;apply + (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))));trivial. +Qed. + +Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := + match l with + | List.nil => True + | a::l => Interp a = 0 /\ Cond0 A Interp l + end. + +Lemma mult_l_correct : forall l la lp, + Cond0 PolZ (PhiR l) lp -> + PhiR l (mult_l la lp) = 0. +Proof. + induction la;simpl;intros;trivial. + destruct lp;trivial. + simpl in H;destruct H. + rewrite PolZadd_correct, PolZmul_correct, H, IHla;[ring2 | trivial]. +Qed. + +Lemma compute_list_correct : forall l lla lp, + Cond0 PolZ (PhiR l) lp -> + Cond0 PolZ (PhiR l) (compute_list lla lp). +Proof. + induction lla;simpl;intros;trivial. + apply IHlla;simpl;split;trivial. + apply mult_l_correct;trivial. +Qed. + +Lemma check_correct : + forall l lpe qe certif, + check lpe qe certif = true -> + Cond0 PEZ (PEevalR l) lpe -> + PEevalR l qe = 0. +Proof. + unfold check;intros l lpe qe (lla, lq) H2 H1. + apply PolZeq_correct with (l:=l) in H2. + rewrite norm_correct, H2. + apply mult_l_correct. + apply compute_list_correct. + clear H2 lq lla qe;induction lpe;simpl;trivial. + simpl in H1;destruct H1. + rewrite <- norm_correct;auto. +Qed. + +(* fin du code de Benjamin *) + +Lemma pow_not_zero: forall p n, pow p n = 0 -> p = 0. +induction n. unfold pow; simpl. intros. absurd (1 = 0). +simpl. apply domain_axiom_one_zero. + trivial. replace (pow p (S n)) with (p * (pow p n)). intros. +case (@domain_axiom_product _ _ _ _ H). trivial. trivial. +unfold pow; simpl. +clear IHn. induction n; try ring2. simpl. + rewrite pow_pos_Psucc. trivial. exact Rset. + intros. rewrite H; rewrite H0; trivial. + intros. ring2. intros. ring2. Qed. + +Lemma Rdomain_pow: forall c p r, ~c= 0 -> c * (pow p r)= 0 -> p = ring0. +intros. case (@domain_axiom_product _ _ _ _ H0). intros; absurd (c = 0); auto. +intros. apply pow_not_zero with r. trivial. Qed. + +Definition R2:= 1 + 1. + +Fixpoint IPR p {struct p}: R := + match p with + xH => 1 + | xO xH => 1 + 1 + | xO p1 => R2 + (IPR p1) + | xI xH => 1 + (1 + 1) + | xI p1 => 1 + (R2 * (IPR p1)) + end. + +Definition IZR1 z := + match z with Z0 => 0 + | Zpos p => IPR p + | Zneg p => -(IPR p) + end. + +Fixpoint interpret3 t fv {struct t}: R := + match t with + | (PEadd t1 t2) => + let v1 := interpret3 t1 fv in + let v2 := interpret3 t2 fv in (v1 + v2) + | (PEmul t1 t2) => + let v1 := interpret3 t1 fv in + let v2 := interpret3 t2 fv in (v1 * v2) + | (PEsub t1 t2) => + let v1 := interpret3 t1 fv in + let v2 := interpret3 t2 fv in (v1 - v2) + | (PEopp t1) => + let v1 := interpret3 t1 fv in (- v1) + | (PEpow t1 t2) => + let v1 := interpret3 t1 fv in pow v1 (Nnat.nat_of_N t2) + | (PEc t1) => (IZR1 t1) + | (PEX n) => List.nth (pred (nat_of_P n)) fv 0 + end. + + +End domain. + +Ltac equalities_to_goal := + lazymatch goal with + | H: (@eq _ ?x 0) |- _ => try revert H + | H: (@eq _ 0 ?x) |- _ => + try generalize (sym_equal H); clear H + | H: (@eq _ ?x ?y) |- _ => + try generalize (@psos_r1 _ _ _ _ H); clear H + end. + +Ltac nsatz_domain_begin tacsimpl:= + intros; + try apply (@psos_r1b _ _); + repeat equalities_to_goal; + tacsimpl. + +Ltac generalise_eq_hyps:= + repeat + (match goal with + |h : (?p = ?q)|- _ => revert h + end). + +Ltac lpol_goal t := + match t with + | ?a = ring0 -> ?b => + let r:= lpol_goal b in + constr:(a::r) + | ?a = ring0 => constr:(a::nil) + end. + +(* lp est incluse dans fv. La met en tete. *) + +Ltac parametres_en_tete fv lp := + match fv with + | (@nil _) => lp + | (@cons _ ?x ?fv1) => + let res := AddFvTail x lp in + parametres_en_tete fv1 res + end. + +Ltac append1 a l := + match l with + | (@nil _) => constr:(cons a l) + | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l') + end. + +Ltac rev l := + match l with + |(@nil _) => l + | (cons ?x ?l) => let l' := rev l in append1 x l' + end. + +Ltac nsatz_call_n info nparam p rr lp kont := + let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in + nsatz_compute ll; + match goal with + | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => + intros _; + set (lci:=lci0); + set (lq:=lq0); + kont c rr lq lci + end. + +Ltac nsatz_call radicalmax info nparam p lp kont := + let rec try_n n := + lazymatch n with + | 0%N => fail + | _ => +(* idtac "Trying power: " n;*) + (let r := eval compute in (Nminus radicalmax (Npred n)) in + nsatz_call_n info nparam p r lp kont) || + let n' := eval compute in (Npred n) in try_n n' + end in + try_n radicalmax. + + +Set Implicit Arguments. +Class Cclosed_seq T (l:list T) := {}. +Instance Iclosed_nil T : Cclosed_seq (T:=T) nil. +Instance Iclosed_cons T t l `{Cclosed_seq (T:=T) l} : Cclosed_seq (T:=T) (t::l). + +Class Cfind_at (R:Type) (b:R) (l:list R) (i:nat) := {}. +Instance Ifind0 (R:Type) (b:R) l: Cfind_at b (b::l) 0. +Instance IfindS (R:Type) (b2 b1:R) l i `{Cfind_at R b1 l i} : Cfind_at b1 (b2::l) (S i) | 1. +Definition Ifind0' := Ifind0. +Definition IfindS' := IfindS. + +Definition li_find_at (R:Type) (b:R) l i `{Cfind_at R b l i} {H:Cclosed_seq (T:=R) l} := (l,i). + +Class Creify (R:Type) (e:PExpr Z) (l:list R) (b:R) := {}. +Instance Ireify_zero (R:Type) (Rd:Domain R) l : Creify (PEc 0%Z) l ring0. +Instance Ireify_one (R:Type) (Rd:Domain R) l : Creify (PEc 1%Z) l ring1. +Instance Ireify_plus (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2} + : Creify (PEadd e1 e2) l (ring_plus b1 b2). +Instance Ireify_mult (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2} + : Creify (PEmul e1 e2) l (ring_mult b1 b2). +Instance Ireify_sub (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2} + : Creify (PEsub e1 e2) l (ring_sub b1 b2). +Instance Ireify_opp (R:Type) (Rd:Domain R) e1 l b1 `{Creify R e1 l b1} + : Creify (PEopp e1) l (ring_opp b1). +Instance Ireify_var (R:Type) b l i `{Cfind_at R b l i} + : Creify (PEX _ (P_of_succ_nat i)) l b | 100. + + +Class Creifylist (R:Type) (le:list (PExpr Z)) (l:list R) (lb:list R) := {}. +Instance Creify_nil (R:Type) l : Creifylist nil l (@nil R). +Instance Creify_cons (R:Type) e1 l b1 le2 lb2 `{Creify R e1 l b1} `{Creifylist R le2 l lb2} + : Creifylist (e1::le2) l (b1::lb2). + +Definition li_reifyl (R:Type) le l lb `{Creifylist R le l lb} + {H:Cclosed_seq (T:=R) l} := (l,le). + +Unset Implicit Arguments. + +Ltac lterm_goal g := + match g with + ?b1 = ?b2 => constr:(b1::b2::nil) + | ?b1 = ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) + end. + +Ltac reify_goal l le lb:= + match le with + nil => idtac + | ?e::?le1 => + match lb with + ?b::?lb1 => + let x := fresh "B" in + set (x:= b) at 1; + change x with (@interpret3 _ _ e l); + clear x; + reify_goal l le1 lb1 + end + end. + +Ltac get_lpol g := + match g with + (interpret3 _ _ ?p _) = _ => constr:(p::nil) + | (interpret3 _ _ ?p _) = _ -> ?g => + let l := get_lpol g in constr:(p::l) + end. + +Ltac nsatz_domain_generic radicalmax info lparam lvar tacsimpl Rd := + match goal with + |- ?g => let lb := lterm_goal g in + (*idtac "lb"; idtac lb;*) + match eval red in (li_reifyl (lb:=lb)) with + | (?fv, ?le) => + let fv := match lvar with + (@nil _) => fv + | _ => lvar + end in + (* idtac "variables:";idtac fv;*) + let nparam := eval compute in (Z_of_nat (List.length lparam)) in + let fv := parametres_en_tete fv lparam in + (*idtac "variables:"; idtac fv; + idtac "nparam:"; idtac nparam;*) + match eval red in (li_reifyl (l:=fv) (lb:=lb)) with + | (?fv, ?le) => + idtac "variables:";idtac fv; + reify_goal fv le lb; + match goal with + |- ?g => + let lp := get_lpol g in + let lpol := eval compute in (List.rev lp) in + (*idtac "polynomes:"; idtac lpol;*) + tacsimpl; intros; + + let SplitPolyList kont := + match lpol with + | ?p2::?lp2 => kont p2 lp2 + | _ => idtac "polynomial not in the ideal" + end in + tacsimpl; + SplitPolyList ltac:(fun p lp => + set (p21:=p) ; + set (lp21:=lp); + (*idtac "lp:"; idtac lp; *) + nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => + set (q := PEmul c (PEpow p21 r)); + let Hg := fresh "Hg" in + assert (Hg:check lp21 q (lci,lq) = true); + [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" + | let Hg2 := fresh "Hg" in + assert (Hg2: interpret3 _ _ q fv = ring0); + [ tacsimpl; + apply (@check_correct _ Rd fv lp21 q (lci,lq) Hg); + tacsimpl; + repeat (split;[assumption|idtac]); exact I + | simpl in Hg2; tacsimpl; + apply Rdomain_pow with (interpret3 _ _ c fv) (Nnat.nat_of_N r); tacsimpl; + [ apply domain_axiom_one_zero || idtac "could not prove discrimination result" + | exact Hg2] + ] + ] +) +) +end end end end . + +Ltac nsatz_domainpv radicalmax info lparam lvar tacsimpl rd:= + nsatz_domain_begin tacsimpl; + nsatz_domain_generic radicalmax info lparam lvar tacsimpl rd. + +Ltac nsatz_domain:= + intros; + match goal with + |- (@eq ?r _ _ ) => + let a := constr:(@Ireify_zero _ _ (@nil r)) in + match a with + (@Ireify_zero _ ?rd _) => + nsatz_domainpv 6%N 1%Z (@nil r) (@nil r) ltac:(simpl) rd + end + end. + + + +(* Dans Z *) +Instance Zri : Ring Z := { + ring0 := 0%Z; + ring1 := 1%Z; + ring_plus := Zplus; + ring_mult := Zmult; + ring_sub := Zminus; + ring_opp := Zopp; + ring_ring := Zth}. + +Lemma Zaxiom_one_zero: 1%Z <> 0%Z. +discriminate. +Qed. + +Instance Zdi : Domain Z := { + domain_ring := Zri; + domain_axiom_product := Zmult_integral; + domain_axiom_one_zero := Zaxiom_one_zero}. + + +Ltac simplZ:= + simpl; +replace 0%Z with (@ring0 _ (@domain_ring _ Zdi));[idtac|reflexivity]; +replace 1%Z with (@ring1 _ (@domain_ring _ Zdi));[idtac|reflexivity]; +replace Zplus with (@ring_plus _ (@domain_ring _ Zdi));[idtac|reflexivity]; +replace Zmult with (@ring_mult _ (@domain_ring _ Zdi));[idtac|reflexivity]; +replace Zminus with (@ring_sub _ (@domain_ring _ Zdi));[idtac|reflexivity]; +replace Zopp with (@ring_opp _ (@domain_ring _ Zdi));[idtac|reflexivity]. + +Ltac nsatz_domainZ:= nsatz_domainpv 6%N 1%Z (@nil Z) (@nil Z) ltac:simplZ Zdi. + + +(* Dans R *) +Require Import Reals. +Require Import RealField. + +Instance Rri : Ring R := { + ring0 := 0%R; + ring1 := 1%R; + ring_plus := Rplus; + ring_mult := Rmult; + ring_sub := Rminus; + ring_opp := Ropp; + ring_ring := RTheory}. + +Lemma Raxiom_one_zero: 1%R <> 0%R. +discrR. +Qed. + +Instance Rdi : Domain R := { + domain_ring := Rri; + domain_axiom_product := Rmult_integral; + domain_axiom_one_zero := Raxiom_one_zero}. + + +Ltac simplR:= + simpl; +replace 0%R with (@ring0 _ (@domain_ring _ Rdi));[idtac|reflexivity]; +replace 1%R with (@ring1 _ (@domain_ring _ Rdi));[idtac|reflexivity]; +replace Rplus with (@ring_plus _ (@domain_ring _ Rdi));[idtac|reflexivity]; +replace Rmult with (@ring_mult _ (@domain_ring _ Rdi));[idtac|reflexivity]; +replace Rminus with (@ring_sub _ (@domain_ring _ Rdi));[idtac|reflexivity]; +replace Ropp with (@ring_opp _ (@domain_ring _ Rdi));[idtac|reflexivity]. + +Ltac nsatz_domainR:= nsatz_domainpv 6%N 1%Z (@List.nil R) (@List.nil R) ltac:simplR Rdi. diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml new file mode 100644 index 00000000..b91f01d1 --- /dev/null +++ b/plugins/nsatz/ideal.ml @@ -0,0 +1,1057 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mon -> mon +val deg : mon -> int +val compare_mon : mon -> mon -> int +val div_mon : mon -> mon -> mon +val div_mon_test : mon -> mon -> bool +val ppcm_mon : mon -> mon -> mon + +(* Polynomials *) + +type deg = int +type coef +type poly +type polynom + +val repr : poly -> (coef * mon) list +val polconst : coef -> poly +val zeroP : poly +val gen : int -> poly + +val equal : poly -> poly -> bool +val name_var : string list ref +val getvar : string list -> int -> string +val lstringP : poly list -> string +val printP : poly -> unit +val lprintP : poly list -> unit + +val div_pol_coef : poly -> coef -> poly +val plusP : poly -> poly -> poly +val mult_t_pol : coef -> mon -> poly -> poly +val selectdiv : mon -> poly list -> poly +val oppP : poly -> poly +val emultP : coef -> poly -> poly +val multP : poly -> poly -> poly +val puisP : poly -> int -> poly +val contentP : poly -> coef +val contentPlist : poly list -> coef +val pgcdpos : coef -> coef -> coef +val div_pol : poly -> poly -> coef -> coef -> mon -> poly +val reduce2 : poly -> poly list -> coef * poly + +val poldepcontent : coef list ref +val coefpoldep_find : poly -> poly -> poly +val coefpoldep_set : poly -> poly -> poly -> unit +val initcoefpoldep : poly list -> unit +val reduce2_trace : poly -> poly list -> poly list -> poly list * poly +val spol : poly -> poly -> poly +val etrangers : poly -> poly -> bool +val div_ppcm : poly -> poly -> poly -> bool + +val genPcPf : poly -> poly list -> poly list -> poly list +val genOCPf : poly list -> poly list + +val is_homogeneous : poly -> bool + +type certificate = + { coef : coef; power : int; + gb_comb : poly list list; last_comb : poly list } + +val test_dans_ideal : poly -> poly list -> poly list -> + poly list * poly * certificate +val in_ideal : deg -> poly list -> poly -> poly list * poly * certificate + +end + +(*********************************************************************** + Global options +*) +let lexico = ref false +let use_hmon = ref false + +(* division of tail monomials *) + +let reduire_les_queues = false + +(* divide first with new polynomials *) + +let nouveaux_pol_en_tete = false + +(*********************************************************************** + Functor +*) + +module Make (P:Polynom.S) = struct + + type coef = P.t + let coef0 = P.of_num (Num.Int 0) + let coef1 = P.of_num (Num.Int 1) + let coefm1 = P.of_num (Num.Int (-1)) + let string_of_coef c = "["^(P.to_string c)^"]" + +(*********************************************************************** + Monomials + array of integers, first is the degree +*) + +type mon = int array +type deg = int +type poly = (coef * mon) list +type polynom = + {pol : poly ref; + num : int; + sugar : int} + +let nvar m = Array.length m - 1 + +let deg m = m.(0) + +let mult_mon m m' = + let d = nvar m in + let m'' = Array.create (d+1) 0 in + for i=0 to d do + m''.(i)<- (m.(i)+m'.(i)); + done; + m'' + + +let compare_mon m m' = + let d = nvar m in + if !lexico + then ( + (* Comparaison de monomes avec ordre du degre lexicographique = on commence par regarder la 1ere variable*) + let res=ref 0 in + let i=ref 1 in (* 1 si lexico pur 0 si degre*) + while (!res=0) && (!i<=d) do + res:= (compare m.(!i) m'.(!i)); + i:=!i+1; + done; + !res) + else ( + (* degre lexicographique inverse *) + match compare m.(0) m'.(0) with + | 0 -> (* meme degre total *) + let res=ref 0 in + let i=ref d in + while (!res=0) && (!i>=1) do + res:= - (compare m.(!i) m'.(!i)); + i:=!i-1; + done; + !res + | x -> x) + +let div_mon m m' = + let d = nvar m in + let m'' = Array.create (d+1) 0 in + for i=0 to d do + m''.(i)<- (m.(i)-m'.(i)); + done; + m'' + +let div_pol_coef p c = + List.map (fun (a,m) -> (P.divP a c,m)) p + +(* m' divides m *) +let div_mon_test m m' = + let d = nvar m in + let res=ref true in + let i=ref 0 in (*il faut que le degre total soit bien mis sinon, i=ref 1*) + while (!res) && (!i<=d) do + res:= (m.(!i) >= m'.(!i)); + i:=succ !i; + done; + !res + +let set_deg m = + let d = nvar m in + m.(0)<-0; + for i=1 to d do + m.(0)<- m.(i)+m.(0); + done; + m + +(* lcm *) +let ppcm_mon m m' = + let d = nvar m in + let m'' = Array.create (d+1) 0 in + for i=1 to d do + m''.(i)<- (max m.(i) m'.(i)); + done; + set_deg m'' + + + +(********************************************************************** + Polynomials + list of (coefficient, monomial) decreasing order +*) + +let repr p = p + +let equal = + Util.list_for_all2eq + (fun (c1,m1) (c2,m2) -> P.equal c1 c2 && m1=m2) + +let hash p = + let c = map fst p in + let m = map snd p in + fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c + +module Hashpol = Hashtbl.Make( + struct + type t = poly + let equal = equal + let hash = hash + end) + + +(* A pretty printer for polynomials, with Maple-like syntax. *) + +open Format + +let getvar lv i = + try (nth lv i) + with _ -> (fold_left (fun r x -> r^" "^x) "lv= " lv) + ^" i="^(string_of_int i) + +let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef + dimmon string_of_exp lvar p = + + + let rec string_of_mon m coefone = + let s=ref [] in + for i=1 to (dimmon m) do + (match (string_of_exp m i) with + "0" -> () + | "1" -> s:= (!s) @ [(getvar !lvar (i-1))] + | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]); + done; + (match !s with + [] -> if coefone + then "1" + else "" + | l -> if coefone + then (String.concat "*" l) + else ( "*" ^ + (String.concat "*" l))) + and string_of_term t start = let a = coefterm t and m = monterm t in + match (string_of_coef a) with + "0" -> "" + | "1" ->(match start with + true -> string_of_mon m true + |false -> ( "+ "^ + (string_of_mon m true))) + | "-1" ->( "-" ^" "^(string_of_mon m true)) + | c -> if (String.get c 0)='-' + then ( "- "^ + (String.sub c 1 + ((String.length c)-1))^ + (string_of_mon m false)) + else (match start with + true -> ( c^(string_of_mon m false)) + |false -> ( "+ "^ + c^(string_of_mon m false))) + and stringP p start = + if (zeroP p) + then (if start + then ("0") + else "") + else ((string_of_term (hdP p) start)^ + " "^ + (stringP (tlP p) false)) + in + (stringP p true) + + + +let print_pol zeroP hdP tlP coefterm monterm string_of_coef + dimmon string_of_exp lvar p = + + let rec print_mon m coefone = + let s=ref [] in + for i=1 to (dimmon m) do + (match (string_of_exp m i) with + "0" -> () + | "1" -> s:= (!s) @ [(getvar !lvar (i-1))] + | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]); + done; + (match !s with + [] -> if coefone + then print_string "1" + else () + | l -> if coefone + then print_string (String.concat "*" l) + else (print_string "*"; + print_string (String.concat "*" l))) + and print_term t start = let a = coefterm t and m = monterm t in + match (string_of_coef a) with + "0" -> () + | "1" ->(match start with + true -> print_mon m true + |false -> (print_string "+ "; + print_mon m true)) + | "-1" ->(print_string "-";print_space();print_mon m true) + | c -> if (String.get c 0)='-' + then (print_string "- "; + print_string (String.sub c 1 + ((String.length c)-1)); + print_mon m false) + else (match start with + true -> (print_string c;print_mon m false) + |false -> (print_string "+ "; + print_string c;print_mon m false)) + and printP p start = + if (zeroP p) + then (if start + then print_string("0") + else ()) + else (print_term (hdP p) start; + if start then open_hovbox 0; + print_space(); + print_cut(); + printP (tlP p) false) + in open_hovbox 3; + printP p true; + print_flush() + + +let name_var= ref [] + +let stringP p = + string_of_pol + (fun p -> match p with [] -> true | _ -> false) + (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") + (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal") + (fun (a,m) -> a) + (fun (a,m) -> m) + string_of_coef + (fun m -> (Array.length m)-1) + (fun m i -> (string_of_int (m.(i)))) + name_var + p + +let nsP2 = ref max_int + +let stringPcut p = + (*Polynomesrec.nsP1:=20;*) + nsP2:=10; + let res = + if (length p)> !nsP2 + then (stringP [hd p])^" + "^(string_of_int (length p))^" termes" + else stringP p in + (*Polynomesrec.nsP1:= max_int;*) + nsP2:= max_int; + res + +let rec lstringP l = + match l with + [] -> "" + |p::l -> (stringP p)^("\n")^(lstringP l) + +let printP = print_pol + (fun p -> match p with [] -> true | _ -> false) + (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") + (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal") + (fun (a,m) -> a) + (fun (a,m) -> m) + string_of_coef + (fun m -> (Array.length m)-1) + (fun m i -> (string_of_int (m.(i)))) + name_var + + +let rec lprintP l = + match l with + [] -> () + |p::l -> printP p;print_string "\n"; lprintP l + + +(* Operations *) + +let zeroP = [] + +(* returns a constant polynom ial with d variables *) +let polconst d c = + let m = Array.create (d+1) 0 in + let m = set_deg m in + [(c,m)] + +let plusP p q = + let rec plusP p q = + match p with + [] -> q + |t::p' -> + match q with + [] -> p + |t'::q' -> + match compare_mon (snd t) (snd t') with + 1 -> t::(plusP p' q) + |(-1) -> t'::(plusP p q') + |_ -> let c=P.plusP (fst t) (fst t') in + match P.equal c coef0 with + true -> (plusP p' q') + |false -> (c,(snd t))::(plusP p' q') + in plusP p q + +(* multiplication by (a,monomial) *) +let mult_t_pol a m p = + let rec mult_t_pol p = + match p with + [] -> [] + |(b,m')::p -> ((P.multP a b),(mult_mon m m'))::(mult_t_pol p) + in mult_t_pol p + +let coef_of_int x = P.of_num (Num.Int x) + +(* variable i *) +let gen d i = + let m = Array.create (d+1) 0 in + m.(i) <- 1; + let m = set_deg m in + [((coef_of_int 1),m)] + +let oppP p = + let rec oppP p = + match p with + [] -> [] + |(b,m')::p -> ((P.oppP b),m')::(oppP p) + in oppP p + +(* multiplication by a coefficient *) +let emultP a p = + let rec emultP p = + match p with + [] -> [] + |(b,m')::p -> ((P.multP a b),m')::(emultP p) + in emultP p + +let multP p q = + let rec aux p = + match p with + [] -> [] + |(a,m)::p' -> plusP (mult_t_pol a m q) (aux p') + in aux p + +let puisP p n= + match p with + [] -> [] + |_ -> + let d = nvar (snd (hd p)) in + let rec puisP n = + match n with + 0 -> [coef1, Array.create (d+1) 0] + | 1 -> p + |_ -> multP p (puisP (n-1)) + in puisP n + +let rec contentP p = + match p with + |[] -> coef1 + |[a,m] -> a + |(a,m)::p1 -> + if P.equal a coef1 || P.equal a coefm1 + then a + else P.pgcdP a (contentP p1) + +let contentPlist lp = + match lp with + |[] -> coef1 + |p::l1 -> + fold_left + (fun r q -> + if P.equal r coef1 || P.equal r coefm1 + then r + else P.pgcdP r (contentP q)) + (contentP p) l1 + +(*********************************************************************** + Division of polynomials + *) + +let pgcdpos a b = P.pgcdP a b + +let polynom0 = {pol = ref []; num = 0; sugar = 0} + +let ppol p = !(p.pol) + +let lm p = snd (hd (ppol p)) + +let nallpol = ref 0 + +let allpol = ref (Array.create 1000 polynom0) + +let new_allpol p s = + nallpol := !nallpol + 1; + if !nallpol >= Array.length !allpol + then + allpol := Array.append !allpol (Array.create !nallpol polynom0); + let p = {pol = ref p; num = !nallpol; sugar = s} in + !allpol.(!nallpol)<- p; + p + +(* returns a polynomial of l whose head monomial divides m, else [] *) + +let rec selectdiv m l = + match l with + [] -> polynom0 + |q::r -> let m'= snd (hd (ppol q)) in + match (div_mon_test m m') with + true -> q + |false -> selectdiv m r + +let div_pol p q a b m = +(* info ".";*) + plusP (emultP a p) (mult_t_pol b m q) + +let hmon = Hashtbl.create 1000 + +let use_hmon = ref false + +let find_hmon m = + if !use_hmon + then Hashtbl.find hmon m + else raise Not_found + +let add_hmon m q = + if !use_hmon + then Hashtbl.add hmon m q + else () + +let div_coef a b = P.divP a b + + +(* remainder r of the division of p by polynomials of l, returns (c,r) where c is the coefficient for pseudo-division : c p = sum_i q_i p_i + r *) + +let reduce2 p l = + let l = if nouveaux_pol_en_tete then rev l else l in + let rec reduce p = + match p with + [] -> (coef1,[]) + |t::p' -> + let (a,m)=t in + let q = (try find_hmon m + with Not_found -> + let q = selectdiv m l in + match (ppol q) with + t'::q' -> (add_hmon m q; + q) + |[] -> q) in + match (ppol q) with + [] -> if reduire_les_queues + then + let (c,r)=(reduce p') in + (c,((P.multP a c,m)::r)) + else (coef1,p) + |(b,m')::q' -> + let c=(pgcdpos a b) in + let a'= (div_coef b c) in + let b'=(P.oppP (div_coef a c)) in + let (e,r)=reduce (div_pol p' q' a' b' + (div_mon m m')) in + (P.multP a' e,r) + in let (c,r) = reduce p in + (c,r) + +(* trace of divisions *) + +(* list of initial polynomials *) +let poldep = ref [] +let poldepcontent = ref [] + +(* coefficients of polynomials when written with initial polynomials *) +let coefpoldep = Hashtbl.create 51 + +(* coef of q in p = sum_i c_i*q_i *) +let coefpoldep_find p q = + try (Hashtbl.find coefpoldep (p.num,q.num)) + with _ -> [] + +let coefpoldep_remove p q = + Hashtbl.remove coefpoldep (p.num,q.num) + +let coefpoldep_set p q c = + Hashtbl.add coefpoldep (p.num,q.num) c + +let initcoefpoldep d lp = + poldep:=lp; + poldepcontent:= map (fun p -> contentP (ppol p)) lp; + iter + (fun p -> coefpoldep_set p p (polconst d (coef_of_int 1))) + lp + +(* keeps trace in coefpoldep + divides without pseudodivisions *) + +let reduce2_trace p l lcp = + let l = if nouveaux_pol_en_tete then rev l else l in + (* rend (lq,r), ou r = p + sum(lq) *) + let rec reduce p = + match p with + [] -> ([],[]) + |t::p' -> + let (a,m)=t in + let q = + (try find_hmon m + with Not_found -> + let q = selectdiv m l in + match (ppol q) with + t'::q' -> (add_hmon m q; + q) + |[] -> q) in + match (ppol q) with + [] -> + if reduire_les_queues + then + let (lq,r)=(reduce p') in + (lq,((a,m)::r)) + else ([],p) + |(b,m')::q' -> + let b'=(P.oppP (div_coef a b)) in + let m''= div_mon m m' in + let p1=plusP p' (mult_t_pol b' m'' q') in + let (lq,r)=reduce p1 in + ((b',m'',q)::lq, r) + in let (lq,r) = reduce p in + (*info "reduce2_trace:\n"; + iter + (fun (a,m,s) -> + let x = mult_t_pol a m s in + info ((stringP x)^"\n")) + lq; + info "ok\n";*) + (map2 + (fun c0 q -> + let c = + fold_left + (fun x (a,m,s) -> + if equal (ppol s) (ppol q) + then + plusP x (mult_t_pol a m (polconst (nvar m) (coef_of_int 1))) + else x) + c0 + lq in + c) + lcp + !poldep, + r) + +let homogeneous = ref false +let pol_courant = ref polynom0 + +(*********************************************************************** + Completion + *) + +let sugar_flag = ref true + +let compute_sugar p = + fold_left (fun s (a,m) -> max s m.(0)) 0 p + +let mk_polynom p = + new_allpol p (compute_sugar p) + +let spol ps qs= + let p = ppol ps in + let q = ppol qs in + let m = snd (hd p) in + let m'= snd (hd q) in + let a = fst (hd p) in + let b = fst (hd q) in + let p'= tl p in + let q'= tl q in + let c = (pgcdpos a b) in + let m''=(ppcm_mon m m') in + let m1 = div_mon m'' m in + let m2 = div_mon m'' m' in + let fsp p' q' = + plusP + (mult_t_pol + (div_coef b c) + m1 p') + (mult_t_pol + (P.oppP (div_coef a c)) + m2 q') in + let sp = fsp p' q' in + let sps = + new_allpol + sp + (max (m1.(0) + ps.sugar) (m2.(0) + qs.sugar)) in + coefpoldep_set sps ps (fsp (polconst (nvar m) (coef_of_int 1)) []); + coefpoldep_set sps qs (fsp [] (polconst (nvar m) (coef_of_int 1))); + sps + + +let etrangers p p'= + let m = snd (hd p) in + let m'= snd (hd p') in + let d = nvar m in + let res=ref true in + let i=ref 1 in + while (!res) && (!i<=d) do + res:= (m.(!i) = 0) || (m'.(!i)=0); + i:=!i+1; + done; + !res + +(* teste if head monomial of p'' divides lcm of lhead monomials of p and p' *) + +let div_ppcm p p' p'' = + let m = snd (hd p) in + let m'= snd (hd p') in + let m''= snd (hd p'') in + let d = nvar m in + let res=ref true in + let i=ref 1 in + while (!res) && (!i<=d) do + res:= ((max m.(!i) m'.(!i)) >= m''.(!i)); + i:=!i+1; + done; + !res + +(* code from extraction of Laurent Théry Coq program *) + +type 'poly cpRes = + Keep of ('poly list) + | DontKeep of ('poly list) + +let list_rec f0 f1 = + let rec f2 = function + [] -> f0 + | a0::l0 -> f1 a0 l0 (f2 l0) + in f2 + +let addRes i = function + Keep h'0 -> Keep (i::h'0) + | DontKeep h'0 -> DontKeep (i::h'0) + +let slice i a q = + list_rec + (match etrangers (ppol i) (ppol a) with + true -> DontKeep [] + | false -> Keep []) + (fun b q1 rec_ren -> + match div_ppcm (ppol i) (ppol a) (ppol b) with + true -> DontKeep (b::q1) + | false -> + (match div_ppcm (ppol i) (ppol b) (ppol a) with + true -> rec_ren + | false -> addRes b rec_ren)) q + +(* sugar strategy *) + +let rec addS x l = l @ [x] (* oblige de mettre en queue sinon le certificat deconne *) + +let addSsugar x l = + if !sugar_flag + then + let sx = x.sugar in + let rec insere l = + match l with + | [] -> [x] + | y::l1 -> + if sx <= y.sugar + then x::l + else y::(insere l1) + in insere l + else addS x l + +(* ajoute les spolynomes de i avec la liste de polynomes aP, + a la liste q *) + +let genPcPf i aP q = + (let rec genPc aP0 = + match aP0 with + [] -> (fun r -> r) + | a::l1 -> + (fun l -> + (match slice i a l1 with + Keep l2 -> addSsugar (spol i a) (genPc l2 l) + | DontKeep l2 -> genPc l2 l)) + in genPc aP) q + +let genOCPf h' = + list_rec [] (fun a l rec_ren -> + genPcPf a l rec_ren) h' + +(*********************************************************************** + critical pairs/s-polynomials + *) + +let ordcpair ((i1,j1),m1) ((i2,j2),m2) = +(* let s1 = (max + (!allpol.(i1).sugar + m1.(0) + - (snd (hd (ppol !allpol.(i1)))).(0)) + (!allpol.(j1).sugar + m1.(0) + - (snd (hd (ppol !allpol.(j1)))).(0))) in + let s2 = (max + (!allpol.(i2).sugar + m2.(0) + - (snd (hd (ppol !allpol.(i2)))).(0)) + (!allpol.(j2).sugar + m2.(0) + - (snd (hd (ppol !allpol.(j2)))).(0))) in + match compare s1 s2 with + | 1 -> 1 + |(-1) -> -1 + |0 -> compare_mon m1 m2*) + + compare_mon m1 m2 + +let sortcpairs lcp = + sort ordcpair lcp + +let mergecpairs l1 l2 = + merge ordcpair l1 l2 + +let ord i j = + if i r @ (cpair p q)) [] lq) + +let cpairs lp = + let rec aux l = + match l with + []|[_] -> [] + |p::l1 -> mergecpairs (cpairs1 p l1) (aux l1) + in aux lp + + +let critere2 ((i,j),m) lp lcp = + exists + (fun h -> + h.num <> i && h.num <> j + && (div_mon_test m (lm h)) + && (let c1 = ord i h.num in + not (exists (fun (c,_) -> c1 = c) lcp)) + && (let c1 = ord j h.num in + not (exists (fun (c,_) -> c1 = c) lcp))) + lp + +let critere3 ((i,j),m) lp lcp = + exists + (fun h -> + h.num <> i && h.num <> j + && (div_mon_test m (lm h)) + && (h.num < j + || not (m = ppcm_mon + (lm (!allpol.(i))) + (lm h))) + && (h.num < i + || not (m = ppcm_mon + (lm (!allpol.(j))) + (lm h)))) + lp + +let add_cpairs p lp lcp = + mergecpairs (cpairs1 p lp) lcp + +let step = ref 0 + +let infobuch p q = + if !step = 0 + then (info ("[" ^ (string_of_int (length p)) + ^ "," ^ (string_of_int (length q)) + ^ "]")) + +(* in lp new polynomials are at the end *) + +let coef_courant = ref coef1 + +type certificate = + { coef : coef; power : int; + gb_comb : poly list list; last_comb : poly list } + +let test_dans_ideal p lp lp0 = + let (c,r) = reduce2 (ppol !pol_courant) lp in + info ("remainder: "^(stringPcut r)^"\n"); + coef_courant:= P.multP !coef_courant c; + pol_courant:= mk_polynom r; + if r=[] + then (info "polynomial reduced to 0\n"; + let lcp = map (fun q -> []) !poldep in + let c = !coef_courant in + let (lcq,r) = reduce2_trace (emultP c p) lp lcp in + info "r ok\n"; + info ("r: "^(stringP r)^"\n"); + let res=ref (emultP c p) in + iter2 + (fun cq q -> res:=plusP (!res) (multP cq (ppol q)); + ) + lcq !poldep; + info ("verif sum: "^(stringP (!res))^"\n"); + info ("coefficient: "^(stringP (polconst 1 c))^"\n"); + let rec aux lp = + match lp with + |[] -> [] + |p::lp -> + (map + (fun q -> coefpoldep_find p q) + lp)::(aux lp) + in + let coefficient_multiplicateur = c in + let liste_polynomes_de_depart = rev lp0 in + let polynome_a_tester = p in + let liste_des_coefficients_intermediaires = + (let lci = rev (aux (rev lp)) in + let lci = ref lci (* (map rev lci) *) in + iter (fun x -> lci := tl (!lci)) lp0; + !lci) in + let liste_des_coefficients = + map + (fun cq -> emultP (coef_of_int (-1)) cq) + (rev lcq) in + (liste_polynomes_de_depart, + polynome_a_tester, + {coef = coefficient_multiplicateur; + power = 1; + gb_comb = liste_des_coefficients_intermediaires; + last_comb = liste_des_coefficients}) + ) + else ((*info "polynomial not reduced to 0\n"; + info ("\nremainder: "^(stringPcut r)^"\n");*) + raise NotInIdeal) + +let divide_rem_with_critical_pair = ref false + +let list_diff l x = + filter (fun y -> y <> x) l + +let deg_hom p = + match p with + | [] -> -1 + | (a,m)::_ -> m.(0) + +let pbuchf pq p lp0= + info "computation of the Groebner basis\n"; + step:=0; + Hashtbl.clear hmon; + let rec pbuchf (lp, lpc) = + infobuch lp lpc; +(* step:=(!step+1)mod 10;*) + match lpc with + [] -> + + (* info ("List of polynomials:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp)); + info "--------------------\n";*) + test_dans_ideal (ppol p) lp lp0 + | ((i,j),m) :: lpc2 -> +(* info "choosen pair\n";*) + if critere3 ((i,j),m) lp lpc2 + then (info "c"; pbuchf (lp, lpc2)) + else + let a = spol !allpol.(i) !allpol.(j) in + if !homogeneous && (ppol a)<>[] && deg_hom (ppol a) + > deg_hom (ppol !pol_courant) + then (info "h"; pbuchf (lp, lpc2)) + else +(* let sa = a.sugar in*) + let (ca,a0)= reduce2 (ppol a) lp in + match a0 with + [] -> info "0";pbuchf (lp, lpc2) + | _ -> +(* info "pair reduced\n";*) + a.pol := emultP ca (ppol a); + let (lca,a0) = reduce2_trace (ppol a) lp + (map (fun q -> emultP ca (coefpoldep_find a q)) + !poldep) in +(* info "paire re-reduced";*) + a.pol := a0; +(* let a0 = new_allpol a0 sa in*) + iter2 (fun c q -> + coefpoldep_remove a q; + coefpoldep_set a q c) lca !poldep; + let a0 = a in + info ("\nnew polynomials: "^(stringPcut (ppol a0))^"\n"); + let ct = coef1 (* contentP a0 *) in + (*info ("content: "^(string_of_coef ct)^"\n");*) + poldep:=addS a0 lp; + poldepcontent:=addS ct (!poldepcontent); + + try test_dans_ideal (ppol p) (addS a0 lp) lp0 + with NotInIdeal -> + let newlpc = add_cpairs a0 lp lpc2 in + pbuchf (((addS a0 lp), newlpc)) + in pbuchf pq + +let is_homogeneous p = + match p with + | [] -> true + | (a,m)::p1 -> let d = m.(0) in + for_all (fun (b,m') -> m'.(0)=d) p1 + +(* returns + c + lp = [pn;...;p1] + p + lci = [[a(n+1,n);...;a(n+1,1)]; + [a(n+2,n+1);...;a(n+2,1)]; + ... + [a(n+m,n+m-1);...;a(n+m,1)]] + lc = [qn+m; ... q1] + + such that + c*p = sum qi*pi + where pn+k = a(n+k,n+k-1)*pn+k-1 + ... + a(n+k,1)* p1 + *) + +let in_ideal d lp p = + Hashtbl.clear hmon; + Hashtbl.clear coefpoldep; + nallpol := 0; + allpol := Array.create 1000 polynom0; + homogeneous := for_all is_homogeneous (p::lp); + if !homogeneous then info "homogeneous polynomials\n"; + info ("p: "^(stringPcut p)^"\n"); + info ("lp:\n"^(fold_left (fun r p -> r^(stringPcut p)^"\n") "" lp)); + (*info ("p: "^(stringP p)^"\n"); + info ("lp:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp));*) + + let lp = map mk_polynom lp in + let p = mk_polynom p in + initcoefpoldep d lp; + coef_courant:=coef1; + pol_courant:=p; + + let (lp1,p1,cert) = + try test_dans_ideal (ppol p) lp lp + with NotInIdeal -> pbuchf (lp, (cpairs lp)) p lp in + info "computed\n"; + + (map ppol lp1, p1, cert) + +(* *) +end + + + diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml4 new file mode 100644 index 00000000..892d6037 --- /dev/null +++ b/plugins/nsatz/nsatz.ml4 @@ -0,0 +1,608 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 1 + let puis = power_big_int_positive_int + + (* a et b positifs, résultat positif *) + let rec pgcd a b = + if equal b coef0 + then a + else if lt a b then pgcd b a else pgcd b (modulo a b) + + + (* signe du pgcd = signe(a)*signe(b) si non nuls. *) + let pgcd2 a b = + if equal a coef0 then b + else if equal b coef0 then a + else let c = pgcd (abs a) (abs b) in + if ((lt coef0 a)&&(lt b coef0)) + ||((lt coef0 b)&&(lt a coef0)) + then opp c else c +end + +(* +module Ent = struct + type t = Entiers.entiers + let of_int = Entiers.ent_of_int + let of_num x = Entiers.ent_of_string(Num.string_of_num x) + let to_num x = Num.num_of_string (Entiers.string_of_ent x) + let equal = Entiers.eq_ent + let lt = Entiers.lt_ent + let le = Entiers.le_ent + let abs = Entiers.abs_ent + let plus =Entiers.add_ent + let mult = Entiers.mult_ent + let sub = Entiers.moins_ent + let opp = Entiers.opp_ent + let div = Entiers.div_ent + let modulo = Entiers.mod_ent + let coef0 = Entiers.ent0 + let coef1 = Entiers.ent1 + let to_string = Entiers.string_of_ent + let to_int x = Entiers.int_of_ent x + let hash x =Entiers.hash_ent x + let signe = Entiers.signe_ent + + let rec puis p n = match n with + 0 -> coef1 + |_ -> (mult p (puis p (n-1))) + + (* a et b positifs, résultat positif *) + let rec pgcd a b = + if equal b coef0 + then a + else if lt a b then pgcd b a else pgcd b (modulo a b) + + + (* signe du pgcd = signe(a)*signe(b) si non nuls. *) + let pgcd2 a b = + if equal a coef0 then b + else if equal b coef0 then a + else let c = pgcd (abs a) (abs b) in + if ((lt coef0 a)&&(lt b coef0)) + ||((lt coef0 b)&&(lt a coef0)) + then opp c else c +end +*) + +(* ------------------------------------------------------------------------- *) +(* ------------------------------------------------------------------------- *) + +type vname = string + +type term = + | Zero + | Const of Num.num + | Var of vname + | Opp of term + | Add of term * term + | Sub of term * term + | Mul of term * term + | Pow of term * int + +let const n = + if eq_num n num_0 then Zero else Const n +let pow(p,i) = if i=1 then p else Pow(p,i) +let add = function + (Zero,q) -> q + | (p,Zero) -> p + | (p,q) -> Add(p,q) +let mul = function + (Zero,_) -> Zero + | (_,Zero) -> Zero + | (p,Const n) when eq_num n num_1 -> p + | (Const n,q) when eq_num n num_1 -> q + | (p,q) -> Mul(p,q) + +let unconstr = mkRel 1 + +let tpexpr = + lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") +let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc") +let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX") +let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") +let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub") +let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul") +let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp") +let ttpow = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEpow") + +let tlist = lazy (gen_constant "CC" ["Lists";"List"] "list") +let lnil = lazy (gen_constant "CC" ["Lists";"List"] "nil") +let lcons = lazy (gen_constant "CC" ["Lists";"List"] "cons") + +let tz = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Z") +let z0 = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Z0") +let zpos = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Zpos") +let zneg = lazy(gen_constant "CC" ["ZArith";"BinInt"] "Zneg") + +let pxI = lazy(gen_constant "CC" ["NArith";"BinPos"] "xI") +let pxO = lazy(gen_constant "CC" ["NArith";"BinPos"] "xO") +let pxH = lazy(gen_constant "CC" ["NArith";"BinPos"] "xH") + +let nN0 = lazy (gen_constant "CC" ["NArith";"BinNat"] "N0") +let nNpos = lazy(gen_constant "CC" ["NArith";"BinNat"] "Npos") + +let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) + +let tlp () = mkt_app tlist [mkt_app tpexpr [Lazy.force tz]] +let tllp () = mkt_app tlist [tlp()] + +let rec mkt_pos n = + if n =/ num_1 then Lazy.force pxH + else if mod_num n num_2 =/ num_0 then + mkt_app pxO [mkt_pos (quo_num n num_2)] + else + mkt_app pxI [mkt_pos (quo_num n num_2)] + +let mkt_n n = + if n=num_0 + then Lazy.force nN0 + else mkt_app nNpos [mkt_pos n] + +let mkt_z z = + if z =/ num_0 then Lazy.force z0 + else if z >/ num_0 then + mkt_app zpos [mkt_pos z] + else + mkt_app zneg [mkt_pos ((Int 0) -/ z)] + +let rec mkt_term t = match t with +| Zero -> mkt_term (Const num_0) +| Const r -> let (n,d) = numdom r in + mkt_app ttconst [Lazy.force tz; mkt_z n] +| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)] +| Opp t1 -> mkt_app ttopp [Lazy.force tz; mkt_term t1] +| Add (t1,t2) -> mkt_app ttadd [Lazy.force tz; mkt_term t1; mkt_term t2] +| Sub (t1,t2) -> mkt_app ttsub [Lazy.force tz; mkt_term t1; mkt_term t2] +| Mul (t1,t2) -> mkt_app ttmul [Lazy.force tz; mkt_term t1; mkt_term t2] +| Pow (t1,n) -> if (n = 0) then + mkt_app ttconst [Lazy.force tz; mkt_z num_1] +else + mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)] + +let rec parse_pos p = + match kind_of_term p with +| App (a,[|p2|]) -> + if a = Lazy.force pxO then num_2 */ (parse_pos p2) + else num_1 +/ (num_2 */ (parse_pos p2)) +| _ -> num_1 + +let parse_z z = + match kind_of_term z with +| App (a,[|p2|]) -> + if a = Lazy.force zpos then parse_pos p2 else (num_0 -/ (parse_pos p2)) +| _ -> num_0 + +let parse_n z = + match kind_of_term z with +| App (a,[|p2|]) -> + parse_pos p2 +| _ -> num_0 + +let rec parse_term p = + match kind_of_term p with +| App (a,[|_;p2|]) -> + if a = Lazy.force ttvar then Var (string_of_num (parse_pos p2)) + else if a = Lazy.force ttconst then Const (parse_z p2) + else if a = Lazy.force ttopp then Opp (parse_term p2) + else Zero +| App (a,[|_;p2;p3|]) -> + if a = Lazy.force ttadd then Add (parse_term p2, parse_term p3) + else if a = Lazy.force ttsub then Sub (parse_term p2, parse_term p3) + else if a = Lazy.force ttmul then Mul (parse_term p2, parse_term p3) + else if a = Lazy.force ttpow then + Pow (parse_term p2, int_of_num (parse_n p3)) + else Zero +| _ -> Zero + +let rec parse_request lp = + match kind_of_term lp with + | App (_,[|_|]) -> [] + | App (_,[|_;p;lp1|]) -> + (parse_term p)::(parse_request lp1) + |_-> assert false + +let nvars = ref 0 + +let set_nvars_term t = + let rec aux t = + match t with + | Zero -> () + | Const r -> () + | Var v -> let n = int_of_string v in + nvars:= max (!nvars) n + | Opp t1 -> aux t1 + | Add (t1,t2) -> aux t1; aux t2 + | Sub (t1,t2) -> aux t1; aux t2 + | Mul (t1,t2) -> aux t1; aux t2 + | Pow (t1,n) -> aux t1 + in aux t + +let string_of_term p = + let rec aux p = + match p with + | Zero -> "0" + | Const r -> string_of_num r + | Var v -> "x"^v + | Opp t1 -> "(-"^(aux t1)^")" + | Add (t1,t2) -> "("^(aux t1)^"+"^(aux t2)^")" + | Sub (t1,t2) -> "("^(aux t1)^"-"^(aux t2)^")" + | Mul (t1,t2) -> "("^(aux t1)^"*"^(aux t2)^")" + | Pow (t1,n) -> (aux t1)^"^"^(string_of_int n) + in aux p + + +(*********************************************************************** + Coefficients: recursive polynomials + *) + +module Coef = BigInt +(*module Coef = Ent*) +module Poly = Polynom.Make(Coef) +module PIdeal = Ideal.Make(Poly) +open PIdeal + +(* term to sparse polynomial + varaibles <=np are in the coefficients +*) + +let term_pol_sparse np t= + let d = !nvars in + let rec aux t = + match t with + | Zero -> zeroP + | Const r -> + if r = num_0 + then zeroP + else polconst d (Poly.Pint (Coef.of_num r)) + | Var v -> + let v = int_of_string v in + if v <= np + then polconst d (Poly.x v) + else gen d v + | Opp t1 -> oppP (aux t1) + | Add (t1,t2) -> plusP (aux t1) (aux t2) + | Sub (t1,t2) -> plusP (aux t1) (oppP (aux t2)) + | Mul (t1,t2) -> multP (aux t1) (aux t2) + | Pow (t1,n) -> puisP (aux t1) n + in (*info ("conversion de: "^(string_of_term t)^"\n");*) + let res= aux t in + (*info ("donne: "^(stringP res)^"\n");*) + res + +(* sparse polynomial to term *) + +let polrec_to_term p = + let rec aux p = + match p with + |Poly.Pint n -> const (Coef.to_num n) + |Poly.Prec (v,coefs) -> + let res = ref Zero in + Array.iteri + (fun i c -> + res:=add(!res, mul(aux c, + pow (Var (string_of_int v), + i)))) + coefs; + !res + in aux p + +(* approximation of the Horner form used in the tactic ring *) + +let pol_sparse_to_term n2 p = + info "pol_sparse_to_term ->\n"; + let p = PIdeal.repr p in + let rec aux p = + match p with + [] -> const (num_of_string "0") + | (a,m)::p1 -> + let n = (Array.length m)-1 in + let (i0,e0) = + List.fold_left (fun (r,d) (a,m) -> + let i0= ref 0 in + for k=1 to n do + if m.(k)>0 + then i0:=k + done; + if !i0 = 0 + then (r,d) + else if !i0 > r + then (!i0, m.(!i0)) + else if !i0 = r && m.(!i0) + if m.(i0)>=e0 + then (m.(i0)<-m.(i0)-e0; + p1:=(a,m)::(!p1)) + else p2:=(a,m)::(!p2)) + p; + let vm = + if e0=1 + then Var (string_of_int (i0)) + else pow (Var (string_of_int (i0)),e0) in + add(mul(vm, aux (List.rev (!p1))), aux (List.rev (!p2)))) + in info "-> pol_sparse_to_term\n"; + aux p + + +let rec remove_list_tail l i = + let rec aux l i = + if l=[] + then [] + else if i<0 + then l + else if i=0 + then List.tl l + else + match l with + |(a::l1) -> + a::(aux l1 (i-1)) + |_ -> assert false + in + List.rev (aux (List.rev l) i) + +(* + lq = [cn+m+1 n+m ...cn+m+1 1] + lci=[[cn+1 n,...,cn1 1] + ... + [cn+m n+m-1,...,cn+m 1]] + + removes intermediate polynomials not useful to compute the last one. + *) + +let remove_zeros zero lci = + let n = List.length (List.hd lci) in + let m=List.length lci in + let u = Array.create m false in + let rec utiles k = + if k>=m + then () + else ( + u.(k)<-true; + let lc = List.nth lci k in + for i=0 to List.length lc - 1 do + if not (zero (List.nth lc i)) + then utiles (i+k+1); + done) + in utiles 0; + let lr = ref [] in + for i=0 to m-1 do + if u.(i) + then lr:=(List.nth lci i)::(!lr) + done; + let lr=List.rev !lr in + let lr = List.map + (fun lc -> + let lcr=ref lc in + for i=0 to m-1 do + if not u.(i) + then lcr:=remove_list_tail !lcr (m-i+(n-m)) + done; + !lcr) + lr in + info ("unuseful spolynomials: " + ^string_of_int (m-List.length lr)^"\n"); + info ("useful spolynomials: " + ^string_of_int (List.length lr)^"\n"); + lr + +let theoremedeszeros lpol p = + let t1 = Unix.gettimeofday() in + let m = !nvars in + let (lp0,p,cert) = in_ideal m lpol p in + let lpc = List.rev !poldepcontent in + info ("time: "^Format.sprintf "@[%10.3f@]s\n" (Unix.gettimeofday ()-.t1)); + (cert,lp0,p,lpc) + +open Ideal + +let theoremedeszeros_termes lp = + nvars:=0;(* mise a jour par term_pol_sparse *) + List.iter set_nvars_term lp; + match lp with + | Const (Int sugarparam)::Const (Int nparam)::lp -> + ((match sugarparam with + |0 -> info "calcul sans sugar\n"; + lexico:=false; + sugar_flag := false; + divide_rem_with_critical_pair := false + |1 -> info "calcul avec sugar\n"; + lexico:=false; + sugar_flag := true; + divide_rem_with_critical_pair := false + |2 -> info "ordre lexico calcul sans sugar\n"; + lexico:=true; + sugar_flag := false; + divide_rem_with_critical_pair := false + |3 -> info "ordre lexico calcul avec sugar\n"; + lexico:=true; + sugar_flag := true; + divide_rem_with_critical_pair := false + |4 -> info "calcul sans sugar, division par les paires\n"; + lexico:=false; + sugar_flag := false; + divide_rem_with_critical_pair := true + |5 -> info "calcul avec sugar, division par les paires\n"; + lexico:=false; + sugar_flag := true; + divide_rem_with_critical_pair := true + |6 -> info "ordre lexico calcul sans sugar, division par les paires\n"; + lexico:=true; + sugar_flag := false; + divide_rem_with_critical_pair := true + |7 -> info "ordre lexico calcul avec sugar, division par les paires\n"; + lexico:=true; + sugar_flag := true; + divide_rem_with_critical_pair := true + | _ -> error "nsatz: bad parameter" + ); + let m= !nvars in + let lvar=ref [] in + for i=m downto 1 do lvar:=["x"^(string_of_int i)^""]@(!lvar); done; + lvar:=["a";"b";"c";"d";"e";"f";"g";"h";"i";"j";"k";"l";"m";"n";"o";"p";"q";"r";"s";"t";"u";"v";"w";"x";"y";"z"] @ (!lvar); (* pour macaulay *) + name_var:=!lvar; + let lp = List.map (term_pol_sparse nparam) lp in + match lp with + | [] -> assert false + | p::lp1 -> + let lpol = List.rev lp1 in + let (cert,lp0,p,_lct) = theoremedeszeros lpol p in + let lc = cert.last_comb::List.rev cert.gb_comb in + match remove_zeros (fun x -> x=zeroP) lc with + | [] -> assert false + | (lq::lci) -> + (* lci commence par les nouveaux polynomes *) + let m= !nvars in + let c = pol_sparse_to_term m (polconst m cert.coef) in + let r = Pow(Zero,cert.power) in + let lci = List.rev lci in + let lci = List.map (List.map (pol_sparse_to_term m)) lci in + let lq = List.map (pol_sparse_to_term m) lq in + info ("nombre de parametres: "^string_of_int nparam^"\n"); + info "terme calcule\n"; + (c,r,lci,lq) + ) + |_ -> assert false + + +(* version avec hash-consing du certificat: +let nsatz lpol = + Hashtbl.clear Dansideal.hmon; + Hashtbl.clear Dansideal.coefpoldep; + Hashtbl.clear Dansideal.sugartbl; + Hashtbl.clear Polynomesrec.hcontentP; + init_constants (); + let lp= parse_request lpol in + let (_lp0,_p,c,r,_lci,_lq as rthz) = theoremedeszeros_termes lp in + let certif = certificat_vers_polynome_creux rthz in + let certif = hash_certif certif in + let certif = certif_term certif in + let c = mkt_term c in + info "constr calcule\n"; + (c, certif) +*) + +let nsatz lpol = + let lp= parse_request lpol in + let (c,r,lci,lq) = theoremedeszeros_termes lp in + let res = [c::r::lq]@lci in + let res = List.map (fun lx -> List.map mkt_term lx) res in + let res = + List.fold_right + (fun lt r -> + let ltterm = + List.fold_right + (fun t r -> + mkt_app lcons [mkt_app tpexpr [Lazy.force tz];t;r]) + lt + (mkt_app lnil [mkt_app tpexpr [Lazy.force tz]]) in + mkt_app lcons [tlp ();ltterm;r]) + res + (mkt_app lnil [tlp ()]) in + info "terme calcule\n"; + res + +let return_term t = + let a = + mkApp(gen_constant "CC" ["Init";"Logic"] "refl_equal",[|tllp ();t|]) in + generalize [a] + +let nsatz_compute t = + let lpol = + try nsatz t + with Ideal.NotInIdeal -> + error "nsatz cannot solve this problem" in + return_term lpol + +TACTIC EXTEND nsatz_compute +| [ "nsatz_compute" constr(lt) ] -> [ nsatz_compute lt ] +END + + diff --git a/plugins/nsatz/nsatz_plugin.mllib b/plugins/nsatz/nsatz_plugin.mllib new file mode 100644 index 00000000..a25e649d --- /dev/null +++ b/plugins/nsatz/nsatz_plugin.mllib @@ -0,0 +1,5 @@ +Utile +Polynom +Ideal +Nsatz +Nsatz_plugin_mod diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml new file mode 100644 index 00000000..14e279b5 --- /dev/null +++ b/plugins/nsatz/polynom.ml @@ -0,0 +1,679 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> bool + val lt : t -> t -> bool + val le : t -> t -> bool + val abs : t -> t + val plus : t -> t -> t + val mult : t -> t -> t + val sub : t -> t -> t + val opp : t -> t + val div : t -> t -> t + val modulo : t -> t -> t + val puis : t -> int -> t + val pgcd : t -> t -> t + + val hash : t -> int + val of_num : Num.num -> t + val to_string : t -> string +end + +module type S = sig + type coef + type variable = int + type t = Pint of coef | Prec of variable * t array + + val of_num : Num.num -> t + val x : variable -> t + val monome : variable -> int -> t + val is_constantP : t -> bool + val is_zero : t -> bool + + val max_var_pol : t -> variable + val max_var_pol2 : t -> variable + val max_var : t array -> variable + val equal : t -> t -> bool + val norm : t -> t + val deg : variable -> t -> int + val deg_total : t -> int + val copyP : t -> t + val coef : variable -> int -> t -> t + + val plusP : t -> t -> t + val content : t -> coef + val div_int : t -> coef -> t + val vire_contenu : t -> t + val vars : t -> variable list + val int_of_Pint : t -> coef + val multx : int -> variable -> t -> t + val multP : t -> t -> t + val deriv : variable -> t -> t + val oppP : t -> t + val moinsP : t -> t -> t + val puisP : t -> int -> t + val ( @@ ) : t -> t -> t + val ( -- ) : t -> t -> t + val ( ^^ ) : t -> int -> t + val coefDom : variable -> t -> t + val coefConst : variable -> t -> t + val remP : variable -> t -> t + val coef_int_tete : t -> coef + val normc : t -> t + val coef_constant : t -> coef + val univ : bool ref + val string_of_var : int -> string + val nsP : int ref + val to_string : t -> string + val printP : t -> unit + val print_tpoly : t array -> unit + val print_lpoly : t list -> unit + val quo_rem_pol : t -> t -> variable -> t * t + val div_pol : t -> t -> variable -> t + val divP : t -> t -> t + val div_pol_rat : t -> t -> bool + val pseudo_div : t -> t -> variable -> t * t * int * t + val pgcdP : t -> t -> t + val pgcd_pol : t -> t -> variable -> t + val content_pol : t -> variable -> t + val pgcd_coef_pol : t -> t -> variable -> t + val pgcd_pol_rec : t -> t -> variable -> t + val gcd_sub_res : t -> t -> variable -> t + val gcd_sub_res_rec : t -> t -> t -> t -> int -> variable -> t + val lazard_power : t -> t -> int -> variable -> t + val hash : t -> int + module Hashpol : Hashtbl.S with type key=t +end + +(*********************************************************************** + 2. Type of polynomials, operations. +*) +module Make (C:Coef) = struct + +type coef = C.t +let coef_of_int i = C.of_num (Num.Int i) +let coef0 = coef_of_int 0 +let coef1 = coef_of_int 1 + +type variable = int + +type t = + Pint of coef (* constant polynomial *) + | Prec of variable * (t array) (* coefficients, increasing degree *) + +(* by default, operations work with normalized polynomials: +- variables are positive integers +- coefficients of a polynomial in x only use variables < x +- no zero coefficient at beginning +- no Prec(x,a) where a is constant in x +*) + +(* constant polynomials *) +let of_num x = Pint (C.of_num x) +let cf0 = of_num (Num.Int 0) +let cf1 = of_num (Num.Int 1) + +(* nth variable *) +let x n = Prec (n,[|cf0;cf1|]) + +(* create v^n *) +let monome v n = + match n with + 0->Pint coef1; + |_->let tmp = Array.create (n+1) (Pint coef0) in + tmp.(n)<-(Pint coef1); + Prec (v, tmp) + +let is_constantP = function + Pint _ -> true + | Prec _ -> false + +let int_of_Pint = function + Pint x -> x + | _ -> failwith "non" + +let is_zero p = + match p with Pint n -> if C.equal n coef0 then true else false |_-> false + +let max_var_pol p = + match p with + Pint _ -> 0 + |Prec(x,_) -> x + +(* p not normalized *) +let rec max_var_pol2 p = + match p with + Pint _ -> 0 + |Prec(v,c)-> Array.fold_right (fun q m -> max (max_var_pol2 q) m) c v + +let rec max_var l = Array.fold_right (fun p m -> max (max_var_pol2 p) m) l 0 + +(* equality between polynomials *) + +let rec equal p q = + match (p,q) with + (Pint a,Pint b) -> C.equal a b + |(Prec(x,p1),Prec(y,q1)) -> + if x<>y then false + else if (Array.length p1)<>(Array.length q1) then false + else (try (Array.iteri (fun i a -> if not (equal a q1.(i)) + then failwith "raté") + p1; + true) + with _ -> false) + | (_,_) -> false + +(* normalize polynomial: remove head zeros, coefficients are normalized + if constant, returns the coefficient +*) + +let rec norm p = match p with + Pint _ -> p + |Prec (x,a)-> + let d = (Array.length a -1) in + let n = ref d in + while !n>0 && (equal a.(!n) (Pint coef0)) do + n:=!n-1; + done; + if !n<0 then Pint coef0 + else if !n=0 then a.(0) + else if !n=d then p + else (let b=Array.create (!n+1) (Pint coef0) in + for i=0 to !n do b.(i)<-a.(i);done; + Prec(x,b)) + + +(* degree in v, v >= max var of p *) +let rec deg v p = + match p with + Prec(x,p1) when x=v -> Array.length p1 -1 + |_ -> 0 + + +(* total degree *) +let rec deg_total p = + match p with + Prec (x,p1) -> let d = ref 0 in + Array.iteri (fun i q -> d:= (max !d (i+(deg_total q)))) p1; + !d + |_ -> 0 + +let rec copyP p = + match p with + Pint i -> Pint i + |Prec(x,q) -> Prec(x,Array.map copyP q) + +(* coefficient of degree i in v, v >= max var of p *) +let coef v i p = + match p with + Prec (x,p1) when x=v -> if i<(Array.length p1) then p1.(i) else Pint coef0 + |_ -> if i=0 then p else Pint coef0 + +(* addition *) + +let rec plusP p q = + let res = + (match (p,q) with + (Pint a,Pint b) -> Pint (C.plus a b) + |(Pint a, Prec (y,q1)) -> let q2=Array.map copyP q1 in + q2.(0)<- plusP p q1.(0); + Prec (y,q2) + |(Prec (x,p1),Pint b) -> let p2=Array.map copyP p1 in + p2.(0)<- plusP p1.(0) q; + Prec (x,p2) + |(Prec (x,p1),Prec (y,q1)) -> + if xy then (let p2=Array.map copyP p1 in + p2.(0)<- plusP p1.(0) q; + Prec (x,p2)) + else + (let n=max (deg x p) (deg x q) in + let r=Array.create (n+1) (Pint coef0) in + for i=0 to n do + r.(i)<- plusP (coef x i p) (coef x i q); + done; + Prec(x,r))) + in norm res + + +(* content, positive integer *) +let rec content p = + match p with + Pint a -> C.abs a + | Prec (x ,p1) -> + Array.fold_left C.pgcd coef0 (Array.map content p1) + +let rec div_int p a= + match p with + Pint b -> Pint (C.div b a) + | Prec(x,p1) -> Prec(x,Array.map (fun x -> div_int x a) p1) + +let vire_contenu p = + let c = content p in + if C.equal c coef0 then p else div_int p c + +(* sorted list of variables of a polynomial *) + +let rec vars=function + Pint _->[] + | Prec (x,l)->(List.flatten ([x]::(List.map vars (Array.to_list l)))) + + +(* multiply p by v^n, v >= max_var p *) +let rec multx n v p = + match p with + Prec (x,p1) when x=v -> let p2= Array.create ((Array.length p1)+n) (Pint coef0) in + for i=0 to (Array.length p1)-1 do + p2.(i+n)<-p1.(i); + done; + Prec (x,p2) + |_ -> if p = (Pint coef0) then (Pint coef0) + else (let p2=Array.create (n+1) (Pint coef0) in + p2.(n)<-p; + Prec (v,p2)) + + +(* product *) +let rec multP p q = + match (p,q) with + (Pint a,Pint b) -> Pint (C.mult a b) + |(Pint a, Prec (y,q1)) -> + if C.equal a coef0 then Pint coef0 + else let q2 = Array.map (fun z-> multP p z) q1 in + Prec (y,q2) + + |(Prec (x,p1), Pint b) -> + if C.equal b coef0 then Pint coef0 + else let p2 = Array.map (fun z-> multP z q) p1 in + Prec (x,p2) + |(Prec (x,p1), Prec(y,q1)) -> + if x multP p z) q1 in + Prec (y,q2)) + else if x>y + then (let p2 = Array.map (fun z-> multP z q) p1 in + Prec (x,p2)) + else Array.fold_left plusP (Pint coef0) + (Array.mapi (fun i z-> (multx i x (multP z q))) p1) + + + +(* derive p with variable v, v >= max_var p *) +let rec deriv v p = + match p with + Pint a -> Pint coef0 + | Prec(x,p1) when x=v -> + let d = Array.length p1 -1 in + if d=1 then p1.(1) + else + (let p2 = Array.create d (Pint coef0) in + for i=0 to d-1 do + p2.(i)<- multP (Pint (coef_of_int (i+1))) p1.(i+1); + done; + Prec (x,p2)) + | Prec(x,p1)-> Pint coef0 + + +(* opposite *) +let rec oppP p = + match p with + Pint a -> Pint (C.opp a) + |Prec(x,p1) -> Prec(x,Array.map oppP p1) + +let moinsP p q=plusP p (oppP q) + +let rec puisP p n = match n with + 0 -> cf1 + |_ -> (multP p (puisP p (n-1))) + + +(* infix notations *) +(*let (++) a b = plusP a b +*) +let (@@) a b = multP a b + +let (--) a b = moinsP a b + +let (^^) a b = puisP a b + + +(* leading coefficient in v, v>= max_var p *) + +let coefDom v p= coef v (deg v p) p + +let coefConst v p = coef v 0 p + +(* tail of a polynomial *) +let remP v p = + moinsP p (multP (coefDom v p) (puisP (x v) (deg v p))) + + +(* first interger coefficient of p *) +let rec coef_int_tete p = + let v = max_var_pol p in + if v>0 + then coef_int_tete (coefDom v p) + else (match p with | Pint a -> a |_ -> assert false) + + +(* divide by the content and make the head int coef positive *) +let normc p = + let p = vire_contenu p in + let a = coef_int_tete p in + if C.le coef0 a then p else oppP p + + +(* constant coef of normalized polynomial *) +let rec coef_constant p = + match p with + Pint a->a + |Prec(_,q)->coef_constant q.(0) + + +(*********************************************************************** + 3. Printing polynomials. +*) + +(* if univ = false, we use x,y,z,a,b,c,d... as variables, else x1,x2,... +*) +let univ=ref true + +let string_of_var x= + if !univ then + "u"^(string_of_int x) + else + if x<=3 then String.make 1 (Char.chr(x+(Char.code 'w'))) + else String.make 1 (Char.chr(x-4+(Char.code 'a'))) + +let nsP = ref 0 + +let rec string_of_Pcut p = + if (!nsP)<=0 + then "..." + else + match p with + |Pint a-> nsP:=(!nsP)-1; + if C.le coef0 a + then C.to_string a + else "("^(C.to_string a)^")" + |Prec (x,t)-> + let v=string_of_var x + and s=ref "" + and sp=ref "" in + let st0 = string_of_Pcut t.(0) in + if st0<>"0" + then s:=st0; + let fin = ref false in + for i=(Array.length t)-1 downto 1 do + if (!nsP)<0 + then (sp:="..."; + if not (!fin) then s:=(!s)^"+"^(!sp); + fin:=true) + else ( + let si=string_of_Pcut t.(i) in + sp:=""; + if i=1 + then ( + if si<>"0" + then (nsP:=(!nsP)-1; + if si="1" + then sp:=v + else + (if (String.contains si '+') + then sp:="("^si^")*"^v + else sp:=si^"*"^v))) + else ( + if si<>"0" + then (nsP:=(!nsP)-1; + if si="1" + then sp:=v^"^"^(string_of_int i) + else (if (String.contains si '+') + then sp:="("^si^")*"^v^"^"^(string_of_int i) + else sp:=si^"*"^v^"^"^(string_of_int i)))); + if !sp<>"" && not (!fin) + then (nsP:=(!nsP)-1; + if !s="" + then s:=!sp + else s:=(!s)^"+"^(!sp))); + done; + if !s="" then (nsP:=(!nsP)-1; + (s:="0")); + !s + +let to_string p = + nsP:=20; + string_of_Pcut p + +let printP p = Format.printf "@[%s@]" (to_string p) + +let print_tpoly lp = + let s = ref "\n{ " in + Array.iter (fun p -> s:=(!s)^(to_string p)^"\n") lp; + prt0 ((!s)^"}") + +let print_lpoly lp = print_tpoly (Array.of_list lp) + +(*********************************************************************** + 4. Exact division of polynomials. +*) + +(* return (s,r) s.t. p = s*q+r *) +let rec quo_rem_pol p q x = + if x=0 + then (match (p,q) with + |(Pint a, Pint b) -> + if C.equal (C.modulo a b) coef0 + then (Pint (C.div a b), cf0) + else failwith "div_pol1" + |_ -> assert false) + else + let m = deg x q in + let b = coefDom x q in + let q1 = remP x q in (* q = b*x^m+q1 *) + let r = ref p in + let s = ref cf0 in + let continue =ref true in + while (!continue) && (not (equal !r cf0)) do + let n = deg x !r in + if n false + +(*********************************************************************** + 5. Pseudo-division and gcd with subresultants. +*) + +(* pseudo division : + q = c*x^m+q1 + retruns (r,c,d,s) s.t. c^d*p = s*q + r. +*) + +let pseudo_div p q x = + match q with + Pint _ -> (cf0, q,1, p) + | Prec (v,q1) when x<>v -> (cf0, q,1, p) + | Prec (v,q1) -> + ( + (* pr "pseudo_division: c^d*p = s*q + r";*) + let delta = ref 0 in + let r = ref p in + let c = coefDom x q in + let q1 = remP x q in + let d' = deg x q in + let s = ref cf0 in + while (deg x !r)>=(deg x q) do + let d = deg x !r in + let a = coefDom x !r in + let r1=remP x !r in + let u = a @@ ((monome x (d-d'))) in + r:=(c @@ r1) -- (u @@ q1); + s:=plusP (c @@ (!s)) u; + delta := (!delta) + 1; + done; + (* + pr ("deg d: "^(string_of_int (!delta))^", deg c: "^(string_of_int (deg_total c))); + pr ("deg r:"^(string_of_int (deg_total !r))); + *) + (!r,c,!delta, !s) + ) + +(* gcd with subresultants *) + +let rec pgcdP p q = + let x = max (max_var_pol p) (max_var_pol q) in + pgcd_pol p q x + +and pgcd_pol p q x = + pgcd_pol_rec p q x + +and content_pol p x = + match p with + Prec(v,p1) when v=x -> + Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) cf0 p1 + | _ -> p + +and pgcd_coef_pol c p x = + match p with + Prec(v,p1) when x=v -> + Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) c p1 + |_ -> pgcd_pol_rec c p (x-1) + +and pgcd_pol_rec p q x = + match (p,q) with + (Pint a,Pint b) -> Pint (C.pgcd (C.abs a) (C.abs b)) + |_ -> + if equal p cf0 + then q + else if equal q cf0 + then p + else if (deg x q) = 0 + then pgcd_coef_pol q p x + else if (deg x p) = 0 + then pgcd_coef_pol p q x + else ( + let a = content_pol p x in + let b = content_pol q x in + let c = pgcd_pol_rec a b (x-1) in + pr (string_of_int x); + let p1 = div_pol p c x in + let q1 = div_pol q c x in + let r = gcd_sub_res p1 q1 x in + let cr = content_pol r x in + let res = c @@ (div_pol r cr x) in + res + ) + +(* Sub-résultants: + + ai*Ai = Qi*Ai+1 + bi*Ai+2 + + deg Ai+2 < deg Ai+1 + + Ai = ci*X^ni + ... + di = ni - ni+1 + + ai = (- ci+1)^(di + 1) + b1 = 1 + bi = ci*si^di si i>1 + + s1 = 1 + si+1 = ((ci+1)^di*si)/si^di + +*) +and gcd_sub_res p q x = + if equal q cf0 + then p + else + let d = deg x p in + let d' = deg x q in + if d (C.hash a) + | Prec (v,p) -> + Array.fold_right (fun q h -> h + hash q) p 0 + +module Hashpol = Hashtbl.Make( + struct + type poly = t + type t = poly + let equal = equal + let hash = hash + end) + +end diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli new file mode 100644 index 00000000..623d901e --- /dev/null +++ b/plugins/nsatz/polynom.mli @@ -0,0 +1,97 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t -> bool + val lt : t -> t -> bool + val le : t -> t -> bool + val abs : t -> t + val plus : t -> t -> t + val mult : t -> t -> t + val sub : t -> t -> t + val opp : t -> t + val div : t -> t -> t + val modulo : t -> t -> t + val puis : t -> int -> t + val pgcd : t -> t -> t + + val hash : t -> int + val of_num : Num.num -> t + val to_string : t -> string +end + +module type S = sig + type coef + type variable = int + type t = Pint of coef | Prec of variable * t array + + val of_num : Num.num -> t + val x : variable -> t + val monome : variable -> int -> t + val is_constantP : t -> bool + val is_zero : t -> bool + + val max_var_pol : t -> variable + val max_var_pol2 : t -> variable + val max_var : t array -> variable + val equal : t -> t -> bool + val norm : t -> t + val deg : variable -> t -> int + val deg_total : t -> int + val copyP : t -> t + val coef : variable -> int -> t -> t + + val plusP : t -> t -> t + val content : t -> coef + val div_int : t -> coef -> t + val vire_contenu : t -> t + val vars : t -> variable list + val int_of_Pint : t -> coef + val multx : int -> variable -> t -> t + val multP : t -> t -> t + val deriv : variable -> t -> t + val oppP : t -> t + val moinsP : t -> t -> t + val puisP : t -> int -> t + val ( @@ ) : t -> t -> t + val ( -- ) : t -> t -> t + val ( ^^ ) : t -> int -> t + val coefDom : variable -> t -> t + val coefConst : variable -> t -> t + val remP : variable -> t -> t + val coef_int_tete : t -> coef + val normc : t -> t + val coef_constant : t -> coef + val univ : bool ref + val string_of_var : int -> string + val nsP : int ref + val to_string : t -> string + val printP : t -> unit + val print_tpoly : t array -> unit + val print_lpoly : t list -> unit + val quo_rem_pol : t -> t -> variable -> t * t + val div_pol : t -> t -> variable -> t + val divP : t -> t -> t + val div_pol_rat : t -> t -> bool + val pseudo_div : t -> t -> variable -> t * t * int * t + val pgcdP : t -> t -> t + val pgcd_pol : t -> t -> variable -> t + val content_pol : t -> variable -> t + val pgcd_coef_pol : t -> t -> variable -> t + val pgcd_pol_rec : t -> t -> variable -> t + val gcd_sub_res : t -> t -> variable -> t + val gcd_sub_res_rec : t -> t -> t -> t -> int -> variable -> t + val lazard_power : t -> t -> int -> variable -> t + val hash : t -> int + module Hashpol : Hashtbl.S with type key=t +end + +module Make (C:Coef) : S with type coef = C.t diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml new file mode 100644 index 00000000..c16bd425 --- /dev/null +++ b/plugins/nsatz/utile.ml @@ -0,0 +1,130 @@ +(* Printing *) + +let pr x = + if !Flags.debug then (Format.printf "@[%s@]" x; flush(stdout);)else () + +let prn x = + if !Flags.debug then (Format.printf "@[%s\n@]" x; flush(stdout);) else () + +let prt0 s = () (* print_string s;flush(stdout)*) + +let prt s = + if !Flags.debug then (print_string (s^"\n");flush(stdout)) else () + +let info s = + Flags.if_verbose prerr_string s + +(* Lists *) + +let rec list_mem_eq eq x l = + match l with + [] -> false + |y::l1 -> if (eq x y) then true else (list_mem_eq eq x l1) + +let set_of_list_eq eq l = + let res = ref [] in + List.iter (fun x -> if not (list_mem_eq eq x (!res)) then res:=x::(!res)) l; + List.rev !res + + +(* Memoization + f is compatible with nf: f(nf(x)) = f(x) +*) + +let memos s memoire nf f x = + try (let v = Hashtbl.find memoire (nf x) in pr s;v) + with _ -> (pr "#"; + let v = f x in + Hashtbl.add memoire (nf x) v; + v) + + +(********************************************************************** + Eléments minimaux pour un ordre partiel de division. + E est un ensemble, avec une multiplication + et une division partielle div (la fonction div peut échouer), + constant est un prédicat qui définit un sous-ensemble C de E. +*) +(* + Etant donnée une partie A de E, on calcule une partie B de E disjointe de C + telle que: + - les éléments de A sont des produits d'éléments de B et d'un de C. + - B est minimale pour cette propriété. +*) + +let facteurs_liste div constant lp = + let lp = List.filter (fun x -> not (constant x)) lp in + let rec factor lmin lp = (* lmin: ne se divisent pas entre eux *) + match lp with + [] -> lmin + |p::lp1 -> + (let l1 = ref [] in + let p_dans_lmin = ref false in + List.iter (fun q -> try (let r = div p q in + if not (constant r) + then l1:=r::(!l1) + else p_dans_lmin:=true) + with _ -> ()) + lmin; + if !p_dans_lmin + then factor lmin lp1 + else if (!l1)=[] + (* aucun q de lmin ne divise p *) + then (let l1=ref lp1 in + let lmin1=ref [] in + List.iter (fun q -> try (let r = div q p in + if not (constant r) + then l1:=r::(!l1)) + with _ -> lmin1:=q::(!lmin1)) + lmin; + factor (List.rev (p::(!lmin1))) !l1) + (* au moins un q de lmin divise p non trivialement *) + else factor lmin ((!l1)@lp1)) + in + factor [] lp + + +(* On suppose que tout élément de A est produit d'éléments de B et d'un de C: + A et B sont deux tableaux, rend un tableau de couples + (élément de C, listes d'indices l) + tels que A.(i) = l.(i)_1*Produit(B.(j), j dans l.(i)_2) + zero est un prédicat sur E tel que (zero x) => (constant x): + si (zero x) est vrai on ne decompose pas x + c est un élément quelconque de E. +*) +let factorise_tableau div zero c f l1 = + let res = Array.create (Array.length f) (c,[]) in + Array.iteri (fun i p -> + let r = ref p in + let li = ref [] in + if not (zero p) + then + Array.iteri (fun j q -> + try (while true do + let rr = div !r q in + li:=j::(!li); + r:=rr; + done) + with _ -> ()) + l1; + res.(i)<-(!r,!li)) + f; + (l1,res) + + +(* exemples: + +let l = [1;2;6;24;720] +and div1 = (fun a b -> if a mod b =0 then a/b else failwith "div") +and constant = (fun x -> x<2) +and zero = (fun x -> x=0) + + +let f = facteurs_liste div1 constant l + + +factorise_tableau div1 zero 0 (Array.of_list l) (Array.of_list f) + +*) + + diff --git a/plugins/nsatz/utile.mli b/plugins/nsatz/utile.mli new file mode 100644 index 00000000..83b2ac39 --- /dev/null +++ b/plugins/nsatz/utile.mli @@ -0,0 +1,22 @@ + +(* Printing *) +val pr : string -> unit +val prn : string -> unit +val prt0 : 'a -> unit +val prt : string -> unit +val info : string -> unit + +(* Listes *) +val list_mem_eq : ('a -> 'b -> bool) -> 'a -> 'b list -> bool +val set_of_list_eq : ('a -> 'a -> bool) -> 'a list -> 'a list + +(* Memoization *) +val memos : + string -> ('a, 'b) Hashtbl.t -> ('c -> 'a) -> ('c -> 'b) -> 'c -> 'b + + +val facteurs_liste : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a list -> 'a list +val factorise_tableau : + ('a -> 'b -> 'a) -> + ('a -> bool) -> + 'a -> 'a array -> 'b array -> 'b array * ('a * int list) array diff --git a/plugins/nsatz/vo.itarget b/plugins/nsatz/vo.itarget new file mode 100644 index 00000000..4af4786d --- /dev/null +++ b/plugins/nsatz/vo.itarget @@ -0,0 +1,3 @@ +NsatzR.vo +Nsatz_domain.vo +NsatzZ.vo diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v new file mode 100644 index 00000000..30b94571 --- /dev/null +++ b/plugins/omega/Omega.v @@ -0,0 +1,59 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* nat) => abstract omega: zarith. +Hint Extern 10 (_ <= _) => abstract omega: zarith. +Hint Extern 10 (_ < _) => abstract omega: zarith. +Hint Extern 10 (_ >= _) => abstract omega: zarith. +Hint Extern 10 (_ > _) => abstract omega: zarith. + +Hint Extern 10 (_ <> _ :>nat) => abstract omega: zarith. +Hint Extern 10 (~ _ <= _) => abstract omega: zarith. +Hint Extern 10 (~ _ < _) => abstract omega: zarith. +Hint Extern 10 (~ _ >= _) => abstract omega: zarith. +Hint Extern 10 (~ _ > _) => abstract omega: zarith. + +Hint Extern 10 (_ = _ :>Z) => abstract omega: zarith. +Hint Extern 10 (_ <= _)%Z => abstract omega: zarith. +Hint Extern 10 (_ < _)%Z => abstract omega: zarith. +Hint Extern 10 (_ >= _)%Z => abstract omega: zarith. +Hint Extern 10 (_ > _)%Z => abstract omega: zarith. + +Hint Extern 10 (_ <> _ :>Z) => abstract omega: zarith. +Hint Extern 10 (~ (_ <= _)%Z) => abstract omega: zarith. +Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith. +Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith. +Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith. + +Hint Extern 10 False => abstract omega: zarith. \ No newline at end of file diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v new file mode 100644 index 00000000..56a854d6 --- /dev/null +++ b/plugins/omega/OmegaLemmas.v @@ -0,0 +1,302 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 0 <= x -> 0 <= y. +intros x y H; rewrite H; auto with arith. +Qed. + +Lemma OMEGA2 : forall x y : Z, 0 <= x -> 0 <= y -> 0 <= x + y. +exact Zplus_le_0_compat. +Qed. + +Lemma OMEGA3 : forall x y k : Z, k > 0 -> x = y * k -> x = 0 -> y = 0. + +intros x y k H1 H2 H3; apply (Zmult_integral_l k); + [ unfold not in |- *; intros H4; absurd (k > 0); + [ rewrite H4; unfold Zgt in |- *; simpl in |- *; discriminate + | assumption ] + | rewrite <- H2; assumption ]. +Qed. + +Lemma OMEGA4 : forall x y z : Z, x > 0 -> y > x -> z * y + x <> 0. + +unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0); + [ intros H4; cut (0 <= z * y + x); + [ intros H5; generalize (Zmult_le_approx y z x H4 H2 H5); intros H6; + absurd (z * y + x > 0); + [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate + | apply Zle_gt_trans with x; + [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x); + apply Zplus_le_compat_r; rewrite Zmult_comm; + generalize H4; unfold Zgt in |- *; case y; + [ simpl in |- *; intros H7; discriminate H7 + | intros p H7; rewrite <- (Zmult_0_r (Zpos p)); + unfold Zle in |- *; rewrite Zcompare_mult_compat; + exact H6 + | simpl in |- *; intros p H7; discriminate H7 ] + | assumption ] ] + | rewrite H3; unfold Zle in |- *; simpl in |- *; discriminate ] + | apply Zgt_trans with x; [ assumption | assumption ] ]. +Qed. + +Lemma OMEGA5 : forall x y z : Z, x = 0 -> y = 0 -> x + y * z = 0. + +intros x y z H1 H2; rewrite H1; rewrite H2; simpl in |- *; trivial with arith. +Qed. + +Lemma OMEGA6 : forall x y z : Z, 0 <= x -> y = 0 -> 0 <= x + y * z. + +intros x y z H1 H2; rewrite H2; simpl in |- *; rewrite Zplus_0_r; assumption. +Qed. + +Lemma OMEGA7 : + forall x y z t : Z, z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t. + +intros x y z t H1 H2 H3 H4; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat; + apply Zmult_gt_0_le_0_compat; assumption. +Qed. + +Lemma OMEGA8 : forall x y : Z, 0 <= x -> 0 <= y -> x = - y -> x = 0. + +intros x y H1 H2 H3; elim (Zle_lt_or_eq 0 x H1); + [ intros H4; absurd (0 < x); + [ change (0 >= x) in |- *; apply Zle_ge; apply Zplus_le_reg_l with y; + rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r; + assumption + | assumption ] + | intros H4; rewrite H4; trivial with arith ]. +Qed. + +Lemma OMEGA9 : forall x y z t : Z, y = 0 -> x = z -> y + (- x + z) * t = 0. + +intros x y z t H1 H2; rewrite H2; rewrite Zplus_opp_l; rewrite Zmult_0_l; + rewrite Zplus_0_r; assumption. +Qed. + +Lemma OMEGA10 : + forall v c1 c2 l1 l2 k1 k2 : Z, + (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = + v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). + +intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + rewrite (Zplus_permute (l1 * k1) (v * c2 * k2)); trivial with arith. +Qed. + +Lemma OMEGA11 : + forall v1 c1 l1 l2 k1 : Z, + (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). + +intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + trivial with arith. +Qed. + +Lemma OMEGA12 : + forall v2 c2 l1 l2 k2 : Z, + l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). + +intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + rewrite Zplus_permute; trivial with arith. +Qed. + +Lemma OMEGA13 : + forall (v l1 l2 : Z) (x : positive), + v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2. + +intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1); + rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r; + rewrite <- Zopp_neg; rewrite (Zplus_comm (- Zneg x) (Zneg x)); + rewrite Zplus_opp_r; rewrite Zmult_0_r; rewrite Zplus_0_r; + trivial with arith. +Qed. + +Lemma OMEGA14 : + forall (v l1 l2 : Z) (x : positive), + v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2. + +intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zneg x) l1); + rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r; + rewrite <- Zopp_neg; rewrite Zplus_opp_r; rewrite Zmult_0_r; + rewrite Zplus_0_r; trivial with arith. +Qed. +Lemma OMEGA15 : + forall v c1 c2 l1 l2 k2 : Z, + v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). + +intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + rewrite (Zplus_permute l1 (v * c2 * k2)); trivial with arith. +Qed. + +Lemma OMEGA16 : forall v c l k : Z, (v * c + l) * k = v * (c * k) + l * k. + +intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + trivial with arith. +Qed. + +Lemma OMEGA17 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0. + +unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; + apply Zplus_reg_l with (y * z); rewrite Zplus_comm; + rewrite H3; rewrite H2; auto with arith. +Qed. + +Lemma OMEGA18 : forall x y k : Z, x = y * k -> Zne x 0 -> Zne y 0. + +unfold Zne, not in |- *; intros x y k H1 H2 H3; apply H2; rewrite H1; + rewrite H3; auto with arith. +Qed. + +Lemma OMEGA19 : forall x : Z, Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1. + +unfold Zne in |- *; intros x H; elim (Zle_or_lt 0 x); + [ intros H1; elim Zle_lt_or_eq with (1 := H1); + [ intros H2; left; change (0 <= Zpred x) in |- *; apply Zsucc_le_reg; + rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption + | intros H2; absurd (x = 0); auto with arith ] + | intros H1; right; rewrite <- Zopp_eq_mult_neg_1; rewrite Zplus_comm; + apply Zle_left; apply Zsucc_le_reg; simpl in |- *; + apply Zlt_le_succ; auto with arith ]. +Qed. + +Lemma OMEGA20 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0. + +unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; rewrite H2 in H3; + simpl in H3; rewrite Zplus_0_r in H3; trivial with arith. +Qed. + +Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop) + (H : P (y + x)) := eq_ind_r P H (Zplus_comm x y). + +Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop) + (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p). + +Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) + (H : P (n + m + p)) := eq_ind_r P H (Zplus_assoc n m p). + +Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop) + (H : P (m + (n + p))) := eq_ind_r P H (Zplus_permute n m p). + +Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop) + (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) := + eq_ind_r P H (OMEGA10 v c1 c2 l1 l2 k1 k2). + +Definition fast_OMEGA11 (v1 c1 l1 l2 k1 : Z) (P : Z -> Prop) + (H : P (v1 * (c1 * k1) + (l1 * k1 + l2))) := + eq_ind_r P H (OMEGA11 v1 c1 l1 l2 k1). +Definition fast_OMEGA12 (v2 c2 l1 l2 k2 : Z) (P : Z -> Prop) + (H : P (v2 * (c2 * k2) + (l1 + l2 * k2))) := + eq_ind_r P H (OMEGA12 v2 c2 l1 l2 k2). + +Definition fast_OMEGA15 (v c1 c2 l1 l2 k2 : Z) (P : Z -> Prop) + (H : P (v * (c1 + c2 * k2) + (l1 + l2 * k2))) := + eq_ind_r P H (OMEGA15 v c1 c2 l1 l2 k2). +Definition fast_OMEGA16 (v c l k : Z) (P : Z -> Prop) + (H : P (v * (c * k) + l * k)) := eq_ind_r P H (OMEGA16 v c l k). + +Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) + (H : P (l1 + l2)) := eq_ind_r P H (OMEGA13 v l1 l2 x). + +Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) + (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x). +Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) + (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x). + +Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop) + (H : P (x * -1)) := eq_ind_r P H (Zopp_eq_mult_neg_1 x). + +Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop) + (H : P (y * x)) := eq_ind_r P H (Zmult_comm x y). + +Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop) + (H : P (- x + - y)) := eq_ind_r P H (Zopp_plus_distr x y). + +Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) := + eq_ind_r P H (Zopp_involutive x). + +Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) + (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y). + +Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop) + (H : P (n * p + m * p)) := eq_ind_r P H (Zmult_plus_distr_l n m p). +Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) + (H : P (x * - y)) := eq_ind_r P H (Zmult_opp_comm x y). + +Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop) + (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p). + +Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) + (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x). + +Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop) + (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor2 x y). + +Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop) + (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor3 x y). + +Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop) + (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z). + +Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) + (H : P y) := eq_ind_r P H (Zred_factor5 x y). + +Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) + (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x). diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v new file mode 100644 index 00000000..21535f0d --- /dev/null +++ b/plugins/omega/OmegaPlugin.v @@ -0,0 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* simpl (t a) in * + | _ => zify_unop_var_or_term t thm a + end. + +Ltac zify_unop_nored t thm a := + (* in this version, we don't try to reduce the unop (that can be (Zplus x)) *) + let isz := isZcst a in + match isz with + | true => zify_unop_core t thm a + | _ => zify_unop_var_or_term t thm a + end. + +Ltac zify_binop t thm a b:= + (* works as zify_unop, except that we should be careful when + dealing with b, since it can be equal to a *) + let isza := isZcst a in + match isza with + | true => zify_unop (t a) (thm a) b + | _ => + let za := fresh "z" in + (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || + (remember a as za; match goal with + | H : za = b |- _ => zify_unop_nored (t za) (thm za) za + | _ => zify_unop_nored (t za) (thm za) b + end) + end. + +Ltac zify_op_1 := + match goal with + | |- context [ Zmax ?a ?b ] => zify_binop Zmax Zmax_spec a b + | H : context [ Zmax ?a ?b ] |- _ => zify_binop Zmax Zmax_spec a b + | |- context [ Zmin ?a ?b ] => zify_binop Zmin Zmin_spec a b + | H : context [ Zmin ?a ?b ] |- _ => zify_binop Zmin Zmin_spec a b + | |- context [ Zsgn ?a ] => zify_unop Zsgn Zsgn_spec a + | H : context [ Zsgn ?a ] |- _ => zify_unop Zsgn Zsgn_spec a + | |- context [ Zabs ?a ] => zify_unop Zabs Zabs_spec a + | H : context [ Zabs ?a ] |- _ => zify_unop Zabs Zabs_spec a + end. + +Ltac zify_op := repeat zify_op_1. + + + + + +(** II) Conversion from nat to Z *) + + +Definition Z_of_nat' := Z_of_nat. + +Ltac hide_Z_of_nat t := + let z := fresh "z" in set (z:=Z_of_nat t) in *; + change Z_of_nat with Z_of_nat' in z; + unfold z in *; clear z. + +Ltac zify_nat_rel := + match goal with + (* I: equalities *) + | H : (@eq nat ?a ?b) |- _ => generalize (inj_eq _ _ H); clear H; intro H + | |- (@eq nat ?a ?b) => apply (inj_eq_rev a b) + | H : context [ @eq nat ?a ?b ] |- _ => rewrite (inj_eq_iff a b) in H + | |- context [ @eq nat ?a ?b ] => rewrite (inj_eq_iff a b) + (* II: less than *) + | H : (lt ?a ?b) |- _ => generalize (inj_lt _ _ H); clear H; intro H + | |- (lt ?a ?b) => apply (inj_lt_rev a b) + | H : context [ lt ?a ?b ] |- _ => rewrite (inj_lt_iff a b) in H + | |- context [ lt ?a ?b ] => rewrite (inj_lt_iff a b) + (* III: less or equal *) + | H : (le ?a ?b) |- _ => generalize (inj_le _ _ H); clear H; intro H + | |- (le ?a ?b) => apply (inj_le_rev a b) + | H : context [ le ?a ?b ] |- _ => rewrite (inj_le_iff a b) in H + | |- context [ le ?a ?b ] => rewrite (inj_le_iff a b) + (* IV: greater than *) + | H : (gt ?a ?b) |- _ => generalize (inj_gt _ _ H); clear H; intro H + | |- (gt ?a ?b) => apply (inj_gt_rev a b) + | H : context [ gt ?a ?b ] |- _ => rewrite (inj_gt_iff a b) in H + | |- context [ gt ?a ?b ] => rewrite (inj_gt_iff a b) + (* V: greater or equal *) + | H : (ge ?a ?b) |- _ => generalize (inj_ge _ _ H); clear H; intro H + | |- (ge ?a ?b) => apply (inj_ge_rev a b) + | H : context [ ge ?a ?b ] |- _ => rewrite (inj_ge_iff a b) in H + | |- context [ ge ?a ?b ] => rewrite (inj_ge_iff a b) + end. + +Ltac zify_nat_op := + match goal with + (* misc type conversions: positive/N/Z to nat *) + | H : context [ Z_of_nat (nat_of_P ?a) ] |- _ => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) in H + | |- context [ Z_of_nat (nat_of_P ?a) ] => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) + | H : context [ Z_of_nat (nat_of_N ?a) ] |- _ => rewrite (Z_of_nat_of_N a) in H + | |- context [ Z_of_nat (nat_of_N ?a) ] => rewrite (Z_of_nat_of_N a) + | H : context [ Z_of_nat (Zabs_nat ?a) ] |- _ => rewrite (inj_Zabs_nat a) in H + | |- context [ Z_of_nat (Zabs_nat ?a) ] => rewrite (inj_Zabs_nat a) + + (* plus -> Zplus *) + | H : context [ Z_of_nat (plus ?a ?b) ] |- _ => rewrite (inj_plus a b) in H + | |- context [ Z_of_nat (plus ?a ?b) ] => rewrite (inj_plus a b) + + (* min -> Zmin *) + | H : context [ Z_of_nat (min ?a ?b) ] |- _ => rewrite (inj_min a b) in H + | |- context [ Z_of_nat (min ?a ?b) ] => rewrite (inj_min a b) + + (* max -> Zmax *) + | H : context [ Z_of_nat (max ?a ?b) ] |- _ => rewrite (inj_max a b) in H + | |- context [ Z_of_nat (max ?a ?b) ] => rewrite (inj_max a b) + + (* minus -> Zmax (Zminus ... ...) 0 *) + | H : context [ Z_of_nat (minus ?a ?b) ] |- _ => rewrite (inj_minus a b) in H + | |- context [ Z_of_nat (minus ?a ?b) ] => rewrite (inj_minus a b) + + (* pred -> minus ... -1 -> Zmax (Zminus ... -1) 0 *) + | H : context [ Z_of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H + | |- context [ Z_of_nat (pred ?a) ] => rewrite (pred_of_minus a) + + (* mult -> Zmult and a positivity hypothesis *) + | H : context [ Z_of_nat (mult ?a ?b) ] |- _ => + let H:= fresh "H" in + assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in * + | |- context [ Z_of_nat (mult ?a ?b) ] => + let H:= fresh "H" in + assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in * + + (* O -> Z0 *) + | H : context [ Z_of_nat O ] |- _ => simpl (Z_of_nat O) in H + | |- context [ Z_of_nat O ] => simpl (Z_of_nat O) + + (* S -> number or Zsucc *) + | H : context [ Z_of_nat (S ?a) ] |- _ => + let isnat := isnatcst a in + match isnat with + | true => simpl (Z_of_nat (S a)) in H + | _ => rewrite (inj_S a) in H + end + | |- context [ Z_of_nat (S ?a) ] => + let isnat := isnatcst a in + match isnat with + | true => simpl (Z_of_nat (S a)) + | _ => rewrite (inj_S a) + end + + (* atoms of type nat : we add a positivity condition (if not already there) *) + | H : context [ Z_of_nat ?a ] |- _ => + match goal with + | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a + | H' : 0 <= Z_of_nat' a |- _ => fail + | _ => let H:= fresh "H" in + assert (H:=Zle_0_nat a); hide_Z_of_nat a + end + | |- context [ Z_of_nat ?a ] => + match goal with + | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a + | H' : 0 <= Z_of_nat' a |- _ => fail + | _ => let H:= fresh "H" in + assert (H:=Zle_0_nat a); hide_Z_of_nat a + end + end. + +Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. + + + + +(* III) conversion from positive to Z *) + +Definition Zpos' := Zpos. +Definition Zneg' := Zneg. + +Ltac hide_Zpos t := + let z := fresh "z" in set (z:=Zpos t) in *; + change Zpos with Zpos' in z; + unfold z in *; clear z. + +Ltac zify_positive_rel := + match goal with + (* I: equalities *) + | H : (@eq positive ?a ?b) |- _ => generalize (Zpos_eq _ _ H); clear H; intro H + | |- (@eq positive ?a ?b) => apply (Zpos_eq_rev a b) + | H : context [ @eq positive ?a ?b ] |- _ => rewrite (Zpos_eq_iff a b) in H + | |- context [ @eq positive ?a ?b ] => rewrite (Zpos_eq_iff a b) + (* II: less than *) + | H : context [ (?a change (a change (a change (a<=b)%positive with (Zpos a<=Zpos b) in H + | |- context [ (?a<=?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b) + (* IV: greater than *) + | H : context [ (?a>?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H + | |- context [ (?a>?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b) + (* V: greater or equal *) + | H : context [ (?a>=?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H + | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) + end. + +Ltac zify_positive_op := + match goal with + (* Zneg -> -Zpos (except for numbers) *) + | H : context [ Zneg ?a ] |- _ => + let isp := isPcst a in + match isp with + | true => change (Zneg a) with (Zneg' a) in H + | _ => change (Zneg a) with (- Zpos a) in H + end + | |- context [ Zneg ?a ] => + let isp := isPcst a in + match isp with + | true => change (Zneg a) with (Zneg' a) + | _ => change (Zneg a) with (- Zpos a) + end + + (* misc type conversions: nat to positive *) + | H : context [ Zpos (P_of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H + | |- context [ Zpos (P_of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) + + (* Pplus -> Zplus *) + | H : context [ Zpos (Pplus ?a ?b) ] |- _ => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) in H + | |- context [ Zpos (Pplus ?a ?b) ] => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) + + (* Pmin -> Zmin *) + | H : context [ Zpos (Pmin ?a ?b) ] |- _ => rewrite (Zpos_min a b) in H + | |- context [ Zpos (Pmin ?a ?b) ] => rewrite (Zpos_min a b) + + (* Pmax -> Zmax *) + | H : context [ Zpos (Pmax ?a ?b) ] |- _ => rewrite (Zpos_max a b) in H + | |- context [ Zpos (Pmax ?a ?b) ] => rewrite (Zpos_max a b) + + (* Pminus -> Zmax 1 (Zminus ... ...) *) + | H : context [ Zpos (Pminus ?a ?b) ] |- _ => rewrite (Zpos_minus a b) in H + | |- context [ Zpos (Pminus ?a ?b) ] => rewrite (Zpos_minus a b) + + (* Psucc -> Zsucc *) + | H : context [ Zpos (Psucc ?a) ] |- _ => rewrite (Zpos_succ_morphism a) in H + | |- context [ Zpos (Psucc ?a) ] => rewrite (Zpos_succ_morphism a) + + (* Ppred -> Pminus ... -1 -> Zmax 1 (Zminus ... - 1) *) + | H : context [ Zpos (Ppred ?a) ] |- _ => rewrite (Ppred_minus a) in H + | |- context [ Zpos (Ppred ?a) ] => rewrite (Ppred_minus a) + + (* Pmult -> Zmult and a positivity hypothesis *) + | H : context [ Zpos (Pmult ?a ?b) ] |- _ => + let H:= fresh "H" in + assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in * + | |- context [ Zpos (Pmult ?a ?b) ] => + let H:= fresh "H" in + assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in * + + (* xO *) + | H : context [ Zpos (xO ?a) ] |- _ => + let isp := isPcst a in + match isp with + | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H + | _ => rewrite (Zpos_xO a) in H + end + | |- context [ Zpos (xO ?a) ] => + let isp := isPcst a in + match isp with + | true => change (Zpos (xO a)) with (Zpos' (xO a)) + | _ => rewrite (Zpos_xO a) + end + (* xI *) + | H : context [ Zpos (xI ?a) ] |- _ => + let isp := isPcst a in + match isp with + | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H + | _ => rewrite (Zpos_xI a) in H + end + | |- context [ Zpos (xI ?a) ] => + let isp := isPcst a in + match isp with + | true => change (Zpos (xI a)) with (Zpos' (xI a)) + | _ => rewrite (Zpos_xI a) + end + + (* xI : nothing to do, just prevent adding a useless positivity condition *) + | H : context [ Zpos xH ] |- _ => hide_Zpos xH + | |- context [ Zpos xH ] => hide_Zpos xH + + (* atoms of type positive : we add a positivity condition (if not already there) *) + | H : context [ Zpos ?a ] |- _ => + match goal with + | H' : Zpos a > 0 |- _ => hide_Zpos a + | H' : Zpos' a > 0 |- _ => fail + | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a + end + | |- context [ Zpos ?a ] => + match goal with + | H' : Zpos a > 0 |- _ => hide_Zpos a + | H' : Zpos' a > 0 |- _ => fail + | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a + end + end. + +Ltac zify_positive := + repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *. + + + + + +(* IV) conversion from N to Z *) + +Definition Z_of_N' := Z_of_N. + +Ltac hide_Z_of_N t := + let z := fresh "z" in set (z:=Z_of_N t) in *; + change Z_of_N with Z_of_N' in z; + unfold z in *; clear z. + +Ltac zify_N_rel := + match goal with + (* I: equalities *) + | H : (@eq N ?a ?b) |- _ => generalize (Z_of_N_eq _ _ H); clear H; intro H + | |- (@eq N ?a ?b) => apply (Z_of_N_eq_rev a b) + | H : context [ @eq N ?a ?b ] |- _ => rewrite (Z_of_N_eq_iff a b) in H + | |- context [ @eq N ?a ?b ] => rewrite (Z_of_N_eq_iff a b) + (* II: less than *) + | H : (?a generalize (Z_of_N_lt _ _ H); clear H; intro H + | |- (?a apply (Z_of_N_lt_rev a b) + | H : context [ (?a rewrite (Z_of_N_lt_iff a b) in H + | |- context [ (?a rewrite (Z_of_N_lt_iff a b) + (* III: less or equal *) + | H : (?a<=?b)%N |- _ => generalize (Z_of_N_le _ _ H); clear H; intro H + | |- (?a<=?b)%N => apply (Z_of_N_le_rev a b) + | H : context [ (?a<=?b)%N ] |- _ => rewrite (Z_of_N_le_iff a b) in H + | |- context [ (?a<=?b)%N ] => rewrite (Z_of_N_le_iff a b) + (* IV: greater than *) + | H : (?a>?b)%N |- _ => generalize (Z_of_N_gt _ _ H); clear H; intro H + | |- (?a>?b)%N => apply (Z_of_N_gt_rev a b) + | H : context [ (?a>?b)%N ] |- _ => rewrite (Z_of_N_gt_iff a b) in H + | |- context [ (?a>?b)%N ] => rewrite (Z_of_N_gt_iff a b) + (* V: greater or equal *) + | H : (?a>=?b)%N |- _ => generalize (Z_of_N_ge _ _ H); clear H; intro H + | |- (?a>=?b)%N => apply (Z_of_N_ge_rev a b) + | H : context [ (?a>=?b)%N ] |- _ => rewrite (Z_of_N_ge_iff a b) in H + | |- context [ (?a>=?b)%N ] => rewrite (Z_of_N_ge_iff a b) + end. + +Ltac zify_N_op := + match goal with + (* misc type conversions: nat to positive *) + | H : context [ Z_of_N (N_of_nat ?a) ] |- _ => rewrite (Z_of_N_of_nat a) in H + | |- context [ Z_of_N (N_of_nat ?a) ] => rewrite (Z_of_N_of_nat a) + | H : context [ Z_of_N (Zabs_N ?a) ] |- _ => rewrite (Z_of_N_abs a) in H + | |- context [ Z_of_N (Zabs_N ?a) ] => rewrite (Z_of_N_abs a) + | H : context [ Z_of_N (Npos ?a) ] |- _ => rewrite (Z_of_N_pos a) in H + | |- context [ Z_of_N (Npos ?a) ] => rewrite (Z_of_N_pos a) + | H : context [ Z_of_N N0 ] |- _ => change (Z_of_N N0) with Z0 in H + | |- context [ Z_of_N N0 ] => change (Z_of_N N0) with Z0 + + (* Nplus -> Zplus *) + | H : context [ Z_of_N (Nplus ?a ?b) ] |- _ => rewrite (Z_of_N_plus a b) in H + | |- context [ Z_of_N (Nplus ?a ?b) ] => rewrite (Z_of_N_plus a b) + + (* Nmin -> Zmin *) + | H : context [ Z_of_N (Nmin ?a ?b) ] |- _ => rewrite (Z_of_N_min a b) in H + | |- context [ Z_of_N (Nmin ?a ?b) ] => rewrite (Z_of_N_min a b) + + (* Nmax -> Zmax *) + | H : context [ Z_of_N (Nmax ?a ?b) ] |- _ => rewrite (Z_of_N_max a b) in H + | |- context [ Z_of_N (Nmax ?a ?b) ] => rewrite (Z_of_N_max a b) + + (* Nminus -> Zmax 0 (Zminus ... ...) *) + | H : context [ Z_of_N (Nminus ?a ?b) ] |- _ => rewrite (Z_of_N_minus a b) in H + | |- context [ Z_of_N (Nminus ?a ?b) ] => rewrite (Z_of_N_minus a b) + + (* Nsucc -> Zsucc *) + | H : context [ Z_of_N (Nsucc ?a) ] |- _ => rewrite (Z_of_N_succ a) in H + | |- context [ Z_of_N (Nsucc ?a) ] => rewrite (Z_of_N_succ a) + + (* Nmult -> Zmult and a positivity hypothesis *) + | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ => + let H:= fresh "H" in + assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in * + | |- context [ Z_of_N (Nmult ?a ?b) ] => + let H:= fresh "H" in + assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in * + + (* atoms of type N : we add a positivity condition (if not already there) *) + | H : context [ Z_of_N ?a ] |- _ => + match goal with + | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a + | H' : 0 <= Z_of_N' a |- _ => fail + | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a + end + | |- context [ Z_of_N ?a ] => + match goal with + | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a + | H' : 0 <= Z_of_N' a |- _ => fail + | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a + end + end. + +Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. + + + +(** The complete Z-ification tactic *) + +Ltac zify := + repeat progress (zify_nat; zify_positive; zify_N); zify_op. + diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml new file mode 100644 index 00000000..60616845 --- /dev/null +++ b/plugins/omega/coq_omega.ml @@ -0,0 +1,1823 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s) + +let new_identifier_state = + let cpt = ref 0 in + (fun () -> let s = make_ident "State" (Some !cpt) in incr cpt; s) + +let new_identifier_var = + let cpt = ref 0 in + (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s) + +let new_id = + let cpt = ref 0 in fun () -> incr cpt; !cpt + +let new_var_num = + let cpt = ref 1000 in (fun () -> incr cpt; !cpt) + +let new_var = + let cpt = ref 0 in fun () -> incr cpt; Nameops.make_ident "WW" (Some !cpt) + +let display_var i = Printf.sprintf "X%d" i + +let intern_id,unintern_id = + let cpt = ref 0 in + let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in + (fun (name : identifier) -> + try Hashtbl.find table name with Not_found -> + let idx = !cpt in + Hashtbl.add table name idx; + Hashtbl.add co_table idx name; + incr cpt; idx), + (fun idx -> + try Hashtbl.find co_table idx with Not_found -> + let v = new_var () in + Hashtbl.add table v idx; Hashtbl.add co_table idx v; v) + +let mk_then = tclTHENLIST + +let exists_tac c = constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [c]) + +let generalize_tac t = generalize_time (generalize t) +let elim t = elim_time (simplest_elim t) +let exact t = exact_time (Tactics.refine t) +let unfold s = Tactics.unfold_in_concl [all_occurrences, Lazy.force s] + +let rev_assoc k = + let rec loop = function + | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l + in + loop + +let tag_hypothesis,tag_of_hyp, hyp_of_tag = + let l = ref ([]:(identifier * int) list) in + (fun h id -> l := (h,id):: !l), + (fun h -> try List.assoc h !l with Not_found -> failwith "tag_hypothesis"), + (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis") + +let hide_constr,find_constr,clear_tables,dump_tables = + let l = ref ([]:(constr * (identifier * identifier * bool)) list) in + (fun h id eg b -> l := (h,(id,eg,b)):: !l), + (fun h -> try List.assoc h !l with Not_found -> failwith "find_contr"), + (fun () -> l := []), + (fun () -> !l) + +(* Lazy evaluation is used for Coq constants, because this code + is evaluated before the compiled modules are loaded. + To use the constant Zplus, one must type "Lazy.force coq_Zplus" + This is the right way to access to Coq constants in tactics ML code *) + +open Coqlib + +let logic_dir = ["Coq";"Logic";"Decidable"] +let coq_modules = + init_modules @arith_modules @ [logic_dir] @ zarith_base_modules + @ [["Coq"; "omega"; "OmegaLemmas"]] + +let init_constant = gen_constant_in_modules "Omega" init_modules +let constant = gen_constant_in_modules "Omega" coq_modules + +(* Zarith *) +let coq_xH = lazy (constant "xH") +let coq_xO = lazy (constant "xO") +let coq_xI = lazy (constant "xI") +let coq_Z0 = lazy (constant "Z0") +let coq_Zpos = lazy (constant "Zpos") +let coq_Zneg = lazy (constant "Zneg") +let coq_Z = lazy (constant "Z") +let coq_comparison = lazy (constant "comparison") +let coq_Gt = lazy (constant "Gt") +let coq_Zplus = lazy (constant "Zplus") +let coq_Zmult = lazy (constant "Zmult") +let coq_Zopp = lazy (constant "Zopp") +let coq_Zminus = lazy (constant "Zminus") +let coq_Zsucc = lazy (constant "Zsucc") +let coq_Zgt = lazy (constant "Zgt") +let coq_Zle = lazy (constant "Zle") +let coq_Z_of_nat = lazy (constant "Z_of_nat") +let coq_inj_plus = lazy (constant "inj_plus") +let coq_inj_mult = lazy (constant "inj_mult") +let coq_inj_minus1 = lazy (constant "inj_minus1") +let coq_inj_minus2 = lazy (constant "inj_minus2") +let coq_inj_S = lazy (constant "inj_S") +let coq_inj_le = lazy (constant "inj_le") +let coq_inj_lt = lazy (constant "inj_lt") +let coq_inj_ge = lazy (constant "inj_ge") +let coq_inj_gt = lazy (constant "inj_gt") +let coq_inj_neq = lazy (constant "inj_neq") +let coq_inj_eq = lazy (constant "inj_eq") +let coq_fast_Zplus_assoc_reverse = lazy (constant "fast_Zplus_assoc_reverse") +let coq_fast_Zplus_assoc = lazy (constant "fast_Zplus_assoc") +let coq_fast_Zmult_assoc_reverse = lazy (constant "fast_Zmult_assoc_reverse") +let coq_fast_Zplus_permute = lazy (constant "fast_Zplus_permute") +let coq_fast_Zplus_comm = lazy (constant "fast_Zplus_comm") +let coq_fast_Zmult_comm = lazy (constant "fast_Zmult_comm") +let coq_Zmult_le_approx = lazy (constant "Zmult_le_approx") +let coq_OMEGA1 = lazy (constant "OMEGA1") +let coq_OMEGA2 = lazy (constant "OMEGA2") +let coq_OMEGA3 = lazy (constant "OMEGA3") +let coq_OMEGA4 = lazy (constant "OMEGA4") +let coq_OMEGA5 = lazy (constant "OMEGA5") +let coq_OMEGA6 = lazy (constant "OMEGA6") +let coq_OMEGA7 = lazy (constant "OMEGA7") +let coq_OMEGA8 = lazy (constant "OMEGA8") +let coq_OMEGA9 = lazy (constant "OMEGA9") +let coq_fast_OMEGA10 = lazy (constant "fast_OMEGA10") +let coq_fast_OMEGA11 = lazy (constant "fast_OMEGA11") +let coq_fast_OMEGA12 = lazy (constant "fast_OMEGA12") +let coq_fast_OMEGA13 = lazy (constant "fast_OMEGA13") +let coq_fast_OMEGA14 = lazy (constant "fast_OMEGA14") +let coq_fast_OMEGA15 = lazy (constant "fast_OMEGA15") +let coq_fast_OMEGA16 = lazy (constant "fast_OMEGA16") +let coq_OMEGA17 = lazy (constant "OMEGA17") +let coq_OMEGA18 = lazy (constant "OMEGA18") +let coq_OMEGA19 = lazy (constant "OMEGA19") +let coq_OMEGA20 = lazy (constant "OMEGA20") +let coq_fast_Zred_factor0 = lazy (constant "fast_Zred_factor0") +let coq_fast_Zred_factor1 = lazy (constant "fast_Zred_factor1") +let coq_fast_Zred_factor2 = lazy (constant "fast_Zred_factor2") +let coq_fast_Zred_factor3 = lazy (constant "fast_Zred_factor3") +let coq_fast_Zred_factor4 = lazy (constant "fast_Zred_factor4") +let coq_fast_Zred_factor5 = lazy (constant "fast_Zred_factor5") +let coq_fast_Zred_factor6 = lazy (constant "fast_Zred_factor6") +let coq_fast_Zmult_plus_distr_l = lazy (constant "fast_Zmult_plus_distr_l") +let coq_fast_Zmult_opp_comm = lazy (constant "fast_Zmult_opp_comm") +let coq_fast_Zopp_plus_distr = lazy (constant "fast_Zopp_plus_distr") +let coq_fast_Zopp_mult_distr_r = lazy (constant "fast_Zopp_mult_distr_r") +let coq_fast_Zopp_eq_mult_neg_1 = lazy (constant "fast_Zopp_eq_mult_neg_1") +let coq_fast_Zopp_involutive = lazy (constant "fast_Zopp_involutive") +let coq_Zegal_left = lazy (constant "Zegal_left") +let coq_Zne_left = lazy (constant "Zne_left") +let coq_Zlt_left = lazy (constant "Zlt_left") +let coq_Zge_left = lazy (constant "Zge_left") +let coq_Zgt_left = lazy (constant "Zgt_left") +let coq_Zle_left = lazy (constant "Zle_left") +let coq_new_var = lazy (constant "new_var") +let coq_intro_Z = lazy (constant "intro_Z") + +let coq_dec_eq = lazy (constant "dec_eq") +let coq_dec_Zne = lazy (constant "dec_Zne") +let coq_dec_Zle = lazy (constant "dec_Zle") +let coq_dec_Zlt = lazy (constant "dec_Zlt") +let coq_dec_Zgt = lazy (constant "dec_Zgt") +let coq_dec_Zge = lazy (constant "dec_Zge") + +let coq_not_Zeq = lazy (constant "not_Zeq") +let coq_Znot_le_gt = lazy (constant "Znot_le_gt") +let coq_Znot_lt_ge = lazy (constant "Znot_lt_ge") +let coq_Znot_ge_lt = lazy (constant "Znot_ge_lt") +let coq_Znot_gt_le = lazy (constant "Znot_gt_le") +let coq_neq = lazy (constant "neq") +let coq_Zne = lazy (constant "Zne") +let coq_Zle = lazy (constant "Zle") +let coq_Zgt = lazy (constant "Zgt") +let coq_Zge = lazy (constant "Zge") +let coq_Zlt = lazy (constant "Zlt") + +(* Peano/Datatypes *) +let coq_le = lazy (init_constant "le") +let coq_lt = lazy (init_constant "lt") +let coq_ge = lazy (init_constant "ge") +let coq_gt = lazy (init_constant "gt") +let coq_minus = lazy (init_constant "minus") +let coq_plus = lazy (init_constant "plus") +let coq_mult = lazy (init_constant "mult") +let coq_pred = lazy (init_constant "pred") +let coq_nat = lazy (init_constant "nat") +let coq_S = lazy (init_constant "S") +let coq_O = lazy (init_constant "O") + +(* Compare_dec/Peano_dec/Minus *) +let coq_pred_of_minus = lazy (constant "pred_of_minus") +let coq_le_gt_dec = lazy (constant "le_gt_dec") +let coq_dec_eq_nat = lazy (constant "dec_eq_nat") +let coq_dec_le = lazy (constant "dec_le") +let coq_dec_lt = lazy (constant "dec_lt") +let coq_dec_ge = lazy (constant "dec_ge") +let coq_dec_gt = lazy (constant "dec_gt") +let coq_not_eq = lazy (constant "not_eq") +let coq_not_le = lazy (constant "not_le") +let coq_not_lt = lazy (constant "not_lt") +let coq_not_ge = lazy (constant "not_ge") +let coq_not_gt = lazy (constant "not_gt") + +(* Logic/Decidable *) +let coq_eq_ind_r = lazy (constant "eq_ind_r") + +let coq_dec_or = lazy (constant "dec_or") +let coq_dec_and = lazy (constant "dec_and") +let coq_dec_imp = lazy (constant "dec_imp") +let coq_dec_iff = lazy (constant "dec_iff") +let coq_dec_not = lazy (constant "dec_not") +let coq_dec_False = lazy (constant "dec_False") +let coq_dec_not_not = lazy (constant "dec_not_not") +let coq_dec_True = lazy (constant "dec_True") + +let coq_not_or = lazy (constant "not_or") +let coq_not_and = lazy (constant "not_and") +let coq_not_imp = lazy (constant "not_imp") +let coq_not_iff = lazy (constant "not_iff") +let coq_not_not = lazy (constant "not_not") +let coq_imp_simp = lazy (constant "imp_simp") +let coq_iff = lazy (constant "iff") + +(* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) + +(* For unfold *) +open Closure +let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with + | Const kn when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> + EvalConstRef kn + | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant") + +let sp_Zsucc = lazy (evaluable_ref_of_constr "Zsucc" coq_Zsucc) +let sp_Zminus = lazy (evaluable_ref_of_constr "Zminus" coq_Zminus) +let sp_Zle = lazy (evaluable_ref_of_constr "Zle" coq_Zle) +let sp_Zgt = lazy (evaluable_ref_of_constr "Zgt" coq_Zgt) +let sp_Zge = lazy (evaluable_ref_of_constr "Zge" coq_Zge) +let sp_Zlt = lazy (evaluable_ref_of_constr "Zlt" coq_Zlt) +let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ()))) + +let mk_var v = mkVar (id_of_string v) +let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) +let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) +let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) +let mk_eq t1 t2 = mkApp (build_coq_eq (), [| Lazy.force coq_Z; t1; t2 |]) +let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |]) +let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) +let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) +let mk_and t1 t2 = mkApp (build_coq_and (), [| t1; t2 |]) +let mk_or t1 t2 = mkApp (build_coq_or (), [| t1; t2 |]) +let mk_not t = mkApp (build_coq_not (), [| t |]) +let mk_eq_rel t1 t2 = mkApp (build_coq_eq (), + [| Lazy.force coq_comparison; t1; t2 |]) +let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) + +let mk_integer n = + let rec loop n = + if n =? one then Lazy.force coq_xH else + mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI), + [| loop (n/two) |]) + in + if n =? zero then Lazy.force coq_Z0 + else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg), + [| loop (abs n) |]) + +type omega_constant = + | Zplus | Zmult | Zminus | Zsucc | Zopp + | Plus | Mult | Minus | Pred | S | O + | Zpos | Zneg | Z0 | Z_of_nat + | Eq | Neq + | Zne | Zle | Zlt | Zge | Zgt + | Z | Nat + | And | Or | False | True | Not | Iff + | Le | Lt | Ge | Gt + | Other of string + +type omega_proposition = + | Keq of constr * constr * constr + | Kn + +type result = + | Kvar of identifier + | Kapp of omega_constant * constr list + | Kimp of constr * constr + | Kufo + +let destructurate_prop t = + let c, args = decompose_app t in + match kind_of_term c, args with + | _, [_;_;_] when c = build_coq_eq () -> Kapp (Eq,args) + | _, [_;_] when c = Lazy.force coq_neq -> Kapp (Neq,args) + | _, [_;_] when c = Lazy.force coq_Zne -> Kapp (Zne,args) + | _, [_;_] when c = Lazy.force coq_Zle -> Kapp (Zle,args) + | _, [_;_] when c = Lazy.force coq_Zlt -> Kapp (Zlt,args) + | _, [_;_] when c = Lazy.force coq_Zge -> Kapp (Zge,args) + | _, [_;_] when c = Lazy.force coq_Zgt -> Kapp (Zgt,args) + | _, [_;_] when c = build_coq_and () -> Kapp (And,args) + | _, [_;_] when c = build_coq_or () -> Kapp (Or,args) + | _, [_;_] when c = Lazy.force coq_iff -> Kapp (Iff, args) + | _, [_] when c = build_coq_not () -> Kapp (Not,args) + | _, [] when c = build_coq_False () -> Kapp (False,args) + | _, [] when c = build_coq_True () -> Kapp (True,args) + | _, [_;_] when c = Lazy.force coq_le -> Kapp (Le,args) + | _, [_;_] when c = Lazy.force coq_lt -> Kapp (Lt,args) + | _, [_;_] when c = Lazy.force coq_ge -> Kapp (Ge,args) + | _, [_;_] when c = Lazy.force coq_gt -> Kapp (Gt,args) + | Const sp, args -> + Kapp (Other (string_of_id (basename_of_global (ConstRef sp))),args) + | Construct csp , args -> + Kapp (Other (string_of_id (basename_of_global (ConstructRef csp))), args) + | Ind isp, args -> + Kapp (Other (string_of_id (basename_of_global (IndRef isp))),args) + | Var id,[] -> Kvar id + | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) + | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal" + | _ -> Kufo + +let destructurate_type t = + let c, args = decompose_app t in + match kind_of_term c, args with + | _, [] when c = Lazy.force coq_Z -> Kapp (Z,args) + | _, [] when c = Lazy.force coq_nat -> Kapp (Nat,args) + | _ -> Kufo + +let destructurate_term t = + let c, args = decompose_app t in + match kind_of_term c, args with + | _, [_;_] when c = Lazy.force coq_Zplus -> Kapp (Zplus,args) + | _, [_;_] when c = Lazy.force coq_Zmult -> Kapp (Zmult,args) + | _, [_;_] when c = Lazy.force coq_Zminus -> Kapp (Zminus,args) + | _, [_] when c = Lazy.force coq_Zsucc -> Kapp (Zsucc,args) + | _, [_] when c = Lazy.force coq_Zopp -> Kapp (Zopp,args) + | _, [_;_] when c = Lazy.force coq_plus -> Kapp (Plus,args) + | _, [_;_] when c = Lazy.force coq_mult -> Kapp (Mult,args) + | _, [_;_] when c = Lazy.force coq_minus -> Kapp (Minus,args) + | _, [_] when c = Lazy.force coq_pred -> Kapp (Pred,args) + | _, [_] when c = Lazy.force coq_S -> Kapp (S,args) + | _, [] when c = Lazy.force coq_O -> Kapp (O,args) + | _, [_] when c = Lazy.force coq_Zpos -> Kapp (Zneg,args) + | _, [_] when c = Lazy.force coq_Zneg -> Kapp (Zpos,args) + | _, [] when c = Lazy.force coq_Z0 -> Kapp (Z0,args) + | _, [_] when c = Lazy.force coq_Z_of_nat -> Kapp (Z_of_nat,args) + | Var id,[] -> Kvar id + | _ -> Kufo + +let recognize_number t = + let rec loop t = + match decompose_app t with + | f, [t] when f = Lazy.force coq_xI -> one + two * loop t + | f, [t] when f = Lazy.force coq_xO -> two * loop t + | f, [] when f = Lazy.force coq_xH -> one + | _ -> failwith "not a number" + in + match decompose_app t with + | f, [t] when f = Lazy.force coq_Zpos -> loop t + | f, [t] when f = Lazy.force coq_Zneg -> neg (loop t) + | f, [] when f = Lazy.force coq_Z0 -> zero + | _ -> failwith "not a number" + +type constr_path = + | P_APP of int + (* Abstraction and product *) + | P_BODY + | P_TYPE + (* Case *) + | P_BRANCH of int + | P_ARITY + | P_ARG + +let context operation path (t : constr) = + let rec loop i p0 t = + match (p0,kind_of_term t) with + | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t) + | ([], _) -> operation i t + | ((P_APP n :: p), App (f,v)) -> + let v' = Array.copy v in + v'.(pred n) <- loop i p v'.(pred n); mkApp (f, v') + | ((P_BRANCH n :: p), Case (ci,q,c,v)) -> + (* avant, y avait mkApp... anyway, BRANCH seems nowhere used *) + let v' = Array.copy v in + v'.(n) <- loop i p v'.(n); (mkCase (ci,q,c,v')) + | ((P_ARITY :: p), App (f,l)) -> + appvect (loop i p f,l) + | ((P_ARG :: p), App (f,v)) -> + let v' = Array.copy v in + v'.(0) <- loop i p v'.(0); mkApp (f,v') + | (p, Fix ((_,n as ln),(tys,lna,v))) -> + let l = Array.length v in + let v' = Array.copy v in + v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) + | ((P_BODY :: p), Prod (n,t,c)) -> + (mkProd (n,t,loop (succ i) p c)) + | ((P_BODY :: p), Lambda (n,t,c)) -> + (mkLambda (n,t,loop (succ i) p c)) + | ((P_BODY :: p), LetIn (n,b,t,c)) -> + (mkLetIn (n,b,t,loop (succ i) p c)) + | ((P_TYPE :: p), Prod (n,t,c)) -> + (mkProd (n,loop i p t,c)) + | ((P_TYPE :: p), Lambda (n,t,c)) -> + (mkLambda (n,loop i p t,c)) + | ((P_TYPE :: p), LetIn (n,b,t,c)) -> + (mkLetIn (n,b,loop i p t,c)) + | (p, _) -> + ppnl (Printer.pr_lconstr t); + failwith ("abstract_path " ^ string_of_int(List.length p)) + in + loop 1 path t + +let occurence path (t : constr) = + let rec loop p0 t = match (p0,kind_of_term t) with + | (p, Cast (c,_,_)) -> loop p c + | ([], _) -> t + | ((P_APP n :: p), App (f,v)) -> loop p v.(pred n) + | ((P_BRANCH n :: p), Case (_,_,_,v)) -> loop p v.(n) + | ((P_ARITY :: p), App (f,_)) -> loop p f + | ((P_ARG :: p), App (f,v)) -> loop p v.(0) + | (p, Fix((_,n) ,(_,_,v))) -> loop p v.(n) + | ((P_BODY :: p), Prod (n,t,c)) -> loop p c + | ((P_BODY :: p), Lambda (n,t,c)) -> loop p c + | ((P_BODY :: p), LetIn (n,b,t,c)) -> loop p c + | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term + | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term + | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term + | (p, _) -> + ppnl (Printer.pr_lconstr t); + failwith ("occurence " ^ string_of_int(List.length p)) + in + loop path t + +let abstract_path typ path t = + let term_occur = ref (mkRel 0) in + let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in + mkLambda (Name (id_of_string "x"), typ, abstract), !term_occur + +let focused_simpl path gl = + let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in + convert_concl_no_check newc DEFAULTcast gl + +let focused_simpl path = simpl_time (focused_simpl path) + +type oformula = + | Oplus of oformula * oformula + | Oinv of oformula + | Otimes of oformula * oformula + | Oatom of identifier + | Oz of bigint + | Oufo of constr + +let rec oprint = function + | Oplus(t1,t2) -> + print_string "("; oprint t1; print_string "+"; + oprint t2; print_string ")" + | Oinv t -> print_string "~"; oprint t + | Otimes (t1,t2) -> + print_string "("; oprint t1; print_string "*"; + oprint t2; print_string ")" + | Oatom s -> print_string (string_of_id s) + | Oz i -> print_string (string_of_bigint i) + | Oufo f -> print_string "?" + +let rec weight = function + | Oatom c -> intern_id c + | Oz _ -> -1 + | Oinv c -> weight c + | Otimes(c,_) -> weight c + | Oplus _ -> failwith "weight" + | Oufo _ -> -1 + +let rec val_of = function + | Oatom c -> mkVar c + | Oz c -> mk_integer c + | Oinv c -> mkApp (Lazy.force coq_Zopp, [| val_of c |]) + | Otimes (t1,t2) -> mkApp (Lazy.force coq_Zmult, [| val_of t1; val_of t2 |]) + | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |]) + | Oufo c -> c + +let compile name kind = + let rec loop accu = function + | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r + | Oz n -> + let id = new_id () in + tag_hypothesis name id; + {kind = kind; body = List.rev accu; constant = n; id = id} + | _ -> anomaly "compile_equation" + in + loop [] + +let rec decompile af = + let rec loop = function + | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) + | [] -> Oz af.constant + in + loop af.body + +let mkNewMeta () = mkMeta (Evarutil.new_meta()) + +let clever_rewrite_base_poly typ p result theorem gl = + let full = pf_concl gl in + let (abstracted,occ) = abstract_path typ (List.rev p) full in + let t = + applist + (mkLambda + (Name (id_of_string "P"), + mkArrow typ mkProp, + mkLambda + (Name (id_of_string "H"), + applist (mkRel 1,[result]), + mkApp (Lazy.force coq_eq_ind_r, + [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), + [abstracted]) + in + exact (applist(t,[mkNewMeta()])) gl + +let clever_rewrite_base p result theorem gl = + clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl + +let clever_rewrite_base_nat p result theorem gl = + clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem gl + +let clever_rewrite_gen p result (t,args) = + let theorem = applist(t, args) in + clever_rewrite_base p result theorem + +let clever_rewrite_gen_nat p result (t,args) = + let theorem = applist(t, args) in + clever_rewrite_base_nat p result theorem + +let clever_rewrite p vpath t gl = + let full = pf_concl gl in + let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in + let vargs = List.map (fun p -> occurence p occ) vpath in + let t' = applist(t, (vargs @ [abstracted])) in + exact (applist(t',[mkNewMeta()])) gl + +let rec shuffle p (t1,t2) = + match t1,t2 with + | Oplus(l1,r1), Oplus(l2,r2) -> + if weight l1 > weight l2 then + let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in + (clever_rewrite p [[P_APP 1;P_APP 1]; + [P_APP 1; P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zplus_assoc_reverse) + :: tac, + Oplus(l1,t')) + else + let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in + (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] + (Lazy.force coq_fast_Zplus_permute) + :: tac, + Oplus(l2,t')) + | Oplus(l1,r1), t2 -> + if weight l1 > weight t2 then + let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in + clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zplus_assoc_reverse) + :: tac, + Oplus(l1, t') + else + [clever_rewrite p [[P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zplus_comm)], + Oplus(t2,t1) + | t1,Oplus(l2,r2) -> + if weight l2 > weight t1 then + let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in + clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] + (Lazy.force coq_fast_Zplus_permute) + :: tac, + Oplus(l2,t') + else [],Oplus(t1,t2) + | Oz t1,Oz t2 -> + [focused_simpl p], Oz(Bigint.add t1 t2) + | t1,t2 -> + if weight t1 < weight t2 then + [clever_rewrite p [[P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zplus_comm)], + Oplus(t2,t1) + else [],Oplus(t1,t2) + +let rec shuffle_mult p_init k1 e1 k2 e2 = + let rec loop p = function + | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> + if v1 = v2 then + let tac = + clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]] + (Lazy.force coq_fast_OMEGA10) + in + if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then + let tac' = + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zred_factor5) in + tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: + loop p (l1,l2) + else tac :: loop (P_APP 2 :: p) (l1,l2) + else if v1 > v2 then + clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 1; P_APP 2]; + [P_APP 2]; + [P_APP 1; P_APP 2]] + (Lazy.force coq_fast_OMEGA11) :: + loop (P_APP 2 :: p) (l1,l2') + else + clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1]; + [P_APP 2; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]] + (Lazy.force coq_fast_OMEGA12) :: + loop (P_APP 2 :: p) (l1',l2) + | ({c=c1;v=v1}::l1), [] -> + clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 1; P_APP 2]; + [P_APP 2]; + [P_APP 1; P_APP 2]] + (Lazy.force coq_fast_OMEGA11) :: + loop (P_APP 2 :: p) (l1,[]) + | [],({c=c2;v=v2}::l2) -> + clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1]; + [P_APP 2; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]] + (Lazy.force coq_fast_OMEGA12) :: + loop (P_APP 2 :: p) ([],l2) + | [],[] -> [focused_simpl p_init] + in + loop p_init (e1,e2) + +let rec shuffle_mult_right p_init e1 k2 e2 = + let rec loop p = function + | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> + if v1 = v2 then + let tac = + clever_rewrite p + [[P_APP 1; P_APP 1; P_APP 1]; + [P_APP 1; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 2]; + [P_APP 2; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]] + (Lazy.force coq_fast_OMEGA15) + in + if Bigint.add c1 (Bigint.mult k2 c2) =? zero then + let tac' = + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zred_factor5) + in + tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: + loop p (l1,l2) + else tac :: loop (P_APP 2 :: p) (l1,l2) + else if v1 > v2 then + clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zplus_assoc_reverse) :: + loop (P_APP 2 :: p) (l1,l2') + else + clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1]; + [P_APP 2; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]] + (Lazy.force coq_fast_OMEGA12) :: + loop (P_APP 2 :: p) (l1',l2) + | ({c=c1;v=v1}::l1), [] -> + clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zplus_assoc_reverse) :: + loop (P_APP 2 :: p) (l1,[]) + | [],({c=c2;v=v2}::l2) -> + clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1]; + [P_APP 2; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]] + (Lazy.force coq_fast_OMEGA12) :: + loop (P_APP 2 :: p) ([],l2) + | [],[] -> [focused_simpl p_init] + in + loop p_init (e1,e2) + +let rec shuffle_cancel p = function + | [] -> [focused_simpl p] + | ({c=c1}::l1) -> + let tac = + clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]; + [P_APP 1; P_APP 1; P_APP 2; P_APP 1]] + (if c1 >? zero then + (Lazy.force coq_fast_OMEGA13) + else + (Lazy.force coq_fast_OMEGA14)) + in + tac :: shuffle_cancel p l1 + +let rec scalar p n = function + | Oplus(t1,t2) -> + let tac1,t1' = scalar (P_APP 1 :: p) n t1 and + tac2,t2' = scalar (P_APP 2 :: p) n t2 in + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zmult_plus_distr_l) :: + (tac1 @ tac2), Oplus(t1',t2') + | Oinv t -> + [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zmult_opp_comm); + focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(neg n)) + | Otimes(t1,Oz x) -> + [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zmult_assoc_reverse); + focused_simpl (P_APP 2 :: p)], + Otimes(t1,Oz (n*x)) + | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" + | (Oatom _ as t) -> [], Otimes(t,Oz n) + | Oz i -> [focused_simpl p],Oz(n*i) + | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |])) + +let rec scalar_norm p_init = + let rec loop p = function + | [] -> [focused_simpl p_init] + | (_::l) -> + clever_rewrite p + [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l + in + loop p_init + +let rec norm_add p_init = + let rec loop p = function + | [] -> [focused_simpl p_init] + | _:: l -> + clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zplus_assoc_reverse) :: + loop (P_APP 2 :: p) l + in + loop p_init + +let rec scalar_norm_add p_init = + let rec loop p = function + | [] -> [focused_simpl p_init] + | _ :: l -> + clever_rewrite p + [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] + (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l + in + loop p_init + +let rec negate p = function + | Oplus(t1,t2) -> + let tac1,t1' = negate (P_APP 1 :: p) t1 and + tac2,t2' = negate (P_APP 2 :: p) t2 in + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] + (Lazy.force coq_fast_Zopp_plus_distr) :: + (tac1 @ tac2), + Oplus(t1',t2') + | Oinv t -> + [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_involutive)], t + | Otimes(t1,Oz x) -> + [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] + (Lazy.force coq_fast_Zopp_mult_distr_r); + focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x)) + | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" + | (Oatom _ as t) -> + let r = Otimes(t,Oz(negone)) in + [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r + | Oz i -> [focused_simpl p],Oz(neg i) + | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |])) + +let rec transform p t = + let default isnat t' = + try + let v,th,_ = find_constr t' in + [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v + with _ -> + let v = new_identifier_var () + and th = new_identifier () in + hide_constr t' v th isnat; + [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v + in + try match destructurate_term t with + | Kapp(Zplus,[t1;t2]) -> + let tac1,t1' = transform (P_APP 1 :: p) t1 + and tac2,t2' = transform (P_APP 2 :: p) t2 in + let tac,t' = shuffle p (t1',t2') in + tac1 @ tac2 @ tac, t' + | Kapp(Zminus,[t1;t2]) -> + let tac,t = + transform p + (mkApp (Lazy.force coq_Zplus, + [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in + unfold sp_Zminus :: tac,t + | Kapp(Zsucc,[t1]) -> + let tac,t = transform p (mkApp (Lazy.force coq_Zplus, + [| t1; mk_integer one |])) in + unfold sp_Zsucc :: tac,t + | Kapp(Zmult,[t1;t2]) -> + let tac1,t1' = transform (P_APP 1 :: p) t1 + and tac2,t2' = transform (P_APP 2 :: p) t2 in + begin match t1',t2' with + | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t' + | (Oz n,_) -> + let sym = + clever_rewrite p [[P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zmult_comm) in + let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t' + | _ -> default false t + end + | Kapp((Zpos|Zneg|Z0),_) -> + (try ([],Oz(recognize_number t)) with _ -> default false t) + | Kvar s -> [],Oatom s + | Kapp(Zopp,[t]) -> + let tac,t' = transform (P_APP 1 :: p) t in + let tac',t'' = negate p t' in + tac @ tac', t'' + | Kapp(Z_of_nat,[t']) -> default true t' + | _ -> default false t + with e when catchable_exception e -> default false t + +let shrink_pair p f1 f2 = + match f1,f2 with + | Oatom v,Oatom _ -> + let r = Otimes(Oatom v,Oz two) in + clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r + | Oatom v, Otimes(_,c2) -> + let r = Otimes(Oatom v,Oplus(c2,Oz one)) in + clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] + (Lazy.force coq_fast_Zred_factor2), r + | Otimes (v1,c1),Oatom v -> + let r = Otimes(Oatom v,Oplus(c1,Oz one)) in + clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]] + (Lazy.force coq_fast_Zred_factor3), r + | Otimes (Oatom v,c1),Otimes (v2,c2) -> + let r = Otimes(Oatom v,Oplus(c1,c2)) in + clever_rewrite p + [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]] + (Lazy.force coq_fast_Zred_factor4),r + | t1,t2 -> + begin + oprint t1; print_newline (); oprint t2; print_newline (); + flush Pervasives.stdout; error "shrink.1" + end + +let reduce_factor p = function + | Oatom v -> + let r = Otimes(Oatom v,Oz one) in + [clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor0)],r + | Otimes(Oatom v,Oz n) as f -> [],f + | Otimes(Oatom v,c) -> + let rec compute = function + | Oz n -> n + | Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2) + | _ -> error "condense.1" + in + [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) + | t -> oprint t; error "reduce_factor.1" + +let rec condense p = function + | Oplus(f1,(Oplus(f2,r) as t)) -> + if weight f1 = weight f2 then begin + let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in + let assoc_tac = + clever_rewrite p + [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] + (Lazy.force coq_fast_Zplus_assoc) in + let tac_list,t' = condense p (Oplus(t,r)) in + (assoc_tac :: shrink_tac :: tac_list), t' + end else begin + let tac,f = reduce_factor (P_APP 1 :: p) f1 in + let tac',t' = condense (P_APP 2 :: p) t in + (tac @ tac'), Oplus(f,t') + end + | Oplus(f1,Oz n) -> + let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n) + | Oplus(f1,f2) -> + if weight f1 = weight f2 then begin + let tac_shrink,t = shrink_pair p f1 f2 in + let tac,t' = condense p t in + tac_shrink :: tac,t' + end else begin + let tac,f = reduce_factor (P_APP 1 :: p) f1 in + let tac',t' = condense (P_APP 2 :: p) f2 in + (tac @ tac'),Oplus(f,t') + end + | Oz _ as t -> [],t + | t -> + let tac,t' = reduce_factor p t in + let final = Oplus(t',Oz zero) in + let tac' = clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor6) in + tac @ [tac'], final + +let rec clear_zero p = function + | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero -> + let tac = + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zred_factor5) in + let tac',t = clear_zero p r in + tac :: tac',t + | Oplus(f,r) -> + let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t) + | t -> [],t + +let replay_history tactic_normalisation = + let aux = id_of_string "auxiliary" in + let aux1 = id_of_string "auxiliary_1" in + let aux2 = id_of_string "auxiliary_2" in + let izero = mk_integer zero in + let rec loop t = + match t with + | HYP e :: l -> + begin + try + tclTHEN + (List.assoc (hyp_of_tag e.id) tactic_normalisation) + (loop l) + with Not_found -> loop l end + | NEGATE_CONTRADICT (e2,e1,b) :: l -> + let eq1 = decompile e1 + and eq2 = decompile e2 in + let id1 = hyp_of_tag e1.id + and id2 = hyp_of_tag e2.id in + let k = if b then negone else one in + let p_initial = [P_APP 1;P_TYPE] in + let tac= shuffle_mult_right p_initial e1.body k e2.body in + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_OMEGA17, [| + val_of eq1; + val_of eq2; + mk_integer k; + mkVar id1; mkVar id2 |])]); + (mk_then tac); + (intros_using [aux]); + (resolve_id aux); + reflexivity + ] + | CONTRADICTION (e1,e2) :: l -> + let eq1 = decompile e1 + and eq2 = decompile e2 in + let p_initial = [P_APP 2;P_TYPE] in + let tac = shuffle_cancel p_initial e1.body in + let solve_le = + let not_sup_sup = mkApp (build_coq_eq (), [| + Lazy.force coq_comparison; + Lazy.force coq_Gt; + Lazy.force coq_Gt |]) + in + tclTHENS + (tclTHENLIST [ + (unfold sp_Zle); + (simpl_in_concl); + intro; + (absurd not_sup_sup) ]) + [ assumption ; reflexivity ] + in + let theorem = + mkApp (Lazy.force coq_OMEGA2, [| + val_of eq1; val_of eq2; + mkVar (hyp_of_tag e1.id); + mkVar (hyp_of_tag e2.id) |]) + in + tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le) + | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> + let id = hyp_of_tag e1.id in + let eq1 = val_of(decompile e1) + and eq2 = val_of(decompile e2) in + let kk = mk_integer k + and dd = mk_integer d in + let rhs = mk_plus (mk_times eq2 kk) dd in + let state_eg = mk_eq eq1 rhs in + let tac = scalar_norm_add [P_APP 3] e2.body in + tclTHENS + (cut state_eg) + [ tclTHENS + (tclTHENLIST [ + (intros_using [aux]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA1, + [| eq1; rhs; mkVar aux; mkVar id |])]); + (clear [aux;id]); + (intros_using [id]); + (cut (mk_gt kk dd)) ]) + [ tclTHENS + (cut (mk_gt kk izero)) + [ tclTHENLIST [ + (intros_using [aux1; aux2]); + (generalize_tac + [mkApp (Lazy.force coq_Zmult_le_approx, + [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); + (clear [aux1;aux2;id]); + (intros_using [id]); + (loop l) ]; + tclTHENLIST [ + (unfold sp_Zgt); + (simpl_in_concl); + reflexivity ] ]; + tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] + ]; + tclTHEN (mk_then tac) reflexivity ] + + | NOT_EXACT_DIVIDE (e1,k) :: l -> + let c = floor_div e1.constant k in + let d = Bigint.sub e1.constant (Bigint.mult c k) in + let e2 = {id=e1.id; kind=EQUA;constant = c; + body = map_eq_linear (fun c -> c / k) e1.body } in + let eq2 = val_of(decompile e2) in + let kk = mk_integer k + and dd = mk_integer d in + let tac = scalar_norm_add [P_APP 2] e2.body in + tclTHENS + (cut (mk_gt dd izero)) + [ tclTHENS (cut (mk_gt kk dd)) + [tclTHENLIST [ + (intros_using [aux2;aux1]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA4, + [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); + (clear [aux1;aux2]); + (unfold sp_not); + (intros_using [aux]); + (resolve_id aux); + (mk_then tac); + assumption ] ; + tclTHENLIST [ + (unfold sp_Zgt); + simpl_in_concl; + reflexivity ] ]; + tclTHENLIST [ + (unfold sp_Zgt); + simpl_in_concl; + reflexivity ] ] + | EXACT_DIVIDE (e1,k) :: l -> + let id = hyp_of_tag e1.id in + let e2 = map_eq_afine (fun c -> c / k) e1 in + let eq1 = val_of(decompile e1) + and eq2 = val_of(decompile e2) in + let kk = mk_integer k in + let state_eq = mk_eq eq1 (mk_times eq2 kk) in + if e1.kind = DISE then + let tac = scalar_norm [P_APP 3] e2.body in + tclTHENS + (cut state_eq) + [tclTHENLIST [ + (intros_using [aux1]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA18, + [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); + (clear [aux1;id]); + (intros_using [id]); + (loop l) ]; + tclTHEN (mk_then tac) reflexivity ] + else + let tac = scalar_norm [P_APP 3] e2.body in + tclTHENS (cut state_eq) + [ + tclTHENS + (cut (mk_gt kk izero)) + [tclTHENLIST [ + (intros_using [aux2;aux1]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA3, + [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); + (clear [aux1;aux2;id]); + (intros_using [id]); + (loop l) ]; + tclTHENLIST [ + (unfold sp_Zgt); + simpl_in_concl; + reflexivity ] ]; + tclTHEN (mk_then tac) reflexivity ] + | (MERGE_EQ(e3,e1,e2)) :: l -> + let id = new_identifier () in + tag_hypothesis id e3; + let id1 = hyp_of_tag e1.id + and id2 = hyp_of_tag e2 in + let eq1 = val_of(decompile e1) + and eq2 = val_of (decompile (negate_eq e1)) in + let tac = + clever_rewrite [P_APP 3] [[P_APP 1]] + (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: + scalar_norm [P_APP 3] e1.body + in + tclTHENS + (cut (mk_eq eq1 (mk_inv eq2))) + [tclTHENLIST [ + (intros_using [aux]); + (generalize_tac [mkApp (Lazy.force coq_OMEGA8, + [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); + (clear [id1;id2;aux]); + (intros_using [id]); + (loop l) ]; + tclTHEN (mk_then tac) reflexivity] + + | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l -> + let id = new_identifier () + and id2 = hyp_of_tag orig.id in + tag_hypothesis id e.id; + let eq1 = val_of(decompile def) + and eq2 = val_of(decompile orig) in + let vid = unintern_id v in + let theorem = + mkApp (build_coq_ex (), [| + Lazy.force coq_Z; + mkLambda + (Name vid, + Lazy.force coq_Z, + mk_eq (mkRel 1) eq1) |]) + in + let mm = mk_integer m in + let p_initial = [P_APP 2;P_TYPE] in + let tac = + clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) + [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: + shuffle_mult_right p_initial + orig.body m ({c= negone;v= v}::def.body) in + tclTHENS + (cut theorem) + [tclTHENLIST [ + (intros_using [aux]); + (elim_id aux); + (clear [aux]); + (intros_using [vid; aux]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA9, + [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); + (mk_then tac); + (clear [aux]); + (intros_using [id]); + (loop l) ]; + tclTHEN (exists_tac eq1) reflexivity ] + | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> + let id1 = new_identifier () + and id2 = new_identifier () in + tag_hypothesis id1 e1; tag_hypothesis id2 e2; + let id = hyp_of_tag e.id in + let tac1 = norm_add [P_APP 2;P_TYPE] e.body in + let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in + let eq = val_of(decompile e) in + tclTHENS + (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) + [tclTHENLIST [ (mk_then tac1); (intros_using [id1]); (loop act1) ]; + tclTHENLIST [ (mk_then tac2); (intros_using [id2]); (loop act2) ]] + | SUM(e3,(k1,e1),(k2,e2)) :: l -> + let id = new_identifier () in + tag_hypothesis id e3; + let id1 = hyp_of_tag e1.id + and id2 = hyp_of_tag e2.id in + let eq1 = val_of(decompile e1) + and eq2 = val_of(decompile e2) in + if k1 =? one & e2.kind = EQUA then + let tac_thm = + match e1.kind with + | EQUA -> Lazy.force coq_OMEGA5 + | INEQ -> Lazy.force coq_OMEGA6 + | DISE -> Lazy.force coq_OMEGA20 + in + let kk = mk_integer k2 in + let p_initial = + if e1.kind=DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in + let tac = shuffle_mult_right p_initial e1.body k2 e2.body in + tclTHENLIST [ + (generalize_tac + [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); + (mk_then tac); + (intros_using [id]); + (loop l) + ] + else + let kk1 = mk_integer k1 + and kk2 = mk_integer k2 in + let p_initial = [P_APP 2;P_TYPE] in + let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in + tclTHENS (cut (mk_gt kk1 izero)) + [tclTHENS + (cut (mk_gt kk2 izero)) + [tclTHENLIST [ + (intros_using [aux2;aux1]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA7, [| + eq1;eq2;kk1;kk2; + mkVar aux1;mkVar aux2; + mkVar id1;mkVar id2 |])]); + (clear [aux1;aux2]); + (mk_then tac); + (intros_using [id]); + (loop l) ]; + tclTHENLIST [ + (unfold sp_Zgt); + simpl_in_concl; + reflexivity ] ]; + tclTHENLIST [ + (unfold sp_Zgt); + simpl_in_concl; + reflexivity ] ] + | CONSTANT_NOT_NUL(e,k) :: l -> + tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl + | CONSTANT_NUL(e) :: l -> + tclTHEN (resolve_id (hyp_of_tag e)) reflexivity + | CONSTANT_NEG(e,k) :: l -> + tclTHENLIST [ + (generalize_tac [mkVar (hyp_of_tag e)]); + (unfold sp_Zle); + simpl_in_concl; + (unfold sp_not); + (intros_using [aux]); + (resolve_id aux); + reflexivity + ] + | _ -> tclIDTAC + in + loop + +let normalize p_initial t = + let (tac,t') = transform p_initial t in + let (tac',t'') = condense p_initial t' in + let (tac'',t''') = clear_zero p_initial t'' in + tac @ tac' @ tac'' , t''' + +let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) = + let p_initial = [P_APP pos ;P_TYPE] in + let (tac,t') = normalize p_initial t in + let shift_left = + tclTHEN + (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ]) + (tclTRY (clear [id])) + in + if tac <> [] then + let id' = new_identifier () in + ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ])) + :: tactic, + compile id' flag t' :: defs) + else + (tactic,defs) + +let destructure_omega gl tac_def (id,c) = + if atompart_of_id id = "State" then + tac_def + else + try match destructurate_prop c with + | Kapp(Eq,[typ;t1;t2]) + when destructurate_type (pf_nf gl typ) = Kapp(Z,[]) -> + let t = mk_plus t1 (mk_inv t2) in + normalize_equation + id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def + | Kapp(Zne,[t1;t2]) -> + let t = mk_plus t1 (mk_inv t2) in + normalize_equation + id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def + | Kapp(Zle,[t1;t2]) -> + let t = mk_plus t2 (mk_inv t1) in + normalize_equation + id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def + | Kapp(Zlt,[t1;t2]) -> + let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in + normalize_equation + id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def + | Kapp(Zge,[t1;t2]) -> + let t = mk_plus t1 (mk_inv t2) in + normalize_equation + id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def + | Kapp(Zgt,[t1;t2]) -> + let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in + normalize_equation + id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def + | _ -> tac_def + with e when catchable_exception e -> tac_def + +let reintroduce id = + (* [id] cannot be cleared if dependent: protect it by a try *) + tclTHEN (tclTRY (clear [id])) (intro_using id) + +let coq_omega gl = + clear_tables (); + let tactic_normalisation, system = + List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in + let prelude,sys = + List.fold_left + (fun (tac,sys) (t,(v,th,b)) -> + if b then + let id = new_identifier () in + let i = new_id () in + tag_hypothesis id i; + (tclTHENLIST [ + (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); + (intros_using [v; id]); + (elim_id id); + (clear [id]); + (intros_using [th;id]); + tac ]), + {kind = INEQ; + body = [{v=intern_id v; c=one}]; + constant = zero; id = i} :: sys + else + (tclTHENLIST [ + (simplest_elim (applist (Lazy.force coq_new_var, [t]))); + (intros_using [v;th]); + tac ]), + sys) + (tclIDTAC,[]) (dump_tables ()) + in + let system = system @ sys in + if !display_system_flag then display_system display_var system; + if !old_style_flag then begin + try + let _ = simplify (new_id,new_var_num,display_var) false system in + tclIDTAC gl + with UNSOLVABLE -> + let _,path = depend [] [] (history ()) in + if !display_action_flag then display_action display_var path; + (tclTHEN prelude (replay_history tactic_normalisation path)) gl + end else begin + try + let path = simplify_strong (new_id,new_var_num,display_var) system in + if !display_action_flag then display_action display_var path; + (tclTHEN prelude (replay_history tactic_normalisation path)) gl + with NO_CONTRADICTION -> error "Omega can't solve this system" + end + +let coq_omega = solver_time coq_omega + +let nat_inject gl = + let rec explore p t = + try match destructurate_term t with + | Kapp(Plus,[t1;t2]) -> + tclTHENLIST [ + (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) + ((Lazy.force coq_inj_plus),[t1;t2])); + (explore (P_APP 1 :: p) t1); + (explore (P_APP 2 :: p) t2) + ] + | Kapp(Mult,[t1;t2]) -> + tclTHENLIST [ + (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2)) + ((Lazy.force coq_inj_mult),[t1;t2])); + (explore (P_APP 1 :: p) t1); + (explore (P_APP 2 :: p) t2) + ] + | Kapp(Minus,[t1;t2]) -> + let id = new_identifier () in + tclTHENS + (tclTHEN + (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) + (intros_using [id])) + [ + tclTHENLIST [ + (clever_rewrite_gen p + (mk_minus (mk_inj t1) (mk_inj t2)) + ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id])); + (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]); + (explore (P_APP 1 :: p) t1); + (explore (P_APP 2 :: p) t2) ]; + (tclTHEN + (clever_rewrite_gen p (mk_integer zero) + ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id])) + (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])])) + ] + | Kapp(S,[t']) -> + let rec is_number t = + try match destructurate_term t with + Kapp(S,[t]) -> is_number t + | Kapp(O,[]) -> true + | _ -> false + with e when catchable_exception e -> false + in + let rec loop p t = + try match destructurate_term t with + Kapp(S,[t]) -> + (tclTHEN + (clever_rewrite_gen p + (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) + ((Lazy.force coq_inj_S),[t])) + (loop (P_APP 1 :: p) t)) + | _ -> explore p t + with e when catchable_exception e -> explore p t + in + if is_number t' then focused_simpl p else loop p t + | Kapp(Pred,[t]) -> + let t_minus_one = + mkApp (Lazy.force coq_minus, [| t; + mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in + tclTHEN + (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one + ((Lazy.force coq_pred_of_minus),[t])) + (explore p t_minus_one) + | Kapp(O,[]) -> focused_simpl p + | _ -> tclIDTAC + with e when catchable_exception e -> tclIDTAC + + and loop = function + | [] -> tclIDTAC + | (i,t)::lit -> + begin try match destructurate_prop t with + Kapp(Le,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) + ] + | Kapp(Lt,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) + ] + | Kapp(Ge,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) + ] + | Kapp(Gt,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) + ] + | Kapp(Neq,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) + ] + | Kapp(Eq,[typ;t1;t2]) -> + if pf_conv_x gl typ (Lazy.force coq_nat) then + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 2; P_TYPE] t1); + (explore [P_APP 3; P_TYPE] t2); + (reintroduce i); + (loop lit) + ] + else loop lit + | _ -> loop lit + with e when catchable_exception e -> loop lit end + in + loop (List.rev (pf_hyps_types gl)) gl + +let rec decidability gl t = + match destructurate_prop t with + | Kapp(Or,[t1;t2]) -> + mkApp (Lazy.force coq_dec_or, [| t1; t2; + decidability gl t1; decidability gl t2 |]) + | Kapp(And,[t1;t2]) -> + mkApp (Lazy.force coq_dec_and, [| t1; t2; + decidability gl t1; decidability gl t2 |]) + | Kapp(Iff,[t1;t2]) -> + mkApp (Lazy.force coq_dec_iff, [| t1; t2; + decidability gl t1; decidability gl t2 |]) + | Kimp(t1,t2) -> + mkApp (Lazy.force coq_dec_imp, [| t1; t2; + decidability gl t1; decidability gl t2 |]) + | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; + decidability gl t1 |]) + | Kapp(Eq,[typ;t1;t2]) -> + begin match destructurate_type (pf_nf gl typ) with + | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) + | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) + | _ -> errorlabstrm "decidability" + (str "Omega: Can't solve a goal with equality on " ++ + Printer.pr_lconstr typ) + end + | Kapp(Zne,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zne, [| t1;t2 |]) + | Kapp(Zle,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zle, [| t1;t2 |]) + | Kapp(Zlt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zlt, [| t1;t2 |]) + | Kapp(Zge,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zge, [| t1;t2 |]) + | Kapp(Zgt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zgt, [| t1;t2 |]) + | Kapp(Le, [t1;t2]) -> mkApp (Lazy.force coq_dec_le, [| t1;t2 |]) + | Kapp(Lt, [t1;t2]) -> mkApp (Lazy.force coq_dec_lt, [| t1;t2 |]) + | Kapp(Ge, [t1;t2]) -> mkApp (Lazy.force coq_dec_ge, [| t1;t2 |]) + | Kapp(Gt, [t1;t2]) -> mkApp (Lazy.force coq_dec_gt, [| t1;t2 |]) + | Kapp(False,[]) -> Lazy.force coq_dec_False + | Kapp(True,[]) -> Lazy.force coq_dec_True + | Kapp(Other t,_::_) -> error + ("Omega: Unrecognized predicate or connective: "^t) + | Kapp(Other t,[]) -> error ("Omega: Unrecognized atomic proposition: "^t) + | Kvar _ -> error "Omega: Can't solve a goal with proposition variables" + | _ -> error "Omega: Unrecognized proposition" + +let onClearedName id tac = + (* We cannot ensure that hyps can be cleared (because of dependencies), *) + (* so renaming may be necessary *) + tclTHEN + (tclTRY (clear [id])) + (fun gl -> + let id = fresh_id [] id gl in + tclTHEN (introduction id) (tac id) gl) + +let destructure_hyps gl = + let rec loop = function + | [] -> (tclTHEN nat_inject coq_omega) + | (i,body,t)::lit -> + begin try match destructurate_prop t with + | Kapp(False,[]) -> elim_id i + | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit + | Kapp(Or,[t1;t2]) -> + (tclTHENS + (elim_id i) + [ onClearedName i (fun i -> (loop ((i,None,t1)::lit))); + onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ]) + | Kapp(And,[t1;t2]) -> + tclTHENLIST [ + (elim_id i); + (tclTRY (clear [i])); + (fun gl -> + let i1 = fresh_id [] (add_suffix i "_left") gl in + let i2 = fresh_id [] (add_suffix i "_right") gl in + tclTHENLIST [ + (introduction i1); + (introduction i2); + (loop ((i1,None,t1)::(i2,None,t2)::lit)) ] gl) + ] + | Kapp(Iff,[t1;t2]) -> + tclTHENLIST [ + (elim_id i); + (tclTRY (clear [i])); + (fun gl -> + let i1 = fresh_id [] (add_suffix i "_left") gl in + let i2 = fresh_id [] (add_suffix i "_right") gl in + tclTHENLIST [ + introduction i1; + generalize_tac + [mkApp (Lazy.force coq_imp_simp, + [| t1; t2; decidability gl t1; mkVar i1|])]; + onClearedName i1 (fun i1 -> + tclTHENLIST [ + introduction i2; + generalize_tac + [mkApp (Lazy.force coq_imp_simp, + [| t2; t1; decidability gl t2; mkVar i2|])]; + onClearedName i2 (fun i2 -> + loop + ((i1,None,mk_or (mk_not t1) t2):: + (i2,None,mk_or (mk_not t2) t1)::lit)) + ])] gl) + ] + | Kimp(t1,t2) -> + if + is_Prop (pf_type_of gl t1) & + is_Prop (pf_type_of gl t2) & + closed0 t2 + then + tclTHENLIST [ + (generalize_tac [mkApp (Lazy.force coq_imp_simp, + [| t1; t2; decidability gl t1; mkVar i|])]); + (onClearedName i (fun i -> + (loop ((i,None,mk_or (mk_not t1) t2)::lit)))) + ] + else + loop lit + | Kapp(Not,[t]) -> + begin match destructurate_prop t with + Kapp(Or,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); + (onClearedName i (fun i -> + (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit)))) + ] + | Kapp(And,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_and, [| t1; t2; + decidability gl t1; mkVar i|])]); + (onClearedName i (fun i -> + (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit)))) + ] + | Kapp(Iff,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_iff, [| t1; t2; + decidability gl t1; decidability gl t2; mkVar i|])]); + (onClearedName i (fun i -> + (loop ((i,None, + mk_or (mk_and t1 (mk_not t2)) + (mk_and (mk_not t1) t2))::lit)))) + ] + | Kimp(t1,t2) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_imp, [| t1; t2; + decidability gl t1;mkVar i |])]); + (onClearedName i (fun i -> + (loop ((i,None,mk_and t1 (mk_not t2)) :: lit)))) + ] + | Kapp(Not,[t]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_not, [| t; + decidability gl t; mkVar i |])]); + (onClearedName i (fun i -> (loop ((i,None,t)::lit)))) + ] + | Kapp(Zle, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_Znot_le_gt, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Zge, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_Znot_ge_lt, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Zlt, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_Znot_lt_ge, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Zgt, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_Znot_gt_le, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Le, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_le, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Ge, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_ge, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Lt, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_lt, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Gt, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_gt, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Eq,[typ;t1;t2]) -> + if !old_style_flag then begin + match destructurate_type (pf_nf gl typ) with + | Kapp(Nat,_) -> + tclTHENLIST [ + (simplest_elim + (mkApp + (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Z,_) -> + tclTHENLIST [ + (simplest_elim + (mkApp + (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); + (onClearedName i (fun _ -> loop lit)) + ] + | _ -> loop lit + end else begin + match destructurate_type (pf_nf gl typ) with + | Kapp(Nat,_) -> + (tclTHEN + (convert_hyp_no_check + (i,body, + (mkApp (Lazy.force coq_neq, [| t1;t2|])))) + (loop lit)) + | Kapp(Z,_) -> + (tclTHEN + (convert_hyp_no_check + (i,body, + (mkApp (Lazy.force coq_Zne, [| t1;t2|])))) + (loop lit)) + | _ -> loop lit + end + | _ -> loop lit + end + | _ -> loop lit + with e when catchable_exception e -> loop lit + end + in + loop (pf_hyps gl) gl + +let destructure_goal gl = + let concl = pf_concl gl in + let rec loop t = + match destructurate_prop t with + | Kapp(Not,[t]) -> + (tclTHEN + (tclTHEN (unfold sp_not) intro) + destructure_hyps) + | Kimp(a,b) -> (tclTHEN intro (loop b)) + | Kapp(False,[]) -> destructure_hyps + | _ -> + (tclTHEN + (tclTHEN + (Tactics.refine + (mkApp (Lazy.force coq_dec_not_not, [| t; + decidability gl t; mkNewMeta () |]))) + intro) + (destructure_hyps)) + in + (loop concl) gl + +let destructure_goal = all_time (destructure_goal) + +let omega_solver gl = + Coqlib.check_required_library ["Coq";"omega";"Omega"]; + let result = destructure_goal gl in + (* if !display_time_flag then begin text_time (); + flush Pervasives.stdout end; *) + result diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 new file mode 100644 index 00000000..3bfdce7f --- /dev/null +++ b/plugins/omega/g_omega.ml4 @@ -0,0 +1,47 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tacinterp.interp <:tactic> + | "positive" -> Tacinterp.interp <:tactic> + | "N" -> Tacinterp.interp <:tactic> + | "Z" -> Tacinterp.interp <:tactic> + | s -> Util.error ("No Omega knowledge base for type "^s)) + (Util.list_uniquize (List.sort compare l)) + in + tclTHEN + (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) + omega_solver + + +TACTIC EXTEND omega +| [ "omega" ] -> [ omega_tactic [] ] +END + +TACTIC EXTEND omega' +| [ "omega" "with" ne_ident_list(l) ] -> + [ omega_tactic (List.map Names.string_of_id l) ] +| [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ] +END + diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml new file mode 100644 index 00000000..11ab9c03 --- /dev/null +++ b/plugins/omega/omega.ml @@ -0,0 +1,716 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bigint -> bool + val add : bigint -> bigint -> bigint + val sub : bigint -> bigint -> bigint + val mult : bigint -> bigint -> bigint + val euclid : bigint -> bigint -> bigint * bigint + val neg : bigint -> bigint + val zero : bigint + val one : bigint + val to_string : bigint -> string +end + +let debug = ref false + +module MakeOmegaSolver (Int:INT) = struct + +type bigint = Int.bigint +let (?) x y = Int.less_than y x +let (>=?) x y = Int.less_than y x or x = y +let (=?) = (=) +let (+) = Int.add +let (-) = Int.sub +let ( * ) = Int.mult +let (/) x y = fst (Int.euclid x y) +let (mod) x y = snd (Int.euclid x y) +let zero = Int.zero +let one = Int.one +let two = one + one +let negone = Int.neg one +let abs x = if Int.less_than x zero then Int.neg x else x +let string_of_bigint = Int.to_string +let neg = Int.neg + +(* To ensure that polymorphic (<) is not used mistakenly on big integers *) +(* Warning: do not use (=) either on big int *) +let (<) = ((<) : int -> int -> bool) +let (>) = ((>) : int -> int -> bool) +let (<=) = ((<=) : int -> int -> bool) +let (>=) = ((>=) : int -> int -> bool) + +let pp i = print_int i; print_newline (); flush stdout + +let push v l = l := v :: !l + +let rec pgcd x y = if y =? zero then x else pgcd y (x mod y) + +let pgcd_l = function + | [] -> failwith "pgcd_l" + | x :: l -> List.fold_left pgcd x l + +let floor_div a b = + match a >=? zero , b >? zero with + | true,true -> a / b + | false,false -> a / b + | true, false -> (a-one) / b - one + | false,true -> (a+one) / b - one + +type coeff = {c: bigint ; v: int} + +type linear = coeff list + +type eqn_kind = EQUA | INEQ | DISE + +type afine = { + (* a number uniquely identifying the equation *) + id: int ; + (* a boolean true for an eq, false for an ineq (Sigma a_i x_i >= 0) *) + kind: eqn_kind; + (* the variables and their coefficient *) + body: coeff list; + (* a constant *) + constant: bigint } + +type state_action = { + st_new_eq : afine; + st_def : afine; + st_orig : afine; + st_coef : bigint; + st_var : int } + +type action = + | DIVIDE_AND_APPROX of afine * afine * bigint * bigint + | NOT_EXACT_DIVIDE of afine * bigint + | FORGET_C of int + | EXACT_DIVIDE of afine * bigint + | SUM of int * (bigint * afine) * (bigint * afine) + | STATE of state_action + | HYP of afine + | FORGET of int * int + | FORGET_I of int * int + | CONTRADICTION of afine * afine + | NEGATE_CONTRADICT of afine * afine * bool + | MERGE_EQ of int * afine * int + | CONSTANT_NOT_NUL of int * bigint + | CONSTANT_NUL of int + | CONSTANT_NEG of int * bigint + | SPLIT_INEQ of afine * (int * action list) * (int * action list) + | WEAKEN of int * bigint + +exception UNSOLVABLE + +exception NO_CONTRADICTION + +let display_eq print_var (l,e) = + let _ = + List.fold_left + (fun not_first f -> + print_string + (if f.c ? zero then + Printf.printf "+ %s " (string_of_bigint e) + else if e + accu + one + trace_length l1 + trace_length l2 + | _ -> accu + one in + List.fold_left action_length zero l + +let operator_of_eq = function + | EQUA -> "=" | DISE -> "!=" | INEQ -> ">=" + +let kind_of = function + | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation" + +let display_system print_var l = + List.iter + (fun { kind=b; body=e; constant=c; id=id} -> + Printf.printf "E%d: " id; + display_eq print_var (e,c); + Printf.printf "%s 0\n" (operator_of_eq b)) + l; + print_string "------------------------\n\n" + +let display_inequations print_var l = + List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l; + print_string "------------------------\n\n" + +let sbi = string_of_bigint + +let rec display_action print_var = function + | act :: l -> begin match act with + | DIVIDE_AND_APPROX (e1,e2,k,d) -> + Printf.printf + "Inequation E%d is divided by %s and the constant coefficient is \ + rounded by substracting %s.\n" e1.id (sbi k) (sbi d) + | NOT_EXACT_DIVIDE (e,k) -> + Printf.printf + "Constant in equation E%d is not divisible by the pgcd \ + %s of its other coefficients.\n" e.id (sbi k) + | EXACT_DIVIDE (e,k) -> + Printf.printf + "Equation E%d is divided by the pgcd \ + %s of its coefficients.\n" e.id (sbi k) + | WEAKEN (e,k) -> + Printf.printf + "To ensure a solution in the dark shadow \ + the equation E%d is weakened by %s.\n" e (sbi k) + | SUM (e,(c1,e1),(c2,e2)) -> + Printf.printf + "We state %s E%d = %s %s E%d + %s %s E%d.\n" + (kind_of e1.kind) e (sbi c1) (kind_of e1.kind) e1.id (sbi c2) + (kind_of e2.kind) e2.id + | STATE { st_new_eq = e } -> + Printf.printf "We define a new equation E%d: " e.id; + display_eq print_var (e.body,e.constant); + print_string (operator_of_eq e.kind); print_string " 0" + | HYP e -> + Printf.printf "We define E%d: " e.id; + display_eq print_var (e.body,e.constant); + print_string (operator_of_eq e.kind); print_string " 0\n" + | FORGET_C e -> Printf.printf "E%d is trivially satisfiable.\n" e + | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 + | FORGET_I (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 + | MERGE_EQ (e,e1,e2) -> + Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e + | CONTRADICTION (e1,e2) -> + Printf.printf + "Equations E%d and E%d imply a contradiction on their \ + constant factors.\n" e1.id e2.id + | NEGATE_CONTRADICT(e1,e2,b) -> + Printf.printf + "Equations E%d and E%d state that their body is at the same time + equal and different\n" e1.id e2.id + | CONSTANT_NOT_NUL (e,k) -> + Printf.printf "Equation E%d states %s = 0.\n" e (sbi k) + | CONSTANT_NEG(e,k) -> + Printf.printf "Equation E%d states %s >= 0.\n" e (sbi k) + | CONSTANT_NUL e -> + Printf.printf "Inequation E%d states 0 != 0.\n" e + | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> + Printf.printf "Equation E%d is split in E%d and E%d\n\n" e.id e1 e2; + display_action print_var l1; + print_newline (); + display_action print_var l2; + print_newline () + end; display_action print_var l + | [] -> + flush stdout + +let default_print_var v = Printf.sprintf "X%d" v (* For debugging *) + +(*""*) +let add_event, history, clear_history = + let accu = ref [] in + (fun (v:action) -> if !debug then display_action default_print_var [v]; push v accu), + (fun () -> !accu), + (fun () -> accu := []) + +let nf_linear = Sort.list (fun x y -> x.v > y.v) + +let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x)) + +let map_eq_linear f = + let rec loop = function + | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l + | [] -> [] + in + loop + +let map_eq_afine f e = + { id = e.id; kind = e.kind; body = map_eq_linear f e.body; + constant = f e.constant } + +let negate_eq = map_eq_afine (fun x -> neg x) + +let rec sum p0 p1 = match (p0,p1) with + | ([], l) -> l | (l, []) -> l + | (((x1::l1) as l1'), ((x2::l2) as l2')) -> + if x1.v = x2.v then + let c = x1.c + x2.c in + if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2 + else if x1.v > x2.v then + x1 :: sum l1 l2' + else + x2 :: sum l1' l2 + +let sum_afine new_eq_id eq1 eq2 = + { kind = eq1.kind; id = new_eq_id (); + body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant } + +exception FACTOR1 + +let rec chop_factor_1 = function + | x :: l -> + if abs x.c =? one then x,l else let (c',l') = chop_factor_1 l in (c',x::l') + | [] -> raise FACTOR1 + +exception CHOPVAR + +let rec chop_var v = function + | f :: l -> if f.v = v then f,l else let (f',l') = chop_var v l in (f',f::l') + | [] -> raise CHOPVAR + +let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = + if e = [] then begin + match eq_flag with + | EQUA -> + if x =? zero then [] else begin + add_event (CONSTANT_NOT_NUL(id,x)); raise UNSOLVABLE + end + | DISE -> + if x <> zero then [] else begin + add_event (CONSTANT_NUL id); raise UNSOLVABLE + end + | INEQ -> + if x >=? zero then [] else begin + add_event (CONSTANT_NEG(id,x)); raise UNSOLVABLE + end + end else + let gcd = pgcd_l (List.map (fun f -> abs f.c) e) in + if eq_flag=EQUA & x mod gcd <> zero then begin + add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE + end else if eq_flag=DISE & x mod gcd <> zero then begin + add_event (FORGET_C eq.id); [] + end else if gcd <> one then begin + let c = floor_div x gcd in + let d = x - c * gcd in + let new_eq = {id=id; kind=eq_flag; constant=c; + body=map_eq_linear (fun c -> c / gcd) e} in + add_event (if eq_flag=EQUA or eq_flag = DISE then EXACT_DIVIDE(eq,gcd) + else DIVIDE_AND_APPROX(eq,new_eq,gcd,d)); + [new_eq] + end else [eq] + +let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2 + ({body=e1; constant=c1} as eq1) = + try + let (f,_) = chop_var v e1 in + let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c + else failwith "eliminate_with_in" in + let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in + add_event (SUM (res.id,(one,eq1),(coeff,eq2))); res + with CHOPVAR -> eq1 + +let omega_mod a b = a - b * floor_div (two * a + b) (two * b) +let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = + let e = original.body in + let sigma = new_var_id () in + let smallest,var = + try + List.fold_left (fun (v,p) c -> if v >? (abs c.c) then abs c.c,c.v else (v,p)) + (abs (List.hd e).c, (List.hd e).v) (List.tl e) + with Failure "tl" -> display_system print_var [original] ; failwith "TL" in + let m = smallest + one in + let new_eq = + { constant = omega_mod original.constant m; + body = {c= neg m;v=sigma} :: + map_eq_linear (fun a -> omega_mod a m) original.body; + id = new_eq_id (); kind = EQUA } in + let definition = + { constant = neg (floor_div (two * original.constant + m) (two * m)); + body = map_eq_linear (fun a -> neg (floor_div (two * a + m) (two * m))) + original.body; + id = new_eq_id (); kind = EQUA } in + add_event (STATE {st_new_eq = new_eq; st_def = definition; + st_orig = original; st_coef = m; st_var = sigma}); + let new_eq = List.hd (normalize new_eq) in + let eliminated_var, def = chop_var var new_eq.body in + let other_equations = + Util.list_map_append + (fun e -> + normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in + let inequations = + Util.list_map_append + (fun e -> + normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in + let original' = eliminate_with_in new_eq_id eliminated_var new_eq original in + let mod_original = map_eq_afine (fun c -> c / m) original' in + add_event (EXACT_DIVIDE (original',m)); + List.hd (normalize mod_original),other_equations,inequations + +let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = + if !debug then display_system print_var (e::other); + try + let v,def = chop_factor_1 e.body in + (Util.list_map_append + (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other, + Util.list_map_append + (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) ineqs) + with FACTOR1 -> + eliminate_one_equation new_ids (banerjee_step new_ids e other ineqs) + +let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) = + let rec fst_eq_1 = function + (eq::l) -> + if List.exists (fun x -> abs x.c =? one) eq.body then eq,l + else let (eq',l') = fst_eq_1 l in (eq',eq::l') + | [] -> raise Not_found in + match sys_eq with + [] -> if !debug then display_system print_var sys_ineq; sys_ineq + | (e1::rest) -> + let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in + if eq.body = [] then + if eq.constant =? zero then begin + add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq) + end else begin + add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE + end + else + banerjee new_ids + (eliminate_one_equation new_ids (eq,other,sys_ineq)) + +type kind = INVERTED | NORMAL + +let redundancy_elimination new_eq_id system = + let normal = function + ({body=f::_} as e) when f.c negate_eq e, INVERTED + | e -> e,NORMAL in + let table = Hashtbl.create 7 in + List.iter + (fun e -> + let ({body=ne} as nx) ,kind = normal e in + if ne = [] then + if nx.constant + let kept = + if v.constant Some nx,optinvert + end else begin + match optinvert with + Some v -> + let _kept = + if v.constant >? nx.constant + then begin add_event (FORGET_I (v.id,nx.id));v end + else begin add_event (FORGET_I (nx.id,v.id));nx end in + (optnormal,Some(if v.constant >? nx.constant then v else nx)) + | None -> optnormal,Some nx + end in + begin match final with + (Some high, Some low) -> + if high.constant () end; + Hashtbl.remove table ne; + Hashtbl.add table ne final + with Not_found -> + Hashtbl.add table ne + (if kind = NORMAL then (Some nx,None) else (None,Some nx))) + system; + let accu_eq = ref [] in + let accu_ineq = ref [] in + Hashtbl.iter + (fun p0 p1 -> match (p0,p1) with + | (e, (Some x, Some y)) when x.constant =? y.constant -> + let id=new_eq_id () in + add_event (MERGE_EQ(id,x,y.id)); + push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq + | (e, (optnorm,optinvert)) -> + begin match optnorm with + Some x -> push x accu_ineq | _ -> () end; + begin match optinvert with + Some x -> push (negate_eq x) accu_ineq | _ -> () end) + table; + !accu_eq,!accu_ineq + +exception SOLVED_SYSTEM + +let select_variable system = + let table = Hashtbl.create 7 in + let push v c= + try let r = Hashtbl.find table v in r := max !r (abs c) + with Not_found -> Hashtbl.add table v (ref (abs c)) in + List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system; + let vmin,cmin = ref (-1), ref zero in + let var_cpt = ref 0 in + Hashtbl.iter + (fun v ({contents = c}) -> + incr var_cpt; + if c + try let f,eq' = chop_var v eq.body in + if f.c >=? zero then (not_occ,((f.c,eq) :: below),over) + else (not_occ,below,((neg f.c,eq) :: over)) + with CHOPVAR -> (eq::not_occ,below,over)) + ([],[],[]) system + +let product new_eq_id dark_shadow low high = + List.fold_left + (fun accu (a,eq1) -> + List.fold_left + (fun accu (b,eq2) -> + let eq = + sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1) + (map_eq_afine (fun c -> c * a) eq2) in + add_event(SUM(eq.id,(b,eq1),(a,eq2))); + match normalize eq with + | [eq] -> + let final_eq = + if dark_shadow then + let delta = (a - one) * (b - one) in + add_event(WEAKEN(eq.id,delta)); + {id = eq.id; kind=INEQ; body = eq.body; + constant = eq.constant - delta} + else eq + in final_eq :: accu + | (e::_) -> failwith "Product dardk" + | [] -> accu) + accu high) + [] low + +let fourier_motzkin (new_eq_id,_,print_var) dark_shadow system = + let v = select_variable system in + let (ineq_out, ineq_low,ineq_high) = classify v system in + let expanded = ineq_out @ product new_eq_id dark_shadow ineq_low ineq_high in + if !debug then display_system print_var expanded; expanded + +let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system = + if List.exists (fun e -> e.kind = DISE) system then + failwith "disequation in simplify"; + clear_history (); + List.iter (fun e -> add_event (HYP e)) system; + let system = Util.list_map_append normalize system in + let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in + let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in + let system = (eqs @ simp_eq,simp_ineq) in + let rec loop1a system = + let sys_ineq = banerjee new_ids system in + loop1b sys_ineq + and loop1b sys_ineq = + let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in + if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) + in + let rec loop2 system = + try + let expanded = fourier_motzkin new_ids dark_shadow system in + loop2 (loop1b expanded) + with SOLVED_SYSTEM -> + if !debug then display_system print_var system; system + in + loop2 (loop1a system) + +let rec depend relie_on accu = function + | act :: l -> + begin match act with + | DIVIDE_AND_APPROX (e,_,_,_) -> + if List.mem e.id relie_on then depend relie_on (act::accu) l + else depend relie_on accu l + | EXACT_DIVIDE (e,_) -> + if List.mem e.id relie_on then depend relie_on (act::accu) l + else depend relie_on accu l + | WEAKEN (e,_) -> + if List.mem e relie_on then depend relie_on (act::accu) l + else depend relie_on accu l + | SUM (e,(_,e1),(_,e2)) -> + if List.mem e relie_on then + depend (e1.id::e2.id::relie_on) (act::accu) l + else + depend relie_on accu l + | STATE {st_new_eq=e;st_orig=o} -> + if List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l + else depend relie_on accu l + | HYP e -> + if List.mem e.id relie_on then depend relie_on (act::accu) l + else depend relie_on accu l + | FORGET_C _ -> depend relie_on accu l + | FORGET _ -> depend relie_on accu l + | FORGET_I _ -> depend relie_on accu l + | MERGE_EQ (e,e1,e2) -> + if List.mem e relie_on then + depend (e1.id::e2::relie_on) (act::accu) l + else + depend relie_on accu l + | NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l + | CONTRADICTION (e1,e2) -> + depend (e1.id::e2.id::relie_on) (act::accu) l + | CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l + | CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l + | CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l + | NEGATE_CONTRADICT (e1,e2,_) -> + depend (e1.id::e2.id::relie_on) (act::accu) l + | SPLIT_INEQ _ -> failwith "depend" + end + | [] -> relie_on, accu + +(* +let depend relie_on accu trace = + Printf.printf "Longueur de la trace initiale : %d\n" + (trace_length trace + trace_length accu); + let rel',trace' = depend relie_on accu trace in + Printf.printf "Longueur de la trace simplifiée : %d\n" (trace_length trace'); + rel',trace' +*) + +let solve (new_eq_id,new_eq_var,print_var) system = + try let _ = simplify new_eq_id false system in failwith "no contradiction" + with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ()))) + +let negation (eqs,ineqs) = + let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in + let normal = function + | ({body=f::_} as e) when f.c negate_eq e, INVERTED + | e -> e,NORMAL in + let table = Hashtbl.create 7 in + List.iter (fun e -> + let {body=ne;constant=c} ,kind = normal e in + Hashtbl.add table (ne,c) (kind,e)) diseq; + List.iter (fun e -> + assert (e.kind = EQUA); + let {body=ne;constant=c},kind = normal e in + try + let (kind',e') = Hashtbl.find table (ne,c) in + add_event (NEGATE_CONTRADICT (e,e',kind=kind')); + raise UNSOLVABLE + with Not_found -> ()) eqs + +exception FULL_SOLUTION of action list * int list + +let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = + clear_history (); + List.iter (fun e -> add_event (HYP e)) system; + (* Initial simplification phase *) + let rec loop1a system = + negation system; + let sys_ineq = banerjee new_ids system in + loop1b sys_ineq + and loop1b sys_ineq = + let dise,ine = List.partition (fun e -> e.kind = DISE) sys_ineq in + let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in + if simp_eq = [] then dise @ simp_ineq + else loop1a (simp_eq,dise @ simp_ineq) + in + let rec loop2 system = + try + let expanded = fourier_motzkin new_ids false system in + loop2 (loop1b expanded) + with SOLVED_SYSTEM -> if !debug then display_system print_var system; system + in + let rec explode_diseq = function + | (de::diseq,ineqs,expl_map) -> + let id1 = new_eq_id () + and id2 = new_eq_id () in + let e1 = + {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in + let e2 = + {id = id2; kind=INEQ; body = map_eq_linear neg de.body; + constant = neg de.constant - one} in + let new_sys = + List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) + ineqs @ + List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) + ineqs + in + explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map) + | ([],ineqs,expl_map) -> ineqs,expl_map + in + try + let system = Util.list_map_append normalize system in + let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in + let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in + let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in + let system = (eqs @ simp_eq,simp_ineq @ dise) in + let system' = loop1a system in + let diseq,ineq = List.partition (fun e -> e.kind = DISE) system' in + let first_segment = history () in + let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in + let all_solutions = + List.map + (fun (decomp,sys) -> + clear_history (); + try let _ = loop2 sys in raise NO_CONTRADICTION + with UNSOLVABLE -> + let relie_on,path = depend [] [] (history ()) in + let dc,_ = List.partition (fun (_,id,_) -> List.mem id relie_on) decomp in + let red = List.map (fun (x,_,_) -> x) dc in + (red,relie_on,decomp,path)) + sys_exploded + in + let max_count sys = + let tbl = Hashtbl.create 7 in + let augment x = + try incr (Hashtbl.find tbl x) + with Not_found -> Hashtbl.add tbl x (ref 1) in + let eq = ref (-1) and c = ref 0 in + List.iter (function + | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on)) + | (l,_,_,_) -> List.iter augment l) sys; + Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl; + !eq + in + let rec solve systems = + try + let id = max_count systems in + let rec sign = function + | ((id',_,b)::l) -> if id=id' then b else sign l + | [] -> failwith "solve" in + let s1,s2 = + List.partition (fun (_,_,decomp,_) -> sign decomp) systems in + let s1' = + List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s1 in + let s2' = + List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s2 in + let (r1,relie1) = solve s1' + and (r2,relie2) = solve s2' in + let (eq,id1,id2) = List.assoc id explode_map in + [SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.list_union relie1 relie2 + with FULL_SOLUTION (x0,x1) -> (x0,x1) + in + let act,relie_on = solve all_solutions in + snd(depend relie_on act first_segment) + with UNSOLVABLE -> snd (depend [] [] (history ())) + +end diff --git a/plugins/omega/omega_plugin.mllib b/plugins/omega/omega_plugin.mllib new file mode 100644 index 00000000..2b387fdc --- /dev/null +++ b/plugins/omega/omega_plugin.mllib @@ -0,0 +1,4 @@ +Omega +Coq_omega +G_omega +Omega_plugin_mod diff --git a/plugins/omega/vo.itarget b/plugins/omega/vo.itarget new file mode 100644 index 00000000..9d9a77a8 --- /dev/null +++ b/plugins/omega/vo.itarget @@ -0,0 +1,4 @@ +OmegaLemmas.vo +OmegaPlugin.vo +Omega.vo +PreOmega.vo diff --git a/plugins/plugins.itarget b/plugins/plugins.itarget new file mode 100644 index 00000000..56aa42b0 --- /dev/null +++ b/plugins/plugins.itarget @@ -0,0 +1,3 @@ +pluginsopt.otarget +pluginsbyte.otarget +pluginsvo.otarget \ No newline at end of file diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget new file mode 100644 index 00000000..1485c147 --- /dev/null +++ b/plugins/pluginsbyte.itarget @@ -0,0 +1,23 @@ +field/field_plugin.cma +setoid_ring/newring_plugin.cma +extraction/extraction_plugin.cma +firstorder/ground_plugin.cma +rtauto/rtauto_plugin.cma +fourier/fourier_plugin.cma +romega/romega_plugin.cma +omega/omega_plugin.cma +micromega/micromega_plugin.cma +dp/dp_plugin.cma +xml/xml_plugin.cma +subtac/subtac_plugin.cma +ring/ring_plugin.cma +cc/cc_plugin.cma +nsatz/nsatz_plugin.cma +funind/recdef_plugin.cma +syntax/ascii_syntax_plugin.cma +syntax/nat_syntax_plugin.cma +syntax/numbers_syntax_plugin.cma +syntax/r_syntax_plugin.cma +syntax/string_syntax_plugin.cma +syntax/z_syntax_plugin.cma +quote/quote_plugin.cma diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget new file mode 100644 index 00000000..5d502411 --- /dev/null +++ b/plugins/pluginsdyn.itarget @@ -0,0 +1,23 @@ +field/field_plugin.cmxs +setoid_ring/newring_plugin.cmxs +extraction/extraction_plugin.cmxs +firstorder/ground_plugin.cmxs +rtauto/rtauto_plugin.cmxs +fourier/fourier_plugin.cmxs +romega/romega_plugin.cmxs +omega/omega_plugin.cmxs +micromega/micromega_plugin.cmxs +dp/dp_plugin.cmxs +xml/xml_plugin.cmxs +subtac/subtac_plugin.cmxs +ring/ring_plugin.cmxs +cc/cc_plugin.cmxs +nsatz/nsatz_plugin.cmxs +funind/recdef_plugin.cmxs +syntax/ascii_syntax_plugin.cmxs +syntax/nat_syntax_plugin.cmxs +syntax/numbers_syntax_plugin.cmxs +syntax/r_syntax_plugin.cmxs +syntax/string_syntax_plugin.cmxs +syntax/z_syntax_plugin.cmxs +quote/quote_plugin.cmxs diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget new file mode 100644 index 00000000..2f72dab8 --- /dev/null +++ b/plugins/pluginsopt.itarget @@ -0,0 +1,23 @@ +field/field_plugin.cmxa +setoid_ring/newring_plugin.cmxa +extraction/extraction_plugin.cmxa +firstorder/ground_plugin.cmxa +rtauto/rtauto_plugin.cmxa +fourier/fourier_plugin.cmxa +romega/romega_plugin.cmxa +omega/omega_plugin.cmxa +micromega/micromega_plugin.cmxa +dp/dp_plugin.cmxa +xml/xml_plugin.cmxa +subtac/subtac_plugin.cmxa +ring/ring_plugin.cmxa +cc/cc_plugin.cmxa +nsatz/nsatz_plugin.cmxa +funind/recdef_plugin.cmxa +syntax/ascii_syntax_plugin.cmxa +syntax/nat_syntax_plugin.cmxa +syntax/numbers_syntax_plugin.cmxa +syntax/r_syntax_plugin.cmxa +syntax/string_syntax_plugin.cmxa +syntax/z_syntax_plugin.cmxa +quote/quote_plugin.cmxa diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget new file mode 100644 index 00000000..db56534c --- /dev/null +++ b/plugins/pluginsvo.itarget @@ -0,0 +1,13 @@ +dp/vo.otarget +field/vo.otarget +fourier/vo.otarget +funind/vo.otarget +nsatz/vo.otarget +micromega/vo.otarget +omega/vo.otarget +quote/vo.otarget +ring/vo.otarget +romega/vo.otarget +rtauto/vo.otarget +setoid_ring/vo.otarget +extraction/vo.otarget \ No newline at end of file diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v new file mode 100644 index 00000000..11726675 --- /dev/null +++ b/plugins/quote/Quote.v @@ -0,0 +1,87 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool + index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m + index_lt : index -> bool + varmap : Type -> Type. + varmap_find : (A:Type)A -> index -> (varmap A) -> A. + + The first arg. of varmap_find is the default value to take + if the object is not found in the varmap. + + index_lt defines a total well-founded order, but we don't prove that. + +***********************************************************************) + +Set Implicit Arguments. +Unset Boxed Definitions. + +Section variables_map. + +Variable A : Type. + +Inductive varmap : Type := + | Empty_vm : varmap + | Node_vm : A -> varmap -> varmap -> varmap. + +Inductive index : Set := + | Left_idx : index -> index + | Right_idx : index -> index + | End_idx : index. + +Fixpoint varmap_find (default_value:A) (i:index) (v:varmap) {struct v} : A := + match i, v with + | End_idx, Node_vm x _ _ => x + | Right_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v2 + | Left_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v1 + | _, _ => default_value + end. + +Fixpoint index_eq (n m:index) {struct m} : bool := + match n, m with + | End_idx, End_idx => true + | Left_idx n', Left_idx m' => index_eq n' m' + | Right_idx n', Right_idx m' => index_eq n' m' + | _, _ => false + end. + +Fixpoint index_lt (n m:index) {struct m} : bool := + match n, m with + | End_idx, Left_idx _ => true + | End_idx, Right_idx _ => true + | Left_idx n', Right_idx m' => true + | Right_idx n', Right_idx m' => index_lt n' m' + | Left_idx n', Left_idx m' => index_lt n' m' + | _, _ => false + end. + +Lemma index_eq_prop : forall n m:index, index_eq n m = true -> n = m. + simple induction n; simple induction m; simpl in |- *; intros. + rewrite (H i0 H1); reflexivity. + discriminate. + discriminate. + discriminate. + rewrite (H i0 H1); reflexivity. + discriminate. + discriminate. + discriminate. + reflexivity. +Qed. + +End variables_map. + +Unset Implicit Arguments. diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 new file mode 100644 index 00000000..bdeb9844 --- /dev/null +++ b/plugins/quote/g_quote.ml4 @@ -0,0 +1,31 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* fst k)) in + let x = TacDynamic(dummy_loc, Pretyping.constr_in x) in + let tac = <:tactic> in + Tacinterp.interp tac + +TACTIC EXTEND quote + [ "quote" ident(f) ] -> [ quote f [] ] +| [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ] +| [ "quote" ident(f) "in" constr(c) "using" tactic(k) ] -> + [ gen_quote (make_cont k) c f [] ] +| [ "quote" ident(f) "[" ne_ident_list(lc) "]" + "in" constr(c) "using" tactic(k) ] -> + [ gen_quote (make_cont k) c f lc ] +END diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml new file mode 100644 index 00000000..2e4d07d6 --- /dev/null +++ b/plugins/quote/quote.ml @@ -0,0 +1,504 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (varmap A L) -> A}. + + Then, the tactic \texttt{quote f} will replace an + expression \texttt{e} of type \texttt{A} by \texttt{(f vm t)} + such that \texttt{e} and \texttt{(f vm t)} are convertible. + + The problem is then inverting the function \texttt{f}. + + The tactic works when: + + \begin{itemize} + \item L is a simple inductive datatype. The constructors of L may + have one of the three following forms: + + \begin{enumerate} + \item ordinary recursive constructors like: \verb|Cplus : L -> L -> L| + \item variable leaf like: \verb|Cvar : index -> L| + \item constant leaf like \verb|Cconst : A -> L| + \end{enumerate} + + The definition of \texttt{L} must contain at most one variable + leaf and at most one constant leaf. + + When there are both a variable leaf and a constant leaf, there is + an ambiguity on inversion. The term t can be either the + interpretation of \texttt{(Cconst t)} or the interpretation of + (\texttt{Cvar}~$i$) in a variable map containing the binding $i + \rightarrow$~\texttt{t}. How to discriminate between these + choices? + + To solve the dilemma, one gives to \texttt{quote} a list of + \emph{constant constructors}: a term will be considered as a + constant if it is either a constant constructor or the + application of a constant constructor to constants. For example + the list \verb+[S, O]+ defines the closed natural + numbers. \texttt{(S (S O))} is a constant when \texttt{(S x)} is + not. + + The definition of constants vary for each application of the + tactic, so it can even be different for two applications of + \texttt{quote} with the same function. + + \item \texttt{f} is a quite simple fixpoint on + \texttt{L}. In particular, \texttt{f} must verify: + +\begin{verbatim} + (f (Cvar i)) = (varmap_find vm default_value i) +\end{verbatim} +\begin{verbatim} + (f (Cconst c)) = c +\end{verbatim} + + where \texttt{index} and \texttt{varmap\_find} are those defined + the \texttt{Quote} module. \emph{The tactic won't work with + user's own variables map!!} It is mandatory to use the + variable map defined in module \texttt{Quote}. + + \end{itemize} + + The method to proceed is then clear: + + \begin{itemize} + \item Start with an empty hashtable of "registed leafs" + that maps constr to integers and a "variable counter" equal to 0. + \item Try to match the term with every right hand side of the + definition of \texttt{f}. + + If there is one match, returns the correponding left hand + side and call yourself recursively to get the arguments of this + left hand side. + + If there is no match, we are at a leaf. That is the + interpretation of either a variable or a constant. + + If it is a constant, return \texttt{Cconst} applied to that + constant. + + If not, it is a variable. Look in the hashtable + if this leaf has been already encountered. If not, increment + the variable counter and add an entry to the hashtable; then + return \texttt{(Cvar !variables\_counter)} + \end{itemize} +*) + + +(*i*) +open Pp +open Util +open Names +open Term +open Pattern +open Matching +open Tacmach +open Tactics +open Proof_trees +open Tacexpr +(*i*) + +(*s First, we need to access some Coq constants + We do that lazily, because this code can be linked before + the constants are loaded in the environment *) + +let constant dir s = Coqlib.gen_constant "Quote" ("quote"::dir) s + +let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm") +let coq_Node_vm = lazy (constant ["Quote"] "Node_vm") +let coq_varmap_find = lazy (constant ["Quote"] "varmap_find") +let coq_Right_idx = lazy (constant ["Quote"] "Right_idx") +let coq_Left_idx = lazy (constant ["Quote"] "Left_idx") +let coq_End_idx = lazy (constant ["Quote"] "End_idx") + +(*s Then comes the stuff to decompose the body of interpetation function + and pre-compute the inversion data. + +For a function like: + +\begin{verbatim} + Fixpoint interp (vm:varmap Prop) (f:form) := + match f with + | f_and f1 f1 f2 => (interp f1) /\ (interp f2) + | f_or f1 f1 f2 => (interp f1) \/ (interp f2) + | f_var i => varmap_find Prop default_v i vm + | f_const c => c + end. +\end{verbatim} + +With the constant constructors \texttt{C1}, \dots, \texttt{Cn}, the +corresponding scheme will be: + +\begin{verbatim} + {normal_lhs_rhs = + [ "(f_and ?1 ?2)", "?1 /\ ?2"; + "(f_or ?1 ?2)", " ?1 \/ ?2";]; + return_type = "Prop"; + constants = Some [C1,...Cn]; + variable_lhs = Some "(f_var ?1)"; + constant_lhs = Some "(f_const ?1)" + } +\end{verbatim} + +If there is no constructor for variables in the type \texttt{form}, +then [variable_lhs] is [None]. Idem for constants and +[constant_lhs]. Both cannot be equal to [None]. + +The metas in the RHS must correspond to those in the LHS (one cannot +exchange ?1 and ?2 in the example above) + +*) + +module ConstrSet = Set.Make( + struct + type t = constr + let compare = (Pervasives.compare : t->t->int) + end) + +type inversion_scheme = { + normal_lhs_rhs : (constr * constr_pattern) list; + variable_lhs : constr option; + return_type : constr; + constants : ConstrSet.t; + constant_lhs : constr option } + +(*s [compute_ivs gl f cs] computes the inversion scheme associated to + [f:constr] with constants list [cs:constr list] in the context of + goal [gl]. This function uses the auxiliary functions + [i_can't_do_that], [decomp_term], [compute_lhs] and [compute_rhs]. *) + +let i_can't_do_that () = error "Quote: not a simple fixpoint" + +let decomp_term c = kind_of_term (strip_outer_cast c) + +(*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ... + ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive + type [typ] *) + +let coerce_meta_out id = + let s = string_of_id id in + int_of_string (String.sub s 1 (String.length s - 1)) +let coerce_meta_in n = + id_of_string ("M" ^ string_of_int n) + +let compute_lhs typ i nargsi = + match kind_of_term typ with + | Ind(sp,0) -> + let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in + mkApp (mkConstruct ((sp,0),i+1), argsi) + | _ -> i_can't_do_that () + +(*s This function builds the pattern from the RHS. Recursive calls are + replaced by meta-variables ?i corresponding to those in the LHS *) + +let compute_rhs bodyi index_of_f = + let rec aux c = + match kind_of_term c with + | App (j, args) when j = mkRel (index_of_f) (* recursive call *) -> + let i = destRel (array_last args) in + PMeta (Some (coerce_meta_in i)) + | App (f,args) -> + PApp (snd (pattern_of_constr Evd.empty f), Array.map aux args) + | Cast (c,_,_) -> aux c + | _ -> snd (pattern_of_constr Evd.empty c) + in + aux bodyi + +(*s Now the function [compute_ivs] itself *) + +let compute_ivs gl f cs = + let cst = try destConst f with _ -> i_can't_do_that () in + let body = Environ.constant_value (Global.env()) cst in + match decomp_term body with + | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> + let (args3, body3) = decompose_lam body2 in + let nargs3 = List.length args3 in + begin match decomp_term body3 with + | Case(_,p,c,lci) -> (*

Case c of c1 ... cn end *) + let n_lhs_rhs = ref [] + and v_lhs = ref (None : constr option) + and c_lhs = ref (None : constr option) in + Array.iteri + (fun i ci -> + let argsi, bodyi = decompose_lam ci in + let nargsi = List.length argsi in + (* REL (narg3 + nargsi + 1) is f *) + (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *) + (* REL 1 to REL nargsi are argsi (reverse order) *) + (* First we test if the RHS is the RHS for constants *) + if bodyi = mkRel 1 then + c_lhs := Some (compute_lhs (snd (List.hd args3)) + i nargsi) + (* Then we test if the RHS is the RHS for variables *) + else begin match decompose_app bodyi with + | vmf, [_; _; a3; a4 ] + when isRel a3 & isRel a4 & + pf_conv_x gl vmf + (Lazy.force coq_varmap_find)-> + v_lhs := Some (compute_lhs + (snd (List.hd args3)) + i nargsi) + (* Third case: this is a normal LHS-RHS *) + | _ -> + n_lhs_rhs := + (compute_lhs (snd (List.hd args3)) i nargsi, + compute_rhs bodyi (nargs3 + nargsi + 1)) + :: !n_lhs_rhs + end) + lci; + + if !c_lhs = None & !v_lhs = None then i_can't_do_that (); + + (* The Cases predicate is a lambda; we assume no dependency *) + let p = match kind_of_term p with + | Lambda (_,_,p) -> Termops.pop p + | _ -> p + in + + { normal_lhs_rhs = List.rev !n_lhs_rhs; + variable_lhs = !v_lhs; + return_type = p; + constants = List.fold_right ConstrSet.add cs ConstrSet.empty; + constant_lhs = !c_lhs } + + | _ -> i_can't_do_that () + end + |_ -> i_can't_do_that () + +(* TODO for that function: +\begin{itemize} +\item handle the case where the return type is an argument of the + function +\item handle the case of simple mutual inductive (for example terms + and lists of terms) formulas with the corresponding mutual + recursvive interpretation functions. +\end{itemize} +*) + +(*s Stuff to build variables map, currently implemented as complete +binary search trees (see file \texttt{Quote.v}) *) + +(* First the function to distinghish between constants (closed terms) + and variables (open terms) *) + +let rec closed_under cset t = + (ConstrSet.mem t cset) or + (match (kind_of_term t) with + | Cast(c,_,_) -> closed_under cset c + | App(f,l) -> closed_under cset f && array_for_all (closed_under cset) l + | _ -> false) + +(*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete + binary search tree containing the [ci], that is: + +\begin{verbatim} + c1 + / \ + c2 c3 + / \ + c4 c5 +\end{verbatim} + +The second argument is a constr (the common type of the [ci]) +*) + +let btree_of_array a ty = + let size_of_a = Array.length a in + let semi_size_of_a = size_of_a lsr 1 in + let node = Lazy.force coq_Node_vm + and empty = mkApp (Lazy.force coq_Empty_vm, [| ty |]) in + let rec aux n = + if n > size_of_a + then empty + else if n > semi_size_of_a + then mkApp (node, [| ty; a.(n-1); empty; empty |]) + else mkApp (node, [| ty; a.(n-1); aux (2*n); aux (2*n+1) |]) + in + aux 1 + +(*s [btree_of_array] and [path_of_int] verify the following invariant:\\ + {\tt (varmap\_find A dv }[(path_of_int n)] [(btree_of_array a ty)] + = [a.(n)]\\ + [n] must be [> 0] *) + +let path_of_int n = + (* returns the list of digits of n in reverse order with + initial 1 removed *) + 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 b c -> mkApp ((if b then Lazy.force coq_Right_idx + else Lazy.force coq_Left_idx), + [| c |])) + (List.rev (digits_of_int n)) + (Lazy.force coq_End_idx) + +(*s The tactic works with a list of subterms sharing the same + variables map. We need to sort terms in order to avoid than + strange things happen during replacement of terms by their + 'abstract' counterparties. *) + +(* [subterm t t'] tests if constr [t'] occurs in [t] *) +(* This function does not descend under binders (lambda and Cases) *) + +let rec subterm gl (t : constr) (t' : constr) = + (pf_conv_x gl t t') or + (match (kind_of_term t) with + | App (f,args) -> array_exists (fun t -> subterm gl t t') args + | Cast(t,_,_) -> (subterm gl t t') + | _ -> false) + +(*s We want to sort the list according to reverse subterm order. *) +(* Since it's a partial order the algoritm of Sort.list won't work !! *) + +let rec sort_subterm gl l = + let rec insert c = function + | [] -> [c] + | (h::t as l) when c = h -> l (* Avoid doing the same work twice *) + | h::t -> if subterm gl c h then c::h::t else h::(insert c t) + in + match l with + | [] -> [] + | h::t -> insert h (sort_subterm gl t) + +(*s Now we are able to do the inversion itself. + We destructurate the term and use an imperative hashtable + to store leafs that are already encountered. + The type of arguments is:\\ + [ivs : inversion_scheme]\\ + [lc: constr list]\\ + [gl: goal sigma]\\ *) + +let quote_terms ivs lc gl = + Coqlib.check_required_library ["Coq";"quote";"Quote"]; + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + let rec aux c = + let rec auxl l = + match l with + | (lhs, rhs)::tail -> + begin try + let s1 = matches rhs c in + let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1 + in + Termops.subst_meta s2 lhs + with PatternMatchingFailure -> auxl tail + end + | [] -> + begin match ivs.variable_lhs with + | None -> + begin match ivs.constant_lhs with + | Some c_lhs -> Termops.subst_meta [1, c] c_lhs + | None -> anomaly "invalid inversion scheme for quote" + end + | Some var_lhs -> + begin match ivs.constant_lhs with + | Some c_lhs when closed_under ivs.constants c -> + Termops.subst_meta [1, c] c_lhs + | _ -> + begin + try Hashtbl.find varhash c + with Not_found -> + let newvar = + Termops.subst_meta [1, (path_of_int !counter)] + var_lhs in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + end + end + end + in + auxl ivs.normal_lhs_rhs + in + let lp = List.map aux lc in + (lp, (btree_of_array (Array.of_list (List.rev !varlist)) + ivs.return_type )) + +(*s actually we could "quote" a list of terms instead of a single + term. Ring for example needs that, but Ring doesn't use Quote + yet. *) + +let quote f lid gl = + let f = pf_global gl f in + let cl = List.map (pf_global gl) lid in + let ivs = compute_ivs gl f cl in + let (p, vm) = match quote_terms ivs [(pf_concl gl)] gl with + | [p], vm -> (p,vm) + | _ -> assert false + in + match ivs.variable_lhs with + | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast gl + | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast gl + +let gen_quote cont c f lid gl = + let f = pf_global gl f in + let cl = List.map (pf_global gl) lid in + let ivs = compute_ivs gl f cl in + let (p, vm) = match quote_terms ivs [c] gl with + | [p], vm -> (p,vm) + | _ -> assert false + in + match ivs.variable_lhs with + | None -> cont (mkApp (f, [| p |])) gl + | Some _ -> cont (mkApp (f, [| vm; p |])) gl + +(*i + +Just testing ... + +#use "include.ml";; +open Quote;; + +let r = raw_constr_of_string;; + +let ivs = { + normal_lhs_rhs = + [ r "(f_and ?1 ?2)", r "?1/\?2"; + r "(f_not ?1)", r "~?1"]; + variable_lhs = Some (r "(f_atom ?1)"); + return_type = r "Prop"; + constants = ConstrSet.empty; + constant_lhs = (r "nat") +};; + +let t1 = r "True/\(True /\ ~False)";; +let t2 = r "True/\~~False";; + +quote_term ivs () t1;; +quote_term ivs () t2;; + +let ivs2 = + normal_lhs_rhs = + [ r "(f_and ?1 ?2)", r "?1/\?2"; + r "(f_not ?1)", r "~?1" + r "True", r "f_true"]; + variable_lhs = Some (r "(f_atom ?1)"); + return_type = r "Prop"; + constants = ConstrSet.empty; + constant_lhs = (r "nat") + +i*) diff --git a/plugins/quote/quote_plugin.mllib b/plugins/quote/quote_plugin.mllib new file mode 100644 index 00000000..d1b3ccbe --- /dev/null +++ b/plugins/quote/quote_plugin.mllib @@ -0,0 +1,3 @@ +Quote +G_quote +Quote_plugin_mod diff --git a/plugins/quote/vo.itarget b/plugins/quote/vo.itarget new file mode 100644 index 00000000..7a44fc5a --- /dev/null +++ b/plugins/quote/vo.itarget @@ -0,0 +1 @@ +Quote.vo \ No newline at end of file diff --git a/plugins/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v new file mode 100644 index 00000000..231b5fbb --- /dev/null +++ b/plugins/ring/LegacyArithRing.v @@ -0,0 +1,90 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* true + | S n', S m' => nateq n' m' + | _, _ => false + end. + +Lemma nateq_prop : forall n m:nat, Is_true (nateq n m) -> n = m. +Proof. + simple induction n; simple induction m; intros; try contradiction. + trivial. + unfold Is_true in H1. + rewrite (H n1 H1). + trivial. +Qed. + +Hint Resolve nateq_prop: arithring. + +Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq. + split; intros; auto with arith arithring. +(* apply (fun n m p:nat => plus_reg_l m p n) with (n := n). + trivial.*) +Defined. + + +Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ]. + +Goal forall n:nat, S n = 1 + n. +intro; reflexivity. +Save S_to_plus_one. + +(* Replace all occurrences of (S exp) by (plus (S O) exp), except when + exp is already O and only for those occurrences than can be reached by going + down plus and mult operations *) +Ltac rewrite_S_to_plus_term t := + match constr:t with + | 1 => constr:1 + | (S ?X1) => + let t1 := rewrite_S_to_plus_term X1 in + constr:(1 + t1) + | (?X1 + ?X2) => + let t1 := rewrite_S_to_plus_term X1 + with t2 := rewrite_S_to_plus_term X2 in + constr:(t1 + t2) + | (?X1 * ?X2) => + let t1 := rewrite_S_to_plus_term X1 + with t2 := rewrite_S_to_plus_term X2 in + constr:(t1 * t2) + | _ => constr:t + end. + +(* Apply S_to_plus on both sides of an equality *) +Ltac rewrite_S_to_plus := + match goal with + | |- (?X1 = ?X2) => + try + let t1 := + (**) (**) + rewrite_S_to_plus_term X1 + with t2 := rewrite_S_to_plus_term X2 in + change (t1 = t2) in |- * + | |- (?X1 = ?X2) => + try + let t1 := + (**) (**) + rewrite_S_to_plus_term X1 + with t2 := rewrite_S_to_plus_term X2 in + change (t1 = t2) in |- * + end. + +Ltac ring_nat := rewrite_S_to_plus; ring. diff --git a/plugins/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v new file mode 100644 index 00000000..ee9fb376 --- /dev/null +++ b/plugins/ring/LegacyNArithRing.v @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* true + | _ => false + end. + +Lemma Neq_prop : forall n m:N, Is_true (Neq n m) -> n = m. + intros n m H; unfold Neq in H. + apply Ncompare_Eq_eq. + destruct (n ?= m)%N; [ reflexivity | contradiction | contradiction ]. +Qed. + +Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N Neq. + split. + apply Nplus_comm. + apply Nplus_assoc. + apply Nmult_comm. + apply Nmult_assoc. + apply Nplus_0_l. + apply Nmult_1_l. + apply Nmult_0_l. + apply Nmult_plus_distr_r. +(* apply Nplus_reg_l.*) + apply Neq_prop. +Qed. + +Add Legacy Semi Ring + N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ]. diff --git a/plugins/ring/LegacyRing.v b/plugins/ring/LegacyRing.v new file mode 100644 index 00000000..4ae85baf --- /dev/null +++ b/plugins/ring/LegacyRing.v @@ -0,0 +1,37 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* b) eqb. +split; simpl in |- *. +destruct n; destruct m; reflexivity. +destruct n; destruct m; destruct p; reflexivity. +destruct n; destruct m; reflexivity. +destruct n; destruct m; destruct p; reflexivity. +destruct n; reflexivity. +destruct n; reflexivity. +destruct n; reflexivity. +destruct n; destruct m; destruct p; reflexivity. +destruct x; destruct y; reflexivity || simpl in |- *; tauto. +Defined. + +Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory + [ true false ]. diff --git a/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v new file mode 100644 index 00000000..30d29515 --- /dev/null +++ b/plugins/ring/LegacyRing_theory.v @@ -0,0 +1,376 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +(* There is also a "weakly decidable" equality on A. That means + that if (A_eq x y)=true then x=y but x=y can arise when + (A_eq x y)=false. On an abstract ring the function [x,y:A]false + is a good choice. The proof of A_eq_prop is in this case easy. *) +Variable Aeq : A -> A -> bool. + +Infix "+" := Aplus (at level 50, left associativity). +Infix "*" := Amult (at level 40, left associativity). +Notation "0" := Azero. +Notation "1" := Aone. + +Record Semi_Ring_Theory : Prop := + {SR_plus_comm : forall n m:A, n + m = m + n; + SR_plus_assoc : forall n m p:A, n + (m + p) = n + m + p; + SR_mult_comm : forall n m:A, n * m = m * n; + SR_mult_assoc : forall n m p:A, n * (m * p) = n * m * p; + SR_plus_zero_left : forall n:A, 0 + n = n; + SR_mult_one_left : forall n:A, 1 * n = n; + SR_mult_zero_left : forall n:A, 0 * n = 0; + SR_distr_left : forall n m p:A, (n + m) * p = n * p + m * p; +(* SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p;*) + SR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}. + +Variable T : Semi_Ring_Theory. + +Let plus_comm := SR_plus_comm T. +Let plus_assoc := SR_plus_assoc T. +Let mult_comm := SR_mult_comm T. +Let mult_assoc := SR_mult_assoc T. +Let plus_zero_left := SR_plus_zero_left T. +Let mult_one_left := SR_mult_one_left T. +Let mult_zero_left := SR_mult_zero_left T. +Let distr_left := SR_distr_left T. +(*Let plus_reg_left := SR_plus_reg_left T.*) + +Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left + mult_one_left mult_zero_left distr_left (*plus_reg_left*). + +(* Lemmas whose form is x=y are also provided in form y=x because Auto does + not symmetry *) +Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). +symmetry in |- *; eauto. Qed. + +Lemma SR_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p). +symmetry in |- *; eauto. Qed. + +Lemma SR_plus_zero_left2 : forall n:A, n = 0 + n. +symmetry in |- *; eauto. Qed. + +Lemma SR_mult_one_left2 : forall n:A, n = 1 * n. +symmetry in |- *; eauto. Qed. + +Lemma SR_mult_zero_left2 : forall n:A, 0 = 0 * n. +symmetry in |- *; eauto. Qed. + +Lemma SR_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p. +symmetry in |- *; eauto. Qed. + +Lemma SR_plus_permute : forall n m p:A, n + (m + p) = m + (n + p). +intros. +rewrite plus_assoc. +elim (plus_comm m n). +rewrite <- plus_assoc. +reflexivity. +Qed. + +Lemma SR_mult_permute : forall n m p:A, n * (m * p) = m * (n * p). +intros. +rewrite mult_assoc. +elim (mult_comm m n). +rewrite <- mult_assoc. +reflexivity. +Qed. + +Hint Resolve SR_plus_permute SR_mult_permute. + +Lemma SR_distr_right : forall n m p:A, n * (m + p) = n * m + n * p. +intros. +repeat rewrite (mult_comm n). +eauto. +Qed. + +Lemma SR_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p). +symmetry in |- *; apply SR_distr_right. Qed. + +Lemma SR_mult_zero_right : forall n:A, n * 0 = 0. +intro; rewrite mult_comm; eauto. +Qed. + +Lemma SR_mult_zero_right2 : forall n:A, 0 = n * 0. +intro; rewrite mult_comm; eauto. +Qed. + +Lemma SR_plus_zero_right : forall n:A, n + 0 = n. +intro; rewrite plus_comm; eauto. +Qed. +Lemma SR_plus_zero_right2 : forall n:A, n = n + 0. +intro; rewrite plus_comm; eauto. +Qed. + +Lemma SR_mult_one_right : forall n:A, n * 1 = n. +intro; elim mult_comm; auto. +Qed. + +Lemma SR_mult_one_right2 : forall n:A, n = n * 1. +intro; elim mult_comm; auto. +Qed. +(* +Lemma SR_plus_reg_right : forall n m p:A, m + n = p + n -> m = p. +intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n); eauto. +Qed. +*) +End Theory_of_semi_rings. + +Section Theory_of_rings. + +Variable A : Type. + +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aopp : A -> A. +Variable Aeq : A -> A -> bool. + +Infix "+" := Aplus (at level 50, left associativity). +Infix "*" := Amult (at level 40, left associativity). +Notation "0" := Azero. +Notation "1" := Aone. +Notation "- x" := (Aopp x). + +Record Ring_Theory : Prop := + {Th_plus_comm : forall n m:A, n + m = m + n; + Th_plus_assoc : forall n m p:A, n + (m + p) = n + m + p; + Th_mult_comm : forall n m:A, n * m = m * n; + Th_mult_assoc : forall n m p:A, n * (m * p) = n * m * p; + Th_plus_zero_left : forall n:A, 0 + n = n; + Th_mult_one_left : forall n:A, 1 * n = n; + Th_opp_def : forall n:A, n + - n = 0; + Th_distr_left : forall n m p:A, (n + m) * p = n * p + m * p; + Th_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}. + +Variable T : Ring_Theory. + +Let plus_comm := Th_plus_comm T. +Let plus_assoc := Th_plus_assoc T. +Let mult_comm := Th_mult_comm T. +Let mult_assoc := Th_mult_assoc T. +Let plus_zero_left := Th_plus_zero_left T. +Let mult_one_left := Th_mult_one_left T. +Let opp_def := Th_opp_def T. +Let distr_left := Th_distr_left T. + +Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left + mult_one_left opp_def distr_left. + +(* Lemmas whose form is x=y are also provided in form y=x because Auto does + not symmetry *) +Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). +symmetry in |- *; eauto. Qed. + +Lemma Th_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p). +symmetry in |- *; eauto. Qed. + +Lemma Th_plus_zero_left2 : forall n:A, n = 0 + n. +symmetry in |- *; eauto. Qed. + +Lemma Th_mult_one_left2 : forall n:A, n = 1 * n. +symmetry in |- *; eauto. Qed. + +Lemma Th_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p. +symmetry in |- *; eauto. Qed. + +Lemma Th_opp_def2 : forall n:A, 0 = n + - n. +symmetry in |- *; eauto. Qed. + +Lemma Th_plus_permute : forall n m p:A, n + (m + p) = m + (n + p). +intros. +rewrite plus_assoc. +elim (plus_comm m n). +rewrite <- plus_assoc. +reflexivity. +Qed. + +Lemma Th_mult_permute : forall n m p:A, n * (m * p) = m * (n * p). +intros. +rewrite mult_assoc. +elim (mult_comm m n). +rewrite <- mult_assoc. +reflexivity. +Qed. + +Hint Resolve Th_plus_permute Th_mult_permute. + +Lemma aux1 : forall a:A, a + a = a -> a = 0. +intros. +generalize (opp_def a). +pattern a at 1 in |- *. +rewrite <- H. +rewrite <- plus_assoc. +rewrite opp_def. +elim plus_comm. +rewrite plus_zero_left. +trivial. +Qed. + +Lemma Th_mult_zero_left : forall n:A, 0 * n = 0. +intros. +apply aux1. +rewrite <- distr_left. +rewrite plus_zero_left. +reflexivity. +Qed. +Hint Resolve Th_mult_zero_left. + +Lemma Th_mult_zero_left2 : forall n:A, 0 = 0 * n. +symmetry in |- *; eauto. Qed. + +Lemma aux2 : forall x y z:A, x + y = 0 -> x + z = 0 -> y = z. +intros. +rewrite <- (plus_zero_left y). +elim H0. +elim plus_assoc. +elim (plus_comm y z). +rewrite plus_assoc. +rewrite H. +rewrite plus_zero_left. +reflexivity. +Qed. + +Lemma Th_opp_mult_left : forall x y:A, - (x * y) = - x * y. +intros. +apply (aux2 (x:=(x * y))); + [ apply opp_def | rewrite <- distr_left; rewrite opp_def; auto ]. +Qed. +Hint Resolve Th_opp_mult_left. + +Lemma Th_opp_mult_left2 : forall x y:A, - x * y = - (x * y). +symmetry in |- *; eauto. Qed. + +Lemma Th_mult_zero_right : forall n:A, n * 0 = 0. +intro; elim mult_comm; eauto. +Qed. + +Lemma Th_mult_zero_right2 : forall n:A, 0 = n * 0. +intro; elim mult_comm; eauto. +Qed. + +Lemma Th_plus_zero_right : forall n:A, n + 0 = n. +intro; rewrite plus_comm; eauto. +Qed. + +Lemma Th_plus_zero_right2 : forall n:A, n = n + 0. +intro; rewrite plus_comm; eauto. +Qed. + +Lemma Th_mult_one_right : forall n:A, n * 1 = n. +intro; elim mult_comm; eauto. +Qed. + +Lemma Th_mult_one_right2 : forall n:A, n = n * 1. +intro; elim mult_comm; eauto. +Qed. + +Lemma Th_opp_mult_right : forall x y:A, - (x * y) = x * - y. +intros; do 2 rewrite (mult_comm x); auto. +Qed. + +Lemma Th_opp_mult_right2 : forall x y:A, x * - y = - (x * y). +intros; do 2 rewrite (mult_comm x); auto. +Qed. + +Lemma Th_plus_opp_opp : forall x y:A, - x + - y = - (x + y). +intros. +apply (aux2 (x:=(x + y))); + [ elim plus_assoc; rewrite (Th_plus_permute y (- x)); rewrite plus_assoc; + rewrite opp_def; rewrite plus_zero_left; auto + | auto ]. +Qed. + +Lemma Th_plus_permute_opp : forall n m p:A, - m + (n + p) = n + (- m + p). +eauto. Qed. + +Lemma Th_opp_opp : forall n:A, - - n = n. +intro; apply (aux2 (x:=(- n))); [ auto | elim plus_comm; auto ]. +Qed. +Hint Resolve Th_opp_opp. + +Lemma Th_opp_opp2 : forall n:A, n = - - n. +symmetry in |- *; eauto. Qed. + +Lemma Th_mult_opp_opp : forall x y:A, - x * - y = x * y. +intros; rewrite <- Th_opp_mult_left; rewrite <- Th_opp_mult_right; auto. +Qed. + +Lemma Th_mult_opp_opp2 : forall x y:A, x * y = - x * - y. +symmetry in |- *; apply Th_mult_opp_opp. Qed. + +Lemma Th_opp_zero : - 0 = 0. +rewrite <- (plus_zero_left (- 0)). +auto. Qed. +(* +Lemma Th_plus_reg_left : forall n m p:A, n + m = n + p -> m = p. +intros; generalize (f_equal (fun z => - n + z) H). +repeat rewrite plus_assoc. +rewrite (plus_comm (- n) n). +rewrite opp_def. +repeat rewrite Th_plus_zero_left; eauto. +Qed. + +Lemma Th_plus_reg_right : forall n m p:A, m + n = p + n -> m = p. +intros. +eapply Th_plus_reg_left with n. +rewrite (plus_comm n m). +rewrite (plus_comm n p). +auto. +Qed. +*) +Lemma Th_distr_right : forall n m p:A, n * (m + p) = n * m + n * p. +intros. +repeat rewrite (mult_comm n). +eauto. +Qed. + +Lemma Th_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p). +symmetry in |- *; apply Th_distr_right. +Qed. + +End Theory_of_rings. + +Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core. + +Unset Implicit Arguments. + +Definition Semi_Ring_Theory_of : + forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A) + (Aopp:A -> A) (Aeq:A -> A -> bool), + Ring_Theory Aplus Amult Aone Azero Aopp Aeq -> + Semi_Ring_Theory Aplus Amult Aone Azero Aeq. +intros until 1; case H. +split; intros; simpl in |- *; eauto. +Defined. + +(* Every ring can be viewed as a semi-ring : this property will be used + in Abstract_polynom. *) +Coercion Semi_Ring_Theory_of : Ring_Theory >-> Semi_Ring_Theory. + + +Section product_ring. + +End product_ring. + +Section power_ring. + +End power_ring. diff --git a/plugins/ring/LegacyZArithRing.v b/plugins/ring/LegacyZArithRing.v new file mode 100644 index 00000000..68a0dd27 --- /dev/null +++ b/plugins/ring/LegacyZArithRing.v @@ -0,0 +1,37 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* true + | _ => false + end. + +Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y. + intros x y H; unfold Zeq in H. + apply Zcompare_Eq_eq. + destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ]. +Qed. + +Definition ZTheory : Ring_Theory Zplus Zmult 1%Z 0%Z Zopp Zeq. + split; intros; eauto with zarith. + apply Zeq_prop; assumption. +Qed. + +(* NatConstants and NatTheory are defined in Ring_theory.v *) +Add Legacy Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory + [ Zpos Zneg 0%Z xO xI 1%positive ]. diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v new file mode 100644 index 00000000..2a9df21b --- /dev/null +++ b/plugins/ring/Ring_abstract.v @@ -0,0 +1,706 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* aspolynomial + | ASP0 : aspolynomial + | ASP1 : aspolynomial + | ASPplus : aspolynomial -> aspolynomial -> aspolynomial + | ASPmult : aspolynomial -> aspolynomial -> aspolynomial. + +Inductive abstract_sum : Type := + | Nil_acs : abstract_sum + | Cons_acs : varlist -> abstract_sum -> abstract_sum. + +Fixpoint abstract_sum_merge (s1:abstract_sum) : + abstract_sum -> abstract_sum := + match s1 with + | Cons_acs l1 t1 => + (fix asm_aux (s2:abstract_sum) : abstract_sum := + match s2 with + | Cons_acs l2 t2 => + if varlist_lt l1 l2 + then Cons_acs l1 (abstract_sum_merge t1 s2) + else Cons_acs l2 (asm_aux t2) + | Nil_acs => s1 + end) + | Nil_acs => fun s2 => s2 + end. + +Fixpoint abstract_varlist_insert (l1:varlist) (s2:abstract_sum) {struct s2} : + abstract_sum := + match s2 with + | Cons_acs l2 t2 => + if varlist_lt l1 l2 + then Cons_acs l1 s2 + else Cons_acs l2 (abstract_varlist_insert l1 t2) + | Nil_acs => Cons_acs l1 Nil_acs + end. + +Fixpoint abstract_sum_scalar (l1:varlist) (s2:abstract_sum) {struct s2} : + abstract_sum := + match s2 with + | Cons_acs l2 t2 => + abstract_varlist_insert (varlist_merge l1 l2) + (abstract_sum_scalar l1 t2) + | Nil_acs => Nil_acs + end. + +Fixpoint abstract_sum_prod (s1 s2:abstract_sum) {struct s1} : abstract_sum := + match s1 with + | Cons_acs l1 t1 => + abstract_sum_merge (abstract_sum_scalar l1 s2) + (abstract_sum_prod t1 s2) + | Nil_acs => Nil_acs + end. + +Fixpoint aspolynomial_normalize (p:aspolynomial) : abstract_sum := + match p with + | ASPvar i => Cons_acs (Cons_var i Nil_var) Nil_acs + | ASP1 => Cons_acs Nil_var Nil_acs + | ASP0 => Nil_acs + | ASPplus l r => + abstract_sum_merge (aspolynomial_normalize l) + (aspolynomial_normalize r) + | ASPmult l r => + abstract_sum_prod (aspolynomial_normalize l) (aspolynomial_normalize r) + end. + + + +Variable A : Type. +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aeq : A -> A -> bool. +Variable vm : varmap A. +Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq. + +Fixpoint interp_asp (p:aspolynomial) : A := + match p with + | ASPvar i => interp_var Azero vm i + | ASP0 => Azero + | ASP1 => Aone + | ASPplus l r => Aplus (interp_asp l) (interp_asp r) + | ASPmult l r => Amult (interp_asp l) (interp_asp r) + end. + +(* Local *) Definition iacs_aux := + (fix iacs_aux (a:A) (s:abstract_sum) {struct s} : A := + match s with + | Nil_acs => a + | Cons_acs l t => + Aplus a (iacs_aux (interp_vl Amult Aone Azero vm l) t) + end). + +Definition interp_acs (s:abstract_sum) : A := + match s with + | Cons_acs l t => iacs_aux (interp_vl Amult Aone Azero vm l) t + | Nil_acs => Azero + end. + +Hint Resolve (SR_plus_comm T). +Hint Resolve (SR_plus_assoc T). +Hint Resolve (SR_plus_assoc2 T). +Hint Resolve (SR_mult_comm T). +Hint Resolve (SR_mult_assoc T). +Hint Resolve (SR_mult_assoc2 T). +Hint Resolve (SR_plus_zero_left T). +Hint Resolve (SR_plus_zero_left2 T). +Hint Resolve (SR_mult_one_left T). +Hint Resolve (SR_mult_one_left2 T). +Hint Resolve (SR_mult_zero_left T). +Hint Resolve (SR_mult_zero_left2 T). +Hint Resolve (SR_distr_left T). +Hint Resolve (SR_distr_left2 T). +(*Hint Resolve (SR_plus_reg_left T).*) +Hint Resolve (SR_plus_permute T). +Hint Resolve (SR_mult_permute T). +Hint Resolve (SR_distr_right T). +Hint Resolve (SR_distr_right2 T). +Hint Resolve (SR_mult_zero_right T). +Hint Resolve (SR_mult_zero_right2 T). +Hint Resolve (SR_plus_zero_right T). +Hint Resolve (SR_plus_zero_right2 T). +Hint Resolve (SR_mult_one_right T). +Hint Resolve (SR_mult_one_right2 T). +(*Hint Resolve (SR_plus_reg_right T).*) +Hint Resolve refl_equal sym_equal trans_equal. +(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Immediate T. + +Remark iacs_aux_ok : + forall (x:A) (s:abstract_sum), iacs_aux x s = Aplus x (interp_acs s). +Proof. + simple induction s; simpl in |- *; intros. + trivial. + reflexivity. +Qed. + +Hint Extern 10 (_ = _ :>A) => rewrite iacs_aux_ok: core. + +Lemma abstract_varlist_insert_ok : + forall (l:varlist) (s:abstract_sum), + interp_acs (abstract_varlist_insert l s) = + Aplus (interp_vl Amult Aone Azero vm l) (interp_acs s). + + simple induction s. + trivial. + + simpl in |- *; intros. + elim (varlist_lt l v); simpl in |- *. + eauto. + rewrite iacs_aux_ok. + rewrite H; auto. + +Qed. + +Lemma abstract_sum_merge_ok : + forall x y:abstract_sum, + interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y). + +Proof. + simple induction x. + trivial. + simple induction y; intros. + + auto. + + simpl in |- *; elim (varlist_lt v v0); simpl in |- *. + repeat rewrite iacs_aux_ok. + rewrite H; simpl in |- *; auto. + + simpl in H0. + repeat rewrite iacs_aux_ok. + rewrite H0. simpl in |- *; auto. +Qed. + +Lemma abstract_sum_scalar_ok : + forall (l:varlist) (s:abstract_sum), + interp_acs (abstract_sum_scalar l s) = + Amult (interp_vl Amult Aone Azero vm l) (interp_acs s). +Proof. + simple induction s. + simpl in |- *; eauto. + + simpl in |- *; intros. + rewrite iacs_aux_ok. + rewrite abstract_varlist_insert_ok. + rewrite H. + rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). + auto. +Qed. + +Lemma abstract_sum_prod_ok : + forall x y:abstract_sum, + interp_acs (abstract_sum_prod x y) = Amult (interp_acs x) (interp_acs y). + +Proof. + simple induction x. + intros; simpl in |- *; eauto. + + destruct y as [| v0 a0]; intros. + + simpl in |- *; rewrite H; eauto. + + unfold abstract_sum_prod in |- *; fold abstract_sum_prod in |- *. + rewrite abstract_sum_merge_ok. + rewrite abstract_sum_scalar_ok. + rewrite H; simpl in |- *; auto. +Qed. + +Theorem aspolynomial_normalize_ok : + forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x). +Proof. + simple induction x; simpl in |- *; intros; trivial. + rewrite abstract_sum_merge_ok. + rewrite H; rewrite H0; eauto. + rewrite abstract_sum_prod_ok. + rewrite H; rewrite H0; eauto. +Qed. + +End abstract_semi_rings. + +Section abstract_rings. + +(* In abstract polynomials there is no constants other + than 0 and 1. An abstract ring is a ring whose operations plus, + and mult are not functions but constructors. In other words, + when c1 and c2 are closed, (plus c1 c2) doesn't reduce to a closed + term. "closed" mean here "without plus and mult". *) + +(* this section is not parametrized by a (semi-)ring. + Nevertheless, they are two different types for semi-rings and rings + and there will be 2 correction theorems *) + +Inductive apolynomial : Type := + | APvar : index -> apolynomial + | AP0 : apolynomial + | AP1 : apolynomial + | APplus : apolynomial -> apolynomial -> apolynomial + | APmult : apolynomial -> apolynomial -> apolynomial + | APopp : apolynomial -> apolynomial. + +(* A canonical "abstract" sum is a list of varlist with the sign "+" or "-". + Invariant : the list is sorted and there is no varlist is present + with both signs. +x +x +x -x is forbidden => the canonical form is +x+x *) + +Inductive signed_sum : Type := + | Nil_varlist : signed_sum + | Plus_varlist : varlist -> signed_sum -> signed_sum + | Minus_varlist : varlist -> signed_sum -> signed_sum. + +Fixpoint signed_sum_merge (s1:signed_sum) : signed_sum -> signed_sum := + match s1 with + | Plus_varlist l1 t1 => + (fix ssm_aux (s2:signed_sum) : signed_sum := + match s2 with + | Plus_varlist l2 t2 => + if varlist_lt l1 l2 + then Plus_varlist l1 (signed_sum_merge t1 s2) + else Plus_varlist l2 (ssm_aux t2) + | Minus_varlist l2 t2 => + if varlist_eq l1 l2 + then signed_sum_merge t1 t2 + else + if varlist_lt l1 l2 + then Plus_varlist l1 (signed_sum_merge t1 s2) + else Minus_varlist l2 (ssm_aux t2) + | Nil_varlist => s1 + end) + | Minus_varlist l1 t1 => + (fix ssm_aux2 (s2:signed_sum) : signed_sum := + match s2 with + | Plus_varlist l2 t2 => + if varlist_eq l1 l2 + then signed_sum_merge t1 t2 + else + if varlist_lt l1 l2 + then Minus_varlist l1 (signed_sum_merge t1 s2) + else Plus_varlist l2 (ssm_aux2 t2) + | Minus_varlist l2 t2 => + if varlist_lt l1 l2 + then Minus_varlist l1 (signed_sum_merge t1 s2) + else Minus_varlist l2 (ssm_aux2 t2) + | Nil_varlist => s1 + end) + | Nil_varlist => fun s2 => s2 + end. + +Fixpoint plus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} : + signed_sum := + match s2 with + | Plus_varlist l2 t2 => + if varlist_lt l1 l2 + then Plus_varlist l1 s2 + else Plus_varlist l2 (plus_varlist_insert l1 t2) + | Minus_varlist l2 t2 => + if varlist_eq l1 l2 + then t2 + else + if varlist_lt l1 l2 + then Plus_varlist l1 s2 + else Minus_varlist l2 (plus_varlist_insert l1 t2) + | Nil_varlist => Plus_varlist l1 Nil_varlist + end. + +Fixpoint minus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} : + signed_sum := + match s2 with + | Plus_varlist l2 t2 => + if varlist_eq l1 l2 + then t2 + else + if varlist_lt l1 l2 + then Minus_varlist l1 s2 + else Plus_varlist l2 (minus_varlist_insert l1 t2) + | Minus_varlist l2 t2 => + if varlist_lt l1 l2 + then Minus_varlist l1 s2 + else Minus_varlist l2 (minus_varlist_insert l1 t2) + | Nil_varlist => Minus_varlist l1 Nil_varlist + end. + +Fixpoint signed_sum_opp (s:signed_sum) : signed_sum := + match s with + | Plus_varlist l2 t2 => Minus_varlist l2 (signed_sum_opp t2) + | Minus_varlist l2 t2 => Plus_varlist l2 (signed_sum_opp t2) + | Nil_varlist => Nil_varlist + end. + + +Fixpoint plus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} : + signed_sum := + match s2 with + | Plus_varlist l2 t2 => + plus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2) + | Minus_varlist l2 t2 => + minus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2) + | Nil_varlist => Nil_varlist + end. + +Fixpoint minus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} : + signed_sum := + match s2 with + | Plus_varlist l2 t2 => + minus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2) + | Minus_varlist l2 t2 => + plus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2) + | Nil_varlist => Nil_varlist + end. + +Fixpoint signed_sum_prod (s1 s2:signed_sum) {struct s1} : signed_sum := + match s1 with + | Plus_varlist l1 t1 => + signed_sum_merge (plus_sum_scalar l1 s2) (signed_sum_prod t1 s2) + | Minus_varlist l1 t1 => + signed_sum_merge (minus_sum_scalar l1 s2) (signed_sum_prod t1 s2) + | Nil_varlist => Nil_varlist + end. + +Fixpoint apolynomial_normalize (p:apolynomial) : signed_sum := + match p with + | APvar i => Plus_varlist (Cons_var i Nil_var) Nil_varlist + | AP1 => Plus_varlist Nil_var Nil_varlist + | AP0 => Nil_varlist + | APplus l r => + signed_sum_merge (apolynomial_normalize l) (apolynomial_normalize r) + | APmult l r => + signed_sum_prod (apolynomial_normalize l) (apolynomial_normalize r) + | APopp q => signed_sum_opp (apolynomial_normalize q) + end. + + +Variable A : Type. +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aopp : A -> A. +Variable Aeq : A -> A -> bool. +Variable vm : varmap A. +Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. + +(* Local *) Definition isacs_aux := + (fix isacs_aux (a:A) (s:signed_sum) {struct s} : A := + match s with + | Nil_varlist => a + | Plus_varlist l t => + Aplus a (isacs_aux (interp_vl Amult Aone Azero vm l) t) + | Minus_varlist l t => + Aplus a + (isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t) + end). + +Definition interp_sacs (s:signed_sum) : A := + match s with + | Plus_varlist l t => isacs_aux (interp_vl Amult Aone Azero vm l) t + | Minus_varlist l t => isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t + | Nil_varlist => Azero + end. + +Fixpoint interp_ap (p:apolynomial) : A := + match p with + | APvar i => interp_var Azero vm i + | AP0 => Azero + | AP1 => Aone + | APplus l r => Aplus (interp_ap l) (interp_ap r) + | APmult l r => Amult (interp_ap l) (interp_ap r) + | APopp q => Aopp (interp_ap q) + end. + +Hint Resolve (Th_plus_comm T). +Hint Resolve (Th_plus_assoc T). +Hint Resolve (Th_plus_assoc2 T). +Hint Resolve (Th_mult_comm T). +Hint Resolve (Th_mult_assoc T). +Hint Resolve (Th_mult_assoc2 T). +Hint Resolve (Th_plus_zero_left T). +Hint Resolve (Th_plus_zero_left2 T). +Hint Resolve (Th_mult_one_left T). +Hint Resolve (Th_mult_one_left2 T). +Hint Resolve (Th_mult_zero_left T). +Hint Resolve (Th_mult_zero_left2 T). +Hint Resolve (Th_distr_left T). +Hint Resolve (Th_distr_left2 T). +(*Hint Resolve (Th_plus_reg_left T).*) +Hint Resolve (Th_plus_permute T). +Hint Resolve (Th_mult_permute T). +Hint Resolve (Th_distr_right T). +Hint Resolve (Th_distr_right2 T). +Hint Resolve (Th_mult_zero_right2 T). +Hint Resolve (Th_plus_zero_right T). +Hint Resolve (Th_plus_zero_right2 T). +Hint Resolve (Th_mult_one_right T). +Hint Resolve (Th_mult_one_right2 T). +(*Hint Resolve (Th_plus_reg_right T).*) +Hint Resolve refl_equal sym_equal trans_equal. +(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Immediate T. + +Lemma isacs_aux_ok : + forall (x:A) (s:signed_sum), isacs_aux x s = Aplus x (interp_sacs s). +Proof. + simple induction s; simpl in |- *; intros. + trivial. + reflexivity. + reflexivity. +Qed. + +Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core. + +Ltac solve1 v v0 H H0 := + simpl in |- *; elim (varlist_lt v v0); simpl in |- *; rewrite isacs_aux_ok; + [ rewrite H; simpl in |- *; auto | simpl in H0; rewrite H0; auto ]. + +Lemma signed_sum_merge_ok : + forall x y:signed_sum, + interp_sacs (signed_sum_merge x y) = Aplus (interp_sacs x) (interp_sacs y). + + simple induction x. + intro; simpl in |- *; auto. + + simple induction y; intros. + + auto. + + solve1 v v0 H H0. + + simpl in |- *; generalize (varlist_eq_prop v v0). + elim (varlist_eq v v0); simpl in |- *. + + intro Heq; rewrite (Heq I). + rewrite H. + repeat rewrite isacs_aux_ok. + rewrite (Th_plus_permute T). + repeat rewrite (Th_plus_assoc T). + rewrite + (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v0)) + (interp_vl Amult Aone Azero vm v0)). + rewrite (Th_opp_def T). + rewrite (Th_plus_zero_left T). + reflexivity. + + solve1 v v0 H H0. + + simple induction y; intros. + + auto. + + simpl in |- *; generalize (varlist_eq_prop v v0). + elim (varlist_eq v v0); simpl in |- *. + + intro Heq; rewrite (Heq I). + rewrite H. + repeat rewrite isacs_aux_ok. + rewrite (Th_plus_permute T). + repeat rewrite (Th_plus_assoc T). + rewrite (Th_opp_def T). + rewrite (Th_plus_zero_left T). + reflexivity. + + solve1 v v0 H H0. + + solve1 v v0 H H0. + +Qed. + +Ltac solve2 l v H := + elim (varlist_lt l v); simpl in |- *; rewrite isacs_aux_ok; + [ auto | rewrite H; auto ]. + +Lemma plus_varlist_insert_ok : + forall (l:varlist) (s:signed_sum), + interp_sacs (plus_varlist_insert l s) = + Aplus (interp_vl Amult Aone Azero vm l) (interp_sacs s). +Proof. + + simple induction s. + trivial. + + simpl in |- *; intros. + solve2 l v H. + + simpl in |- *; intros. + generalize (varlist_eq_prop l v). + elim (varlist_eq l v); simpl in |- *. + + intro Heq; rewrite (Heq I). + repeat rewrite isacs_aux_ok. + repeat rewrite (Th_plus_assoc T). + rewrite (Th_opp_def T). + rewrite (Th_plus_zero_left T). + reflexivity. + + solve2 l v H. + +Qed. + +Lemma minus_varlist_insert_ok : + forall (l:varlist) (s:signed_sum), + interp_sacs (minus_varlist_insert l s) = + Aplus (Aopp (interp_vl Amult Aone Azero vm l)) (interp_sacs s). +Proof. + + simple induction s. + trivial. + + simpl in |- *; intros. + generalize (varlist_eq_prop l v). + elim (varlist_eq l v); simpl in |- *. + + intro Heq; rewrite (Heq I). + repeat rewrite isacs_aux_ok. + repeat rewrite (Th_plus_assoc T). + rewrite + (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v)) + (interp_vl Amult Aone Azero vm v)). + rewrite (Th_opp_def T). + auto. + + simpl in |- *; intros. + solve2 l v H. + + simpl in |- *; intros; solve2 l v H. + +Qed. + +Lemma signed_sum_opp_ok : + forall s:signed_sum, interp_sacs (signed_sum_opp s) = Aopp (interp_sacs s). +Proof. + + simple induction s; simpl in |- *; intros. + + symmetry in |- *; apply (Th_opp_zero T). + + repeat rewrite isacs_aux_ok. + rewrite H. + rewrite (Th_plus_opp_opp T). + reflexivity. + + repeat rewrite isacs_aux_ok. + rewrite H. + rewrite <- (Th_plus_opp_opp T). + rewrite (Th_opp_opp T). + reflexivity. + +Qed. + +Lemma plus_sum_scalar_ok : + forall (l:varlist) (s:signed_sum), + interp_sacs (plus_sum_scalar l s) = + Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s). +Proof. + + simple induction s. + trivial. + + simpl in |- *; intros. + rewrite plus_varlist_insert_ok. + rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). + repeat rewrite isacs_aux_ok. + rewrite H. + auto. + + simpl in |- *; intros. + rewrite minus_varlist_insert_ok. + repeat rewrite isacs_aux_ok. + rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). + rewrite H. + rewrite (Th_distr_right T). + rewrite <- (Th_opp_mult_right T). + reflexivity. + +Qed. + +Lemma minus_sum_scalar_ok : + forall (l:varlist) (s:signed_sum), + interp_sacs (minus_sum_scalar l s) = + Aopp (Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s)). +Proof. + + simple induction s; simpl in |- *; intros. + + rewrite (Th_mult_zero_right T); symmetry in |- *; apply (Th_opp_zero T). + + simpl in |- *; intros. + rewrite minus_varlist_insert_ok. + rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). + repeat rewrite isacs_aux_ok. + rewrite H. + rewrite (Th_distr_right T). + rewrite (Th_plus_opp_opp T). + reflexivity. + + simpl in |- *; intros. + rewrite plus_varlist_insert_ok. + repeat rewrite isacs_aux_ok. + rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). + rewrite H. + rewrite (Th_distr_right T). + rewrite <- (Th_opp_mult_right T). + rewrite <- (Th_plus_opp_opp T). + rewrite (Th_opp_opp T). + reflexivity. + +Qed. + +Lemma signed_sum_prod_ok : + forall x y:signed_sum, + interp_sacs (signed_sum_prod x y) = Amult (interp_sacs x) (interp_sacs y). +Proof. + + simple induction x. + + simpl in |- *; eauto 1. + + intros; simpl in |- *. + rewrite signed_sum_merge_ok. + rewrite plus_sum_scalar_ok. + repeat rewrite isacs_aux_ok. + rewrite H. + auto. + + intros; simpl in |- *. + repeat rewrite isacs_aux_ok. + rewrite signed_sum_merge_ok. + rewrite minus_sum_scalar_ok. + rewrite H. + rewrite (Th_distr_left T). + rewrite (Th_opp_mult_left T). + reflexivity. + +Qed. + +Theorem apolynomial_normalize_ok : + forall p:apolynomial, interp_sacs (apolynomial_normalize p) = interp_ap p. +Proof. + simple induction p; simpl in |- *; auto 1. + intros. + rewrite signed_sum_merge_ok. + rewrite H; rewrite H0; reflexivity. + intros. + rewrite signed_sum_prod_ok. + rewrite H; rewrite H0; reflexivity. + intros. + rewrite signed_sum_opp_ok. + rewrite H; reflexivity. +Qed. + +End abstract_rings. diff --git a/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v new file mode 100644 index 00000000..7aeee218 --- /dev/null +++ b/plugins/ring/Ring_normalize.v @@ -0,0 +1,902 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* n = m. +Proof. + intros. + apply index_eq_prop. + generalize H. + case (index_eq n m); simpl in |- *; trivial; intros. + contradiction. +Qed. + +Section semi_rings. + +Variable A : Type. +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aeq : A -> A -> bool. + +(* Section definitions. *) + + +(******************************************) +(* Normal abtract Polynomials *) +(******************************************) +(* DEFINITIONS : +- A varlist is a sorted product of one or more variables : x, x*y*z +- A monom is a constant, a varlist or the product of a constant by a varlist + variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT. +- A canonical sum is either a monom or an ordered sum of monoms + (the order on monoms is defined later) +- A normal polynomial it either a constant or a canonical sum or a constant + plus a canonical sum +*) + +(* varlist is isomorphic to (list var), but we built a special inductive + for efficiency *) +Inductive varlist : Type := + | Nil_var : varlist + | Cons_var : index -> varlist -> varlist. + +Inductive canonical_sum : Type := + | Nil_monom : canonical_sum + | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum + | Cons_varlist : varlist -> canonical_sum -> canonical_sum. + +(* Order on monoms *) + +(* That's the lexicographic order on varlist, extended by : + - A constant is less than every monom + - The relation between two varlist is preserved by multiplication by a + constant. + + Examples : + 3 < x < y + x*y < x*y*y*z + 2*x*y < x*y*y*z + x*y < 54*x*y*y*z + 4*x*y < 59*x*y*y*z +*) + +Fixpoint varlist_eq (x y:varlist) {struct y} : bool := + match x, y with + | Nil_var, Nil_var => true + | Cons_var i xrest, Cons_var j yrest => + andb (index_eq i j) (varlist_eq xrest yrest) + | _, _ => false + end. + +Fixpoint varlist_lt (x y:varlist) {struct y} : bool := + match x, y with + | Nil_var, Cons_var _ _ => true + | Cons_var i xrest, Cons_var j yrest => + if index_lt i j + then true + else andb (index_eq i j) (varlist_lt xrest yrest) + | _, _ => false + end. + +(* merges two variables lists *) +Fixpoint varlist_merge (l1:varlist) : varlist -> varlist := + match l1 with + | Cons_var v1 t1 => + (fix vm_aux (l2:varlist) : varlist := + match l2 with + | Cons_var v2 t2 => + if index_lt v1 v2 + then Cons_var v1 (varlist_merge t1 l2) + else Cons_var v2 (vm_aux t2) + | Nil_var => l1 + end) + | Nil_var => fun l2 => l2 + end. + +(* returns the sum of two canonical sums *) +Fixpoint canonical_sum_merge (s1:canonical_sum) : + canonical_sum -> canonical_sum := + match s1 with + | Cons_monom c1 l1 t1 => + (fix csm_aux (s2:canonical_sum) : canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 (canonical_sum_merge t1 s2) + else Cons_monom c2 l2 (csm_aux t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 (canonical_sum_merge t1 s2) + else Cons_varlist l2 (csm_aux t2) + | Nil_monom => s1 + end) + | Cons_varlist l1 t1 => + (fix csm_aux2 (s2:canonical_sum) : canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_varlist l1 (canonical_sum_merge t1 s2) + else Cons_monom c2 l2 (csm_aux2 t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_varlist l1 (canonical_sum_merge t1 s2) + else Cons_varlist l2 (csm_aux2 t2) + | Nil_monom => s1 + end) + | Nil_monom => fun s2 => s2 + end. + +(* Insertion of a monom in a canonical sum *) +Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} : + canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 c2) l1 t2 + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 s2 + else Cons_monom c2 l2 (monom_insert c1 l1 t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 Aone) l1 t2 + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 s2 + else Cons_varlist l2 (monom_insert c1 l1 t2) + | Nil_monom => Cons_monom c1 l1 Nil_monom + end. + +Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} : + canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone c2) l1 t2 + else + if varlist_lt l1 l2 + then Cons_varlist l1 s2 + else Cons_monom c2 l2 (varlist_insert l1 t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone Aone) l1 t2 + else + if varlist_lt l1 l2 + then Cons_varlist l1 s2 + else Cons_varlist l2 (varlist_insert l1 t2) + | Nil_monom => Cons_varlist l1 Nil_monom + end. + +(* Computes c0*s *) +Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} : + canonical_sum := + match s with + | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t) + | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t) + | Nil_monom => Nil_monom + end. + +(* Computes l0*s *) +Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} : + canonical_sum := + match s with + | Cons_monom c l t => + monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) + | Cons_varlist l t => + varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) + | Nil_monom => Nil_monom + end. + +(* Computes c0*l0*s *) +Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) + (s:canonical_sum) {struct s} : canonical_sum := + match s with + | Cons_monom c l t => + monom_insert (Amult c0 c) (varlist_merge l0 l) + (canonical_sum_scalar3 c0 l0 t) + | Cons_varlist l t => + monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t) + | Nil_monom => Nil_monom + end. + +(* returns the product of two canonical sums *) +Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} : + canonical_sum := + match s1 with + | Cons_monom c1 l1 t1 => + canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2) + (canonical_sum_prod t1 s2) + | Cons_varlist l1 t1 => + canonical_sum_merge (canonical_sum_scalar2 l1 s2) + (canonical_sum_prod t1 s2) + | Nil_monom => Nil_monom + end. + +(* The type to represent concrete semi-ring polynomials *) +Inductive spolynomial : Type := + | SPvar : index -> spolynomial + | SPconst : A -> spolynomial + | SPplus : spolynomial -> spolynomial -> spolynomial + | SPmult : spolynomial -> spolynomial -> spolynomial. + +Fixpoint spolynomial_normalize (p:spolynomial) : canonical_sum := + match p with + | SPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom + | SPconst c => Cons_monom c Nil_var Nil_monom + | SPplus l r => + canonical_sum_merge (spolynomial_normalize l) (spolynomial_normalize r) + | SPmult l r => + canonical_sum_prod (spolynomial_normalize l) (spolynomial_normalize r) + end. + +(* Deletion of useless 0 and 1 in canonical sums *) +Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum := + match s with + | Cons_monom c l t => + if Aeq c Azero + then canonical_sum_simplify t + else + if Aeq c Aone + then Cons_varlist l (canonical_sum_simplify t) + else Cons_monom c l (canonical_sum_simplify t) + | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t) + | Nil_monom => Nil_monom + end. + +Definition spolynomial_simplify (x:spolynomial) := + canonical_sum_simplify (spolynomial_normalize x). + +(* End definitions. *) + +(* Section interpretation. *) + +(*** Here a variable map is defined and the interpetation of a spolynom + acording to a certain variables map. Once again the choosen definition + is generic and could be changed ****) + +Variable vm : varmap A. + +(* Interpretation of list of variables + * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn) + * The unbound variables are mapped to 0. Normally this case sould + * never occur. Since we want only to prove correctness theorems, which form + * is : for any varmap and any spolynom ... this is a safe and pain-saving + * choice *) +Definition interp_var (i:index) := varmap_find Azero i vm. + +(* Local *) Definition ivl_aux := + (fix ivl_aux (x:index) (t:varlist) {struct t} : A := + match t with + | Nil_var => interp_var x + | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t') + end). + +Definition interp_vl (l:varlist) := + match l with + | Nil_var => Aone + | Cons_var x t => ivl_aux x t + end. + +(* Local *) Definition interp_m (c:A) (l:varlist) := + match l with + | Nil_var => c + | Cons_var x t => Amult c (ivl_aux x t) + end. + +(* Local *) Definition ics_aux := + (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A := + match s with + | Nil_monom => a + | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t) + | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t) + end). + +(* Interpretation of a canonical sum *) +Definition interp_cs (s:canonical_sum) : A := + match s with + | Nil_monom => Azero + | Cons_varlist l t => ics_aux (interp_vl l) t + | Cons_monom c l t => ics_aux (interp_m c l) t + end. + +Fixpoint interp_sp (p:spolynomial) : A := + match p with + | SPconst c => c + | SPvar i => interp_var i + | SPplus p1 p2 => Aplus (interp_sp p1) (interp_sp p2) + | SPmult p1 p2 => Amult (interp_sp p1) (interp_sp p2) + end. + + +(* End interpretation. *) + +Unset Implicit Arguments. + +(* Section properties. *) + +Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq. + +Hint Resolve (SR_plus_comm T). +Hint Resolve (SR_plus_assoc T). +Hint Resolve (SR_plus_assoc2 T). +Hint Resolve (SR_mult_comm T). +Hint Resolve (SR_mult_assoc T). +Hint Resolve (SR_mult_assoc2 T). +Hint Resolve (SR_plus_zero_left T). +Hint Resolve (SR_plus_zero_left2 T). +Hint Resolve (SR_mult_one_left T). +Hint Resolve (SR_mult_one_left2 T). +Hint Resolve (SR_mult_zero_left T). +Hint Resolve (SR_mult_zero_left2 T). +Hint Resolve (SR_distr_left T). +Hint Resolve (SR_distr_left2 T). +(*Hint Resolve (SR_plus_reg_left T).*) +Hint Resolve (SR_plus_permute T). +Hint Resolve (SR_mult_permute T). +Hint Resolve (SR_distr_right T). +Hint Resolve (SR_distr_right2 T). +Hint Resolve (SR_mult_zero_right T). +Hint Resolve (SR_mult_zero_right2 T). +Hint Resolve (SR_plus_zero_right T). +Hint Resolve (SR_plus_zero_right2 T). +Hint Resolve (SR_mult_one_right T). +Hint Resolve (SR_mult_one_right2 T). +(*Hint Resolve (SR_plus_reg_right T).*) +Hint Resolve refl_equal sym_equal trans_equal. +(* Hints Resolve refl_eqT sym_eqT trans_eqT. *) +Hint Immediate T. + +Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y. +Proof. + simple induction x; simple induction y; contradiction || (try reflexivity). + simpl in |- *; intros. + generalize (andb_prop2 _ _ H1); intros; elim H2; intros. + rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity. +Qed. + +Remark ivl_aux_ok : + forall (v:varlist) (i:index), + ivl_aux i v = Amult (interp_var i) (interp_vl v). +Proof. + simple induction v; simpl in |- *; intros. + trivial. + rewrite H; trivial. +Qed. + +Lemma varlist_merge_ok : + forall x y:varlist, + interp_vl (varlist_merge x y) = Amult (interp_vl x) (interp_vl y). +Proof. + simple induction x. + simpl in |- *; trivial. + simple induction y. + simpl in |- *; trivial. + simpl in |- *; intros. + elim (index_lt i i0); simpl in |- *; intros. + + repeat rewrite ivl_aux_ok. + rewrite H. simpl in |- *. + rewrite ivl_aux_ok. + eauto. + + repeat rewrite ivl_aux_ok. + rewrite H0. + rewrite ivl_aux_ok. + eauto. +Qed. + +Remark ics_aux_ok : + forall (x:A) (s:canonical_sum), ics_aux x s = Aplus x (interp_cs s). +Proof. + simple induction s; simpl in |- *; intros. + trivial. + reflexivity. + reflexivity. +Qed. + +Remark interp_m_ok : + forall (x:A) (l:varlist), interp_m x l = Amult x (interp_vl l). +Proof. + destruct l as [| i v]. + simpl in |- *; trivial. + reflexivity. +Qed. + +Lemma canonical_sum_merge_ok : + forall x y:canonical_sum, + interp_cs (canonical_sum_merge x y) = Aplus (interp_cs x) (interp_cs y). + +simple induction x; simpl in |- *. +trivial. + +simple induction y; simpl in |- *; intros. +(* monom and nil *) +eauto. + +(* monom and monom *) +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. +repeat rewrite interp_m_ok. +rewrite (SR_distr_left T). +repeat rewrite <- (SR_plus_assoc T). +apply f_equal with (f := Aplus (Amult a (interp_vl v0))). +trivial. + +elim (varlist_lt v v0); simpl in |- *. +repeat rewrite ics_aux_ok. +rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. + +rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; + eauto. + +(* monom and varlist *) +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. +repeat rewrite interp_m_ok. +rewrite (SR_distr_left T). +repeat rewrite <- (SR_plus_assoc T). +apply f_equal with (f := Aplus (Amult a (interp_vl v0))). +rewrite (SR_mult_one_left T). +trivial. + +elim (varlist_lt v v0); simpl in |- *. +repeat rewrite ics_aux_ok. +rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. +rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; + eauto. + +simple induction y; simpl in |- *; intros. +(* varlist and nil *) +trivial. + +(* varlist and monom *) +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. +repeat rewrite interp_m_ok. +rewrite (SR_distr_left T). +repeat rewrite <- (SR_plus_assoc T). +rewrite (SR_mult_one_left T). +apply f_equal with (f := Aplus (interp_vl v0)). +trivial. + +elim (varlist_lt v v0); simpl in |- *. +repeat rewrite ics_aux_ok. +rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. +rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; + eauto. + +(* varlist and varlist *) +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. +repeat rewrite interp_m_ok. +rewrite (SR_distr_left T). +repeat rewrite <- (SR_plus_assoc T). +rewrite (SR_mult_one_left T). +apply f_equal with (f := Aplus (interp_vl v0)). +trivial. + +elim (varlist_lt v v0); simpl in |- *. +repeat rewrite ics_aux_ok. +rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. +rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; + eauto. +Qed. + +Lemma monom_insert_ok : + forall (a:A) (l:varlist) (s:canonical_sum), + interp_cs (monom_insert a l s) = + Aplus (Amult a (interp_vl l)) (interp_cs s). +intros; generalize s; simple induction s0. + +simpl in |- *; rewrite interp_m_ok; trivial. + +simpl in |- *; intros. +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; + repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T); + eauto. +elim (varlist_lt l v); simpl in |- *; + [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto + | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; + rewrite ics_aux_ok; eauto ]. + +simpl in |- *; intros. +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; + repeat rewrite ics_aux_ok; rewrite (SR_distr_left T); + rewrite (SR_mult_one_left T); eauto. +elim (varlist_lt l v); simpl in |- *; + [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto + | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; + rewrite ics_aux_ok; eauto ]. +Qed. + +Lemma varlist_insert_ok : + forall (l:varlist) (s:canonical_sum), + interp_cs (varlist_insert l s) = Aplus (interp_vl l) (interp_cs s). +intros; generalize s; simple induction s0. + +simpl in |- *; trivial. + +simpl in |- *; intros. +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; + repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T); + rewrite (SR_mult_one_left T); eauto. +elim (varlist_lt l v); simpl in |- *; + [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto + | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; + rewrite ics_aux_ok; eauto ]. + +simpl in |- *; intros. +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; + repeat rewrite ics_aux_ok; rewrite (SR_distr_left T); + rewrite (SR_mult_one_left T); eauto. +elim (varlist_lt l v); simpl in |- *; + [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto + | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; + rewrite ics_aux_ok; eauto ]. +Qed. + +Lemma canonical_sum_scalar_ok : + forall (a:A) (s:canonical_sum), + interp_cs (canonical_sum_scalar a s) = Amult a (interp_cs s). +simple induction s. +simpl in |- *; eauto. + +simpl in |- *; intros. +repeat rewrite ics_aux_ok. +repeat rewrite interp_m_ok. +rewrite H. +rewrite (SR_distr_right T). +repeat rewrite <- (SR_mult_assoc T). +reflexivity. + +simpl in |- *; intros. +repeat rewrite ics_aux_ok. +repeat rewrite interp_m_ok. +rewrite H. +rewrite (SR_distr_right T). +repeat rewrite <- (SR_mult_assoc T). +reflexivity. +Qed. + +Lemma canonical_sum_scalar2_ok : + forall (l:varlist) (s:canonical_sum), + interp_cs (canonical_sum_scalar2 l s) = Amult (interp_vl l) (interp_cs s). +simple induction s. +simpl in |- *; trivial. + +simpl in |- *; intros. +rewrite monom_insert_ok. +repeat rewrite ics_aux_ok. +repeat rewrite interp_m_ok. +rewrite H. +rewrite varlist_merge_ok. +repeat rewrite (SR_distr_right T). +repeat rewrite <- (SR_mult_assoc T). +repeat rewrite <- (SR_plus_assoc T). +rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). +reflexivity. + +simpl in |- *; intros. +rewrite varlist_insert_ok. +repeat rewrite ics_aux_ok. +repeat rewrite interp_m_ok. +rewrite H. +rewrite varlist_merge_ok. +repeat rewrite (SR_distr_right T). +repeat rewrite <- (SR_mult_assoc T). +repeat rewrite <- (SR_plus_assoc T). +reflexivity. +Qed. + +Lemma canonical_sum_scalar3_ok : + forall (c:A) (l:varlist) (s:canonical_sum), + interp_cs (canonical_sum_scalar3 c l s) = + Amult c (Amult (interp_vl l) (interp_cs s)). +simple induction s. +simpl in |- *; repeat rewrite (SR_mult_zero_right T); reflexivity. + +simpl in |- *; intros. +rewrite monom_insert_ok. +repeat rewrite ics_aux_ok. +repeat rewrite interp_m_ok. +rewrite H. +rewrite varlist_merge_ok. +repeat rewrite (SR_distr_right T). +repeat rewrite <- (SR_mult_assoc T). +repeat rewrite <- (SR_plus_assoc T). +rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). +reflexivity. + +simpl in |- *; intros. +rewrite monom_insert_ok. +repeat rewrite ics_aux_ok. +repeat rewrite interp_m_ok. +rewrite H. +rewrite varlist_merge_ok. +repeat rewrite (SR_distr_right T). +repeat rewrite <- (SR_mult_assoc T). +repeat rewrite <- (SR_plus_assoc T). +rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)). +reflexivity. +Qed. + +Lemma canonical_sum_prod_ok : + forall x y:canonical_sum, + interp_cs (canonical_sum_prod x y) = Amult (interp_cs x) (interp_cs y). +simple induction x; simpl in |- *; intros. +trivial. + +rewrite canonical_sum_merge_ok. +rewrite canonical_sum_scalar3_ok. +rewrite ics_aux_ok. +rewrite interp_m_ok. +rewrite H. +rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)). +symmetry in |- *. +eauto. + +rewrite canonical_sum_merge_ok. +rewrite canonical_sum_scalar2_ok. +rewrite ics_aux_ok. +rewrite H. +trivial. +Qed. + +Theorem spolynomial_normalize_ok : + forall p:spolynomial, interp_cs (spolynomial_normalize p) = interp_sp p. +simple induction p; simpl in |- *; intros. + +reflexivity. +reflexivity. + +rewrite canonical_sum_merge_ok. +rewrite H; rewrite H0. +reflexivity. + +rewrite canonical_sum_prod_ok. +rewrite H; rewrite H0. +reflexivity. +Qed. + +Lemma canonical_sum_simplify_ok : + forall s:canonical_sum, interp_cs (canonical_sum_simplify s) = interp_cs s. +simple induction s. + +reflexivity. + +(* cons_monom *) +simpl in |- *; intros. +generalize (SR_eq_prop T a Azero). +elim (Aeq a Azero). +intro Heq; rewrite (Heq I). +rewrite H. +rewrite ics_aux_ok. +rewrite interp_m_ok. +rewrite (SR_mult_zero_left T). +trivial. + +intros; simpl in |- *. +generalize (SR_eq_prop T a Aone). +elim (Aeq a Aone). +intro Heq; rewrite (Heq I). +simpl in |- *. +repeat rewrite ics_aux_ok. +rewrite interp_m_ok. +rewrite H. +rewrite (SR_mult_one_left T). +reflexivity. + +simpl in |- *. +repeat rewrite ics_aux_ok. +rewrite interp_m_ok. +rewrite H. +reflexivity. + +(* cons_varlist *) +simpl in |- *; intros. +repeat rewrite ics_aux_ok. +rewrite H. +reflexivity. + +Qed. + +Theorem spolynomial_simplify_ok : + forall p:spolynomial, interp_cs (spolynomial_simplify p) = interp_sp p. +intro. +unfold spolynomial_simplify in |- *. +rewrite canonical_sum_simplify_ok. +apply spolynomial_normalize_ok. +Qed. + +(* End properties. *) +End semi_rings. + +Implicit Arguments Cons_varlist. +Implicit Arguments Cons_monom. +Implicit Arguments SPconst. +Implicit Arguments SPplus. +Implicit Arguments SPmult. + +Section rings. + +(* Here the coercion between Ring and Semi-Ring will be useful *) + +Set Implicit Arguments. + +Variable A : Type. +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aopp : A -> A. +Variable Aeq : A -> A -> bool. +Variable vm : varmap A. +Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. + +Hint Resolve (Th_plus_comm T). +Hint Resolve (Th_plus_assoc T). +Hint Resolve (Th_plus_assoc2 T). +Hint Resolve (Th_mult_comm T). +Hint Resolve (Th_mult_assoc T). +Hint Resolve (Th_mult_assoc2 T). +Hint Resolve (Th_plus_zero_left T). +Hint Resolve (Th_plus_zero_left2 T). +Hint Resolve (Th_mult_one_left T). +Hint Resolve (Th_mult_one_left2 T). +Hint Resolve (Th_mult_zero_left T). +Hint Resolve (Th_mult_zero_left2 T). +Hint Resolve (Th_distr_left T). +Hint Resolve (Th_distr_left2 T). +(*Hint Resolve (Th_plus_reg_left T).*) +Hint Resolve (Th_plus_permute T). +Hint Resolve (Th_mult_permute T). +Hint Resolve (Th_distr_right T). +Hint Resolve (Th_distr_right2 T). +Hint Resolve (Th_mult_zero_right T). +Hint Resolve (Th_mult_zero_right2 T). +Hint Resolve (Th_plus_zero_right T). +Hint Resolve (Th_plus_zero_right2 T). +Hint Resolve (Th_mult_one_right T). +Hint Resolve (Th_mult_one_right2 T). +(*Hint Resolve (Th_plus_reg_right T).*) +Hint Resolve refl_equal sym_equal trans_equal. +(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Immediate T. + +(*** Definitions *) + +Inductive polynomial : Type := + | Pvar : index -> polynomial + | Pconst : A -> polynomial + | Pplus : polynomial -> polynomial -> polynomial + | Pmult : polynomial -> polynomial -> polynomial + | Popp : polynomial -> polynomial. + +Fixpoint polynomial_normalize (x:polynomial) : canonical_sum A := + match x with + | Pplus l r => + canonical_sum_merge Aplus Aone (polynomial_normalize l) + (polynomial_normalize r) + | Pmult l r => + canonical_sum_prod Aplus Amult Aone (polynomial_normalize l) + (polynomial_normalize r) + | Pconst c => Cons_monom c Nil_var (Nil_monom A) + | Pvar i => Cons_varlist (Cons_var i Nil_var) (Nil_monom A) + | Popp p => + canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var + (polynomial_normalize p) + end. + +Definition polynomial_simplify (x:polynomial) := + canonical_sum_simplify Aone Azero Aeq (polynomial_normalize x). + +Fixpoint spolynomial_of (x:polynomial) : spolynomial A := + match x with + | Pplus l r => SPplus (spolynomial_of l) (spolynomial_of r) + | Pmult l r => SPmult (spolynomial_of l) (spolynomial_of r) + | Pconst c => SPconst c + | Pvar i => SPvar A i + | Popp p => SPmult (SPconst (Aopp Aone)) (spolynomial_of p) + end. + +(*** Interpretation *) + +Fixpoint interp_p (p:polynomial) : A := + match p with + | Pconst c => c + | Pvar i => varmap_find Azero i vm + | Pplus p1 p2 => Aplus (interp_p p1) (interp_p p2) + | Pmult p1 p2 => Amult (interp_p p1) (interp_p p2) + | Popp p1 => Aopp (interp_p p1) + end. + +(*** Properties *) + +Unset Implicit Arguments. + +Lemma spolynomial_of_ok : + forall p:polynomial, + interp_p p = interp_sp Aplus Amult Azero vm (spolynomial_of p). +simple induction p; reflexivity || (simpl in |- *; intros). +rewrite H; rewrite H0; reflexivity. +rewrite H; rewrite H0; reflexivity. +rewrite H. +rewrite (Th_opp_mult_left2 T). +rewrite (Th_mult_one_left T). +reflexivity. +Qed. + +Theorem polynomial_normalize_ok : + forall p:polynomial, + polynomial_normalize p = + spolynomial_normalize Aplus Amult Aone (spolynomial_of p). +simple induction p; reflexivity || (simpl in |- *; intros). +rewrite H; rewrite H0; reflexivity. +rewrite H; rewrite H0; reflexivity. +rewrite H; simpl in |- *. +elim + (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var + (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0))); + [ reflexivity + | simpl in |- *; intros; rewrite H0; reflexivity + | simpl in |- *; intros; rewrite H0; reflexivity ]. +Qed. + +Theorem polynomial_simplify_ok : + forall p:polynomial, + interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p) = interp_p p. +intro. +unfold polynomial_simplify in |- *. +rewrite spolynomial_of_ok. +rewrite polynomial_normalize_ok. +rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T). +rewrite (spolynomial_normalize_ok A Aplus Amult Aone Azero Aeq vm T). +reflexivity. +Qed. + +End rings. + +Infix "+" := Pplus : ring_scope. +Infix "*" := Pmult : ring_scope. +Notation "- x" := (Popp x) : ring_scope. +Notation "[ x ]" := (Pvar x) (at level 0) : ring_scope. + +Delimit Scope ring_scope with ring. diff --git a/plugins/ring/Setoid_ring.v b/plugins/ring/Setoid_ring.v new file mode 100644 index 00000000..93b9bc7c --- /dev/null +++ b/plugins/ring/Setoid_ring.v @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* n = m. +Proof. + simple induction n; simple induction m; simpl in |- *; + try reflexivity || contradiction. + intros; rewrite (H i0); trivial. + intros; rewrite (H i0); trivial. +Qed. + +Section setoid. + +Variable A : Type. +Variable Aequiv : A -> A -> Prop. +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aopp : A -> A. +Variable Aeq : A -> A -> bool. + +Variable S : Setoid_Theory A Aequiv. + +Add Setoid A Aequiv S as Asetoid. + +Variable plus_morph : + forall a a0:A, Aequiv a a0 -> + forall a1 a2:A, Aequiv a1 a2 -> + Aequiv (Aplus a a1) (Aplus a0 a2). +Variable mult_morph : + forall a a0:A, Aequiv a a0 -> + forall a1 a2:A, Aequiv a1 a2 -> + Aequiv (Amult a a1) (Amult a0 a2). +Variable opp_morph : forall a a0:A, Aequiv a a0 -> Aequiv (Aopp a) (Aopp a0). + +Add Morphism Aplus : Aplus_ext. +intros; apply plus_morph; assumption. +Qed. + +Add Morphism Amult : Amult_ext. +intros; apply mult_morph; assumption. +Qed. + +Add Morphism Aopp : Aopp_ext. +exact opp_morph. +Qed. + +Let equiv_refl := Seq_refl A Aequiv S. +Let equiv_sym := Seq_sym A Aequiv S. +Let equiv_trans := Seq_trans A Aequiv S. + +Hint Resolve equiv_refl equiv_trans. +Hint Immediate equiv_sym. + +Section semi_setoid_rings. + +(* Section definitions. *) + + +(******************************************) +(* Normal abtract Polynomials *) +(******************************************) +(* DEFINITIONS : +- A varlist is a sorted product of one or more variables : x, x*y*z +- A monom is a constant, a varlist or the product of a constant by a varlist + variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT. +- A canonical sum is either a monom or an ordered sum of monoms + (the order on monoms is defined later) +- A normal polynomial it either a constant or a canonical sum or a constant + plus a canonical sum +*) + +(* varlist is isomorphic to (list var), but we built a special inductive + for efficiency *) +Inductive varlist : Type := + | Nil_var : varlist + | Cons_var : index -> varlist -> varlist. + +Inductive canonical_sum : Type := + | Nil_monom : canonical_sum + | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum + | Cons_varlist : varlist -> canonical_sum -> canonical_sum. + +(* Order on monoms *) + +(* That's the lexicographic order on varlist, extended by : + - A constant is less than every monom + - The relation between two varlist is preserved by multiplication by a + constant. + + Examples : + 3 < x < y + x*y < x*y*y*z + 2*x*y < x*y*y*z + x*y < 54*x*y*y*z + 4*x*y < 59*x*y*y*z +*) + +Fixpoint varlist_eq (x y:varlist) {struct y} : bool := + match x, y with + | Nil_var, Nil_var => true + | Cons_var i xrest, Cons_var j yrest => + andb (index_eq i j) (varlist_eq xrest yrest) + | _, _ => false + end. + +Fixpoint varlist_lt (x y:varlist) {struct y} : bool := + match x, y with + | Nil_var, Cons_var _ _ => true + | Cons_var i xrest, Cons_var j yrest => + if index_lt i j + then true + else andb (index_eq i j) (varlist_lt xrest yrest) + | _, _ => false + end. + +(* merges two variables lists *) +Fixpoint varlist_merge (l1:varlist) : varlist -> varlist := + match l1 with + | Cons_var v1 t1 => + (fix vm_aux (l2:varlist) : varlist := + match l2 with + | Cons_var v2 t2 => + if index_lt v1 v2 + then Cons_var v1 (varlist_merge t1 l2) + else Cons_var v2 (vm_aux t2) + | Nil_var => l1 + end) + | Nil_var => fun l2 => l2 + end. + +(* returns the sum of two canonical sums *) +Fixpoint canonical_sum_merge (s1:canonical_sum) : + canonical_sum -> canonical_sum := + match s1 with + | Cons_monom c1 l1 t1 => + (fix csm_aux (s2:canonical_sum) : canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 (canonical_sum_merge t1 s2) + else Cons_monom c2 l2 (csm_aux t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 (canonical_sum_merge t1 s2) + else Cons_varlist l2 (csm_aux t2) + | Nil_monom => s1 + end) + | Cons_varlist l1 t1 => + (fix csm_aux2 (s2:canonical_sum) : canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_varlist l1 (canonical_sum_merge t1 s2) + else Cons_monom c2 l2 (csm_aux2 t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_varlist l1 (canonical_sum_merge t1 s2) + else Cons_varlist l2 (csm_aux2 t2) + | Nil_monom => s1 + end) + | Nil_monom => fun s2 => s2 + end. + +(* Insertion of a monom in a canonical sum *) +Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} : + canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 c2) l1 t2 + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 s2 + else Cons_monom c2 l2 (monom_insert c1 l1 t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 Aone) l1 t2 + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 s2 + else Cons_varlist l2 (monom_insert c1 l1 t2) + | Nil_monom => Cons_monom c1 l1 Nil_monom + end. + +Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} : + canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone c2) l1 t2 + else + if varlist_lt l1 l2 + then Cons_varlist l1 s2 + else Cons_monom c2 l2 (varlist_insert l1 t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone Aone) l1 t2 + else + if varlist_lt l1 l2 + then Cons_varlist l1 s2 + else Cons_varlist l2 (varlist_insert l1 t2) + | Nil_monom => Cons_varlist l1 Nil_monom + end. + +(* Computes c0*s *) +Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} : + canonical_sum := + match s with + | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t) + | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t) + | Nil_monom => Nil_monom + end. + +(* Computes l0*s *) +Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} : + canonical_sum := + match s with + | Cons_monom c l t => + monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) + | Cons_varlist l t => + varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) + | Nil_monom => Nil_monom + end. + +(* Computes c0*l0*s *) +Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) + (s:canonical_sum) {struct s} : canonical_sum := + match s with + | Cons_monom c l t => + monom_insert (Amult c0 c) (varlist_merge l0 l) + (canonical_sum_scalar3 c0 l0 t) + | Cons_varlist l t => + monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t) + | Nil_monom => Nil_monom + end. + +(* returns the product of two canonical sums *) +Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} : + canonical_sum := + match s1 with + | Cons_monom c1 l1 t1 => + canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2) + (canonical_sum_prod t1 s2) + | Cons_varlist l1 t1 => + canonical_sum_merge (canonical_sum_scalar2 l1 s2) + (canonical_sum_prod t1 s2) + | Nil_monom => Nil_monom + end. + +(* The type to represent concrete semi-setoid-ring polynomials *) + +Inductive setspolynomial : Type := + | SetSPvar : index -> setspolynomial + | SetSPconst : A -> setspolynomial + | SetSPplus : setspolynomial -> setspolynomial -> setspolynomial + | SetSPmult : setspolynomial -> setspolynomial -> setspolynomial. + +Fixpoint setspolynomial_normalize (p:setspolynomial) : canonical_sum := + match p with + | SetSPplus l r => + canonical_sum_merge (setspolynomial_normalize l) + (setspolynomial_normalize r) + | SetSPmult l r => + canonical_sum_prod (setspolynomial_normalize l) + (setspolynomial_normalize r) + | SetSPconst c => Cons_monom c Nil_var Nil_monom + | SetSPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom + end. + +Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum := + match s with + | Cons_monom c l t => + if Aeq c Azero + then canonical_sum_simplify t + else + if Aeq c Aone + then Cons_varlist l (canonical_sum_simplify t) + else Cons_monom c l (canonical_sum_simplify t) + | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t) + | Nil_monom => Nil_monom + end. + +Definition setspolynomial_simplify (x:setspolynomial) := + canonical_sum_simplify (setspolynomial_normalize x). + +Variable vm : varmap A. + +Definition interp_var (i:index) := varmap_find Azero i vm. + +Definition ivl_aux := + (fix ivl_aux (x:index) (t:varlist) {struct t} : A := + match t with + | Nil_var => interp_var x + | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t') + end). + +Definition interp_vl (l:varlist) := + match l with + | Nil_var => Aone + | Cons_var x t => ivl_aux x t + end. + +Definition interp_m (c:A) (l:varlist) := + match l with + | Nil_var => c + | Cons_var x t => Amult c (ivl_aux x t) + end. + +Definition ics_aux := + (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A := + match s with + | Nil_monom => a + | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t) + | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t) + end). + +Definition interp_setcs (s:canonical_sum) : A := + match s with + | Nil_monom => Azero + | Cons_varlist l t => ics_aux (interp_vl l) t + | Cons_monom c l t => ics_aux (interp_m c l) t + end. + +Fixpoint interp_setsp (p:setspolynomial) : A := + match p with + | SetSPconst c => c + | SetSPvar i => interp_var i + | SetSPplus p1 p2 => Aplus (interp_setsp p1) (interp_setsp p2) + | SetSPmult p1 p2 => Amult (interp_setsp p1) (interp_setsp p2) + end. + +(* End interpretation. *) + +Unset Implicit Arguments. + +(* Section properties. *) + +Variable T : Semi_Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aeq. + +Hint Resolve (SSR_plus_comm T). +Hint Resolve (SSR_plus_assoc T). +Hint Resolve (SSR_plus_assoc2 S T). +Hint Resolve (SSR_mult_comm T). +Hint Resolve (SSR_mult_assoc T). +Hint Resolve (SSR_mult_assoc2 S T). +Hint Resolve (SSR_plus_zero_left T). +Hint Resolve (SSR_plus_zero_left2 S T). +Hint Resolve (SSR_mult_one_left T). +Hint Resolve (SSR_mult_one_left2 S T). +Hint Resolve (SSR_mult_zero_left T). +Hint Resolve (SSR_mult_zero_left2 S T). +Hint Resolve (SSR_distr_left T). +Hint Resolve (SSR_distr_left2 S T). +Hint Resolve (SSR_plus_reg_left T). +Hint Resolve (SSR_plus_permute S plus_morph T). +Hint Resolve (SSR_mult_permute S mult_morph T). +Hint Resolve (SSR_distr_right S plus_morph T). +Hint Resolve (SSR_distr_right2 S plus_morph T). +Hint Resolve (SSR_mult_zero_right S T). +Hint Resolve (SSR_mult_zero_right2 S T). +Hint Resolve (SSR_plus_zero_right S T). +Hint Resolve (SSR_plus_zero_right2 S T). +Hint Resolve (SSR_mult_one_right S T). +Hint Resolve (SSR_mult_one_right2 S T). +Hint Resolve (SSR_plus_reg_right S T). +Hint Resolve refl_equal sym_equal trans_equal. +(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Immediate T. + +Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y. +Proof. + simple induction x; simple induction y; contradiction || (try reflexivity). + simpl in |- *; intros. + generalize (andb_prop2 _ _ H1); intros; elim H2; intros. + rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity. +Qed. + +Remark ivl_aux_ok : + forall (v:varlist) (i:index), + Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)). +Proof. + simple induction v; simpl in |- *; intros. + trivial. + rewrite (H i); trivial. +Qed. + +Lemma varlist_merge_ok : + forall x y:varlist, + Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)). +Proof. + simple induction x. + simpl in |- *; trivial. + simple induction y. + simpl in |- *; trivial. + simpl in |- *; intros. + elim (index_lt i i0); simpl in |- *; intros. + + rewrite (ivl_aux_ok v i). + rewrite (ivl_aux_ok v0 i0). + rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i). + rewrite (H (Cons_var i0 v0)). + simpl in |- *. + rewrite (ivl_aux_ok v0 i0). + eauto. + + rewrite (ivl_aux_ok v i). + rewrite (ivl_aux_ok v0 i0). + rewrite + (ivl_aux_ok + ((fix vm_aux (l2:varlist) : varlist := + match l2 with + | Nil_var => Cons_var i v + | Cons_var v2 t2 => + if index_lt i v2 + then Cons_var i (varlist_merge v l2) + else Cons_var v2 (vm_aux t2) + end) v0) i0). + rewrite H0. + rewrite (ivl_aux_ok v i). + eauto. +Qed. + +Remark ics_aux_ok : + forall (x:A) (s:canonical_sum), + Aequiv (ics_aux x s) (Aplus x (interp_setcs s)). +Proof. + simple induction s; simpl in |- *; intros; trivial. +Qed. + +Remark interp_m_ok : + forall (x:A) (l:varlist), Aequiv (interp_m x l) (Amult x (interp_vl l)). +Proof. + destruct l as [| i v]; trivial. +Qed. + +Hint Resolve ivl_aux_ok. +Hint Resolve ics_aux_ok. +Hint Resolve interp_m_ok. + +(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *) + +Lemma canonical_sum_merge_ok : + forall x y:canonical_sum, + Aequiv (interp_setcs (canonical_sum_merge x y)) + (Aplus (interp_setcs x) (interp_setcs y)). +Proof. +simple induction x; simpl in |- *. +trivial. + +simple induction y; simpl in |- *; intros. +eauto. + +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *. +rewrite (ics_aux_ok (interp_m a v0) c). +rewrite (ics_aux_ok (interp_m a0 v0) c0). +rewrite (ics_aux_ok (interp_m (Aplus a a0) v0) (canonical_sum_merge c c0)). +rewrite (H c0). +rewrite (interp_m_ok (Aplus a a0) v0). +rewrite (interp_m_ok a v0). +rewrite (interp_m_ok a0 v0). +setoid_replace (Amult (Aplus a a0) (interp_vl v0)) with + (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0))); + [ idtac | trivial ]. +setoid_replace + (Aplus (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0))) + (Aplus (interp_setcs c) (interp_setcs c0))) with + (Aplus (Amult a (interp_vl v0)) + (Aplus (Amult a0 (interp_vl v0)) + (Aplus (interp_setcs c) (interp_setcs c0)))); + [ idtac | trivial ]. +setoid_replace + (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c)) + (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))) with + (Aplus (Amult a (interp_vl v0)) + (Aplus (interp_setcs c) + (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0)))); + [ idtac | trivial ]. +auto. + +elim (varlist_lt v v0); simpl in |- *. +intro. +rewrite + (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_monom a0 v0 c0))) + . +rewrite (ics_aux_ok (interp_m a v) c). +rewrite (ics_aux_ok (interp_m a0 v0) c0). +rewrite (H (Cons_monom a0 v0 c0)); simpl in |- *. +rewrite (ics_aux_ok (interp_m a0 v0) c0); auto. + +intro. +rewrite + (ics_aux_ok (interp_m a0 v0) + ((fix csm_aux (s2:canonical_sum) : canonical_sum := + match s2 with + | Nil_monom => Cons_monom a v c + | Cons_monom c2 l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_monom a v (canonical_sum_merge c s2) + else Cons_monom c2 l2 (csm_aux t2) + | Cons_varlist l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_monom a v (canonical_sum_merge c s2) + else Cons_varlist l2 (csm_aux t2) + end) c0)). +rewrite H0. +rewrite (ics_aux_ok (interp_m a v) c); + rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *; + auto. + +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *. +rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0) (canonical_sum_merge c c0)); + rewrite (ics_aux_ok (interp_m a v0) c); + rewrite (ics_aux_ok (interp_vl v0) c0). +rewrite (H c0). +rewrite (interp_m_ok (Aplus a Aone) v0). +rewrite (interp_m_ok a v0). +setoid_replace (Amult (Aplus a Aone) (interp_vl v0)) with + (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0))); + [ idtac | trivial ]. +setoid_replace + (Aplus (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0))) + (Aplus (interp_setcs c) (interp_setcs c0))) with + (Aplus (Amult a (interp_vl v0)) + (Aplus (Amult Aone (interp_vl v0)) + (Aplus (interp_setcs c) (interp_setcs c0)))); + [ idtac | trivial ]. +setoid_replace + (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c)) + (Aplus (interp_vl v0) (interp_setcs c0))) with + (Aplus (Amult a (interp_vl v0)) + (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0)))); + [ idtac | trivial ]. +setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); + [ idtac | trivial ]. +auto. + +elim (varlist_lt v v0); simpl in |- *. +intro. +rewrite + (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_varlist v0 c0))) + ; rewrite (ics_aux_ok (interp_m a v) c); + rewrite (ics_aux_ok (interp_vl v0) c0). +rewrite (H (Cons_varlist v0 c0)); simpl in |- *. +rewrite (ics_aux_ok (interp_vl v0) c0). +auto. + +intro. +rewrite + (ics_aux_ok (interp_vl v0) + ((fix csm_aux (s2:canonical_sum) : canonical_sum := + match s2 with + | Nil_monom => Cons_monom a v c + | Cons_monom c2 l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_monom a v (canonical_sum_merge c s2) + else Cons_monom c2 l2 (csm_aux t2) + | Cons_varlist l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_monom a v (canonical_sum_merge c s2) + else Cons_varlist l2 (csm_aux t2) + end) c0)); rewrite H0. +rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0); + simpl in |- *. +auto. + +simple induction y; simpl in |- *; intros. +trivial. + +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *. +rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0)); + rewrite (ics_aux_ok (interp_vl v0) c); + rewrite (ics_aux_ok (interp_m a v0) c0); rewrite (H c0). +rewrite (interp_m_ok (Aplus Aone a) v0); rewrite (interp_m_ok a v0). +setoid_replace (Amult (Aplus Aone a) (interp_vl v0)) with + (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0))); + [ idtac | trivial ]. +setoid_replace + (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0))) + (Aplus (interp_setcs c) (interp_setcs c0))) with + (Aplus (Amult Aone (interp_vl v0)) + (Aplus (Amult a (interp_vl v0)) + (Aplus (interp_setcs c) (interp_setcs c0)))); + [ idtac | trivial ]. +setoid_replace + (Aplus (Aplus (interp_vl v0) (interp_setcs c)) + (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))) with + (Aplus (interp_vl v0) + (Aplus (interp_setcs c) + (Aplus (Amult a (interp_vl v0)) (interp_setcs c0)))); + [ idtac | trivial ]. +auto. + +elim (varlist_lt v v0); simpl in |- *; intros. +rewrite + (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_monom a v0 c0))) + ; rewrite (ics_aux_ok (interp_vl v) c); + rewrite (ics_aux_ok (interp_m a v0) c0). +rewrite (H (Cons_monom a v0 c0)); simpl in |- *. +rewrite (ics_aux_ok (interp_m a v0) c0); auto. + +rewrite + (ics_aux_ok (interp_m a v0) + ((fix csm_aux2 (s2:canonical_sum) : canonical_sum := + match s2 with + | Nil_monom => Cons_varlist v c + | Cons_monom c2 l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_varlist v (canonical_sum_merge c s2) + else Cons_monom c2 l2 (csm_aux2 t2) + | Cons_varlist l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_varlist v (canonical_sum_merge c s2) + else Cons_varlist l2 (csm_aux2 t2) + end) c0)); rewrite H0. +rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0); + simpl in |- *; auto. + +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0); intros. +rewrite (H1 I); simpl in |- *. +rewrite + (ics_aux_ok (interp_m (Aplus Aone Aone) v0) (canonical_sum_merge c c0)) + ; rewrite (ics_aux_ok (interp_vl v0) c); + rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H c0). +rewrite (interp_m_ok (Aplus Aone Aone) v0). +setoid_replace (Amult (Aplus Aone Aone) (interp_vl v0)) with + (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0))); + [ idtac | trivial ]. +setoid_replace + (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0))) + (Aplus (interp_setcs c) (interp_setcs c0))) with + (Aplus (Amult Aone (interp_vl v0)) + (Aplus (Amult Aone (interp_vl v0)) + (Aplus (interp_setcs c) (interp_setcs c0)))); + [ idtac | trivial ]. +setoid_replace + (Aplus (Aplus (interp_vl v0) (interp_setcs c)) + (Aplus (interp_vl v0) (interp_setcs c0))) with + (Aplus (interp_vl v0) + (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0)))); +[ idtac | trivial ]. +setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto. + +elim (varlist_lt v v0); simpl in |- *. +rewrite + (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_varlist v0 c0))) + ; rewrite (ics_aux_ok (interp_vl v) c); + rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H (Cons_varlist v0 c0)); + simpl in |- *. +rewrite (ics_aux_ok (interp_vl v0) c0); auto. + +rewrite + (ics_aux_ok (interp_vl v0) + ((fix csm_aux2 (s2:canonical_sum) : canonical_sum := + match s2 with + | Nil_monom => Cons_varlist v c + | Cons_monom c2 l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_varlist v (canonical_sum_merge c s2) + else Cons_monom c2 l2 (csm_aux2 t2) + | Cons_varlist l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_varlist v (canonical_sum_merge c s2) + else Cons_varlist l2 (csm_aux2 t2) + end) c0)); rewrite H0. +rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0); + simpl in |- *; auto. +Qed. + +Lemma monom_insert_ok : + forall (a:A) (l:varlist) (s:canonical_sum), + Aequiv (interp_setcs (monom_insert a l s)) + (Aplus (Amult a (interp_vl l)) (interp_setcs s)). +Proof. +simple induction s; intros. +simpl in |- *; rewrite (interp_m_ok a l); trivial. + +simpl in |- *; generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *. +rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c); + rewrite (ics_aux_ok (interp_m a0 v) c). +rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v). +setoid_replace (Amult (Aplus a a0) (interp_vl v)) with + (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v))); + [ idtac | trivial ]. +auto. + +elim (varlist_lt l v); simpl in |- *; intros. +rewrite (ics_aux_ok (interp_m a0 v) c). +rewrite (interp_m_ok a0 v); rewrite (interp_m_ok a l). +auto. + +rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c)); + rewrite (ics_aux_ok (interp_m a0 v) c); rewrite H. +auto. + +simpl in |- *. +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *. +rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c); + rewrite (ics_aux_ok (interp_vl v) c). +rewrite (interp_m_ok (Aplus a Aone) v). +setoid_replace (Amult (Aplus a Aone) (interp_vl v)) with + (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v))); + [ idtac | trivial ]. +setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); + [ idtac | trivial ]. +auto. + +elim (varlist_lt l v); simpl in |- *; intros; auto. +rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c)); rewrite H. +rewrite (ics_aux_ok (interp_vl v) c); auto. +Qed. + +Lemma varlist_insert_ok : + forall (l:varlist) (s:canonical_sum), + Aequiv (interp_setcs (varlist_insert l s)) + (Aplus (interp_vl l) (interp_setcs s)). +Proof. +simple induction s; simpl in |- *; intros. +trivial. + +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *. +rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c); + rewrite (ics_aux_ok (interp_m a v) c). +rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v). +setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with + (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v))); + [ idtac | trivial ]. +setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto. + +elim (varlist_lt l v); simpl in |- *; intros; auto. +rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c)); + rewrite (ics_aux_ok (interp_m a v) c). +rewrite (interp_m_ok a v). +rewrite H; auto. + +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *. +rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c); + rewrite (ics_aux_ok (interp_vl v) c). +rewrite (interp_m_ok (Aplus Aone Aone) v). +setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with + (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v))); + [ idtac | trivial ]. +setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto. + +elim (varlist_lt l v); simpl in |- *; intros; auto. +rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)). +rewrite H. +rewrite (ics_aux_ok (interp_vl v) c); auto. +Qed. + +Lemma canonical_sum_scalar_ok : + forall (a:A) (s:canonical_sum), + Aequiv (interp_setcs (canonical_sum_scalar a s)) + (Amult a (interp_setcs s)). +Proof. +simple induction s; simpl in |- *; intros. +trivial. + +rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c)); + rewrite (ics_aux_ok (interp_m a0 v) c). +rewrite (interp_m_ok (Amult a a0) v); rewrite (interp_m_ok a0 v). +rewrite H. +setoid_replace (Amult a (Aplus (Amult a0 (interp_vl v)) (interp_setcs c))) + with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c))); + [ idtac | trivial ]. +auto. + +rewrite (ics_aux_ok (interp_m a v) (canonical_sum_scalar a c)); + rewrite (ics_aux_ok (interp_vl v) c); rewrite H. +rewrite (interp_m_ok a v). +auto. +Qed. + +Lemma canonical_sum_scalar2_ok : + forall (l:varlist) (s:canonical_sum), + Aequiv (interp_setcs (canonical_sum_scalar2 l s)) + (Amult (interp_vl l) (interp_setcs s)). +Proof. +simple induction s; simpl in |- *; intros; auto. +rewrite (monom_insert_ok a (varlist_merge l v) (canonical_sum_scalar2 l c)). +rewrite (ics_aux_ok (interp_m a v) c). +rewrite (interp_m_ok a v). +rewrite H. +rewrite (varlist_merge_ok l v). +setoid_replace + (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c))) with + (Aplus (Amult (interp_vl l) (Amult a (interp_vl v))) + (Amult (interp_vl l) (interp_setcs c))); + [ idtac | trivial ]. +auto. + +rewrite (varlist_insert_ok (varlist_merge l v) (canonical_sum_scalar2 l c)). +rewrite (ics_aux_ok (interp_vl v) c). +rewrite H. +rewrite (varlist_merge_ok l v). +auto. +Qed. + +Lemma canonical_sum_scalar3_ok : + forall (c:A) (l:varlist) (s:canonical_sum), + Aequiv (interp_setcs (canonical_sum_scalar3 c l s)) + (Amult c (Amult (interp_vl l) (interp_setcs s))). +Proof. +simple induction s; simpl in |- *; intros. +rewrite (SSR_mult_zero_right S T (interp_vl l)). +auto. + +rewrite + (monom_insert_ok (Amult c a) (varlist_merge l v) + (canonical_sum_scalar3 c l c0)). +rewrite (ics_aux_ok (interp_m a v) c0). +rewrite (interp_m_ok a v). +rewrite H. +rewrite (varlist_merge_ok l v). +setoid_replace + (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c0))) with + (Aplus (Amult (interp_vl l) (Amult a (interp_vl v))) + (Amult (interp_vl l) (interp_setcs c0))); + [ idtac | trivial ]. +setoid_replace + (Amult c + (Aplus (Amult (interp_vl l) (Amult a (interp_vl v))) + (Amult (interp_vl l) (interp_setcs c0)))) with + (Aplus (Amult c (Amult (interp_vl l) (Amult a (interp_vl v)))) + (Amult c (Amult (interp_vl l) (interp_setcs c0)))); + [ idtac | trivial ]. +setoid_replace (Amult (Amult c a) (Amult (interp_vl l) (interp_vl v))) with + (Amult c (Amult a (Amult (interp_vl l) (interp_vl v)))); + [ idtac | trivial ]. +auto. + +rewrite + (monom_insert_ok c (varlist_merge l v) (canonical_sum_scalar3 c l c0)) + . +rewrite (ics_aux_ok (interp_vl v) c0). +rewrite H. +rewrite (varlist_merge_ok l v). +setoid_replace + (Aplus (Amult c (Amult (interp_vl l) (interp_vl v))) + (Amult c (Amult (interp_vl l) (interp_setcs c0)))) with + (Amult c + (Aplus (Amult (interp_vl l) (interp_vl v)) + (Amult (interp_vl l) (interp_setcs c0)))); + [ idtac | trivial ]. +auto. +Qed. + +Lemma canonical_sum_prod_ok : + forall x y:canonical_sum, + Aequiv (interp_setcs (canonical_sum_prod x y)) + (Amult (interp_setcs x) (interp_setcs y)). +Proof. +simple induction x; simpl in |- *; intros. +trivial. + +rewrite + (canonical_sum_merge_ok (canonical_sum_scalar3 a v y) + (canonical_sum_prod c y)). +rewrite (canonical_sum_scalar3_ok a v y). +rewrite (ics_aux_ok (interp_m a v) c). +rewrite (interp_m_ok a v). +rewrite (H y). +setoid_replace (Amult a (Amult (interp_vl v) (interp_setcs y))) with + (Amult (Amult a (interp_vl v)) (interp_setcs y)); + [ idtac | trivial ]. +setoid_replace + (Amult (Aplus (Amult a (interp_vl v)) (interp_setcs c)) (interp_setcs y)) + with + (Aplus (Amult (Amult a (interp_vl v)) (interp_setcs y)) + (Amult (interp_setcs c) (interp_setcs y))); + [ idtac | trivial ]. +trivial. + +rewrite + (canonical_sum_merge_ok (canonical_sum_scalar2 v y) (canonical_sum_prod c y)) + . +rewrite (canonical_sum_scalar2_ok v y). +rewrite (ics_aux_ok (interp_vl v) c). +rewrite (H y). +trivial. +Qed. + +Theorem setspolynomial_normalize_ok : + forall p:setspolynomial, + Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p). +Proof. +simple induction p; simpl in |- *; intros; trivial. +rewrite + (canonical_sum_merge_ok (setspolynomial_normalize s) + (setspolynomial_normalize s0)). +rewrite H; rewrite H0; trivial. + +rewrite + (canonical_sum_prod_ok (setspolynomial_normalize s) + (setspolynomial_normalize s0)). +rewrite H; rewrite H0; trivial. +Qed. + +Lemma canonical_sum_simplify_ok : + forall s:canonical_sum, + Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s). +Proof. +simple induction s; simpl in |- *; intros. +trivial. + +generalize (SSR_eq_prop T a Azero). +elim (Aeq a Azero). +simpl in |- *. +intros. +rewrite (ics_aux_ok (interp_m a v) c). +rewrite (interp_m_ok a v). +rewrite (H0 I). +setoid_replace (Amult Azero (interp_vl v)) with Azero; + [ idtac | trivial ]. +rewrite H. +trivial. + +intros; simpl in |- *. +generalize (SSR_eq_prop T a Aone). +elim (Aeq a Aone). +intros. +rewrite (ics_aux_ok (interp_m a v) c). +rewrite (interp_m_ok a v). +rewrite (H1 I). +simpl in |- *. +rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)). +rewrite H. +auto. + +simpl in |- *. +intros. +rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)). +rewrite (ics_aux_ok (interp_m a v) c). +rewrite H; trivial. + +rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)). +rewrite H. +auto. +Qed. + +Theorem setspolynomial_simplify_ok : + forall p:setspolynomial, + Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p). +Proof. +intro. +unfold setspolynomial_simplify in |- *. +rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)). +exact (setspolynomial_normalize_ok p). +Qed. + +End semi_setoid_rings. + +Implicit Arguments Cons_varlist. +Implicit Arguments Cons_monom. +Implicit Arguments SetSPconst. +Implicit Arguments SetSPplus. +Implicit Arguments SetSPmult. + + + +Section setoid_rings. + +Set Implicit Arguments. + +Variable vm : varmap A. +Variable T : Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq. + +Hint Resolve (STh_plus_comm T). +Hint Resolve (STh_plus_assoc T). +Hint Resolve (STh_plus_assoc2 S T). +Hint Resolve (STh_mult_comm T). +Hint Resolve (STh_mult_assoc T). +Hint Resolve (STh_mult_assoc2 S T). +Hint Resolve (STh_plus_zero_left T). +Hint Resolve (STh_plus_zero_left2 S T). +Hint Resolve (STh_mult_one_left T). +Hint Resolve (STh_mult_one_left2 S T). +Hint Resolve (STh_mult_zero_left S plus_morph mult_morph T). +Hint Resolve (STh_mult_zero_left2 S plus_morph mult_morph T). +Hint Resolve (STh_distr_left T). +Hint Resolve (STh_distr_left2 S T). +Hint Resolve (STh_plus_reg_left S plus_morph T). +Hint Resolve (STh_plus_permute S plus_morph T). +Hint Resolve (STh_mult_permute S mult_morph T). +Hint Resolve (STh_distr_right S plus_morph T). +Hint Resolve (STh_distr_right2 S plus_morph T). +Hint Resolve (STh_mult_zero_right S plus_morph mult_morph T). +Hint Resolve (STh_mult_zero_right2 S plus_morph mult_morph T). +Hint Resolve (STh_plus_zero_right S T). +Hint Resolve (STh_plus_zero_right2 S T). +Hint Resolve (STh_mult_one_right S T). +Hint Resolve (STh_mult_one_right2 S T). +Hint Resolve (STh_plus_reg_right S plus_morph T). +Hint Resolve refl_equal sym_equal trans_equal. +(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Immediate T. + + +(*** Definitions *) + +Inductive setpolynomial : Type := + | SetPvar : index -> setpolynomial + | SetPconst : A -> setpolynomial + | SetPplus : setpolynomial -> setpolynomial -> setpolynomial + | SetPmult : setpolynomial -> setpolynomial -> setpolynomial + | SetPopp : setpolynomial -> setpolynomial. + +Fixpoint setpolynomial_normalize (x:setpolynomial) : canonical_sum := + match x with + | SetPplus l r => + canonical_sum_merge (setpolynomial_normalize l) + (setpolynomial_normalize r) + | SetPmult l r => + canonical_sum_prod (setpolynomial_normalize l) + (setpolynomial_normalize r) + | SetPconst c => Cons_monom c Nil_var Nil_monom + | SetPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom + | SetPopp p => + canonical_sum_scalar3 (Aopp Aone) Nil_var (setpolynomial_normalize p) + end. + +Definition setpolynomial_simplify (x:setpolynomial) := + canonical_sum_simplify (setpolynomial_normalize x). + +Fixpoint setspolynomial_of (x:setpolynomial) : setspolynomial := + match x with + | SetPplus l r => SetSPplus (setspolynomial_of l) (setspolynomial_of r) + | SetPmult l r => SetSPmult (setspolynomial_of l) (setspolynomial_of r) + | SetPconst c => SetSPconst c + | SetPvar i => SetSPvar i + | SetPopp p => SetSPmult (SetSPconst (Aopp Aone)) (setspolynomial_of p) + end. + +(*** Interpretation *) + +Fixpoint interp_setp (p:setpolynomial) : A := + match p with + | SetPconst c => c + | SetPvar i => varmap_find Azero i vm + | SetPplus p1 p2 => Aplus (interp_setp p1) (interp_setp p2) + | SetPmult p1 p2 => Amult (interp_setp p1) (interp_setp p2) + | SetPopp p1 => Aopp (interp_setp p1) + end. + +(*** Properties *) + +Unset Implicit Arguments. + +Lemma setspolynomial_of_ok : + forall p:setpolynomial, + Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)). +simple induction p; trivial; simpl in |- *; intros. +rewrite H; rewrite H0; trivial. +rewrite H; rewrite H0; trivial. +rewrite H. +rewrite + (STh_opp_mult_left2 S plus_morph mult_morph T Aone + (interp_setsp vm (setspolynomial_of s))). +rewrite (STh_mult_one_left T (interp_setsp vm (setspolynomial_of s))). +trivial. +Qed. + +Theorem setpolynomial_normalize_ok : + forall p:setpolynomial, + setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p). +simple induction p; trivial; simpl in |- *; intros. +rewrite H; rewrite H0; reflexivity. +rewrite H; rewrite H0; reflexivity. +rewrite H; simpl in |- *. +elim + (canonical_sum_scalar3 (Aopp Aone) Nil_var + (setspolynomial_normalize (setspolynomial_of s))); + [ reflexivity + | simpl in |- *; intros; rewrite H0; reflexivity + | simpl in |- *; intros; rewrite H0; reflexivity ]. +Qed. + +Theorem setpolynomial_simplify_ok : + forall p:setpolynomial, + Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p). +intro. +unfold setpolynomial_simplify in |- *. +rewrite (setspolynomial_of_ok p). +rewrite setpolynomial_normalize_ok. +rewrite + (canonical_sum_simplify_ok vm + (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq + plus_morph mult_morph T) + (setspolynomial_normalize (setspolynomial_of p))) + . +rewrite + (setspolynomial_normalize_ok vm + (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq + plus_morph mult_morph T) (setspolynomial_of p)) + . +trivial. +Qed. + +End setoid_rings. + +End setoid. diff --git a/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v new file mode 100644 index 00000000..2c2314af --- /dev/null +++ b/plugins/ring/Setoid_ring_theory.v @@ -0,0 +1,427 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A -> Prop. + +Infix Local "==" := Aequiv (at level 70, no associativity). + +Variable S : Setoid_Theory A Aequiv. + +Add Setoid A Aequiv S as Asetoid. + +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aopp : A -> A. +Variable Aeq : A -> A -> bool. + +Infix "+" := Aplus (at level 50, left associativity). +Infix "*" := Amult (at level 40, left associativity). +Notation "0" := Azero. +Notation "1" := Aone. +Notation "- x" := (Aopp x). + +Variable plus_morph : + forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a + a1 == a0 + a2. +Variable mult_morph : + forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a * a1 == a0 * a2. +Variable opp_morph : forall a a0:A, a == a0 -> - a == - a0. + +Add Morphism Aplus : Aplus_ext. +intros; apply plus_morph; assumption. +Qed. + +Add Morphism Amult : Amult_ext. +intros; apply mult_morph; assumption. +Qed. + +Add Morphism Aopp : Aopp_ext. +exact opp_morph. +Qed. + +Section Theory_of_semi_setoid_rings. + +Record Semi_Setoid_Ring_Theory : Prop := + {SSR_plus_comm : forall n m:A, n + m == m + n; + SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p; + SSR_mult_comm : forall n m:A, n * m == m * n; + SSR_mult_assoc : forall n m p:A, n * (m * p) == n * m * p; + SSR_plus_zero_left : forall n:A, 0 + n == n; + SSR_mult_one_left : forall n:A, 1 * n == n; + SSR_mult_zero_left : forall n:A, 0 * n == 0; + SSR_distr_left : forall n m p:A, (n + m) * p == n * p + m * p; + SSR_plus_reg_left : forall n m p:A, n + m == n + p -> m == p; + SSR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}. + +Variable T : Semi_Setoid_Ring_Theory. + +Let plus_comm := SSR_plus_comm T. +Let plus_assoc := SSR_plus_assoc T. +Let mult_comm := SSR_mult_comm T. +Let mult_assoc := SSR_mult_assoc T. +Let plus_zero_left := SSR_plus_zero_left T. +Let mult_one_left := SSR_mult_one_left T. +Let mult_zero_left := SSR_mult_zero_left T. +Let distr_left := SSR_distr_left T. +Let plus_reg_left := SSR_plus_reg_left T. +Let equiv_refl := Seq_refl A Aequiv S. +Let equiv_sym := Seq_sym A Aequiv S. +Let equiv_trans := Seq_trans A Aequiv S. + +Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left + mult_one_left mult_zero_left distr_left plus_reg_left + equiv_refl (*equiv_sym*). +Hint Immediate equiv_sym. + +(* Lemmas whose form is x=y are also provided in form y=x because + Auto does not symmetry *) +Lemma SSR_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p). +auto. Qed. + +Lemma SSR_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p). +auto. Qed. + +Lemma SSR_plus_zero_left2 : forall n:A, n == 0 + n. +auto. Qed. + +Lemma SSR_mult_one_left2 : forall n:A, n == 1 * n. +auto. Qed. + +Lemma SSR_mult_zero_left2 : forall n:A, 0 == 0 * n. +auto. Qed. + +Lemma SSR_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p. +auto. Qed. + +Lemma SSR_plus_permute : forall n m p:A, n + (m + p) == m + (n + p). +intros. +rewrite (plus_assoc n m p). +rewrite (plus_comm n m). +rewrite <- (plus_assoc m n p). +trivial. +Qed. + +Lemma SSR_mult_permute : forall n m p:A, n * (m * p) == m * (n * p). +intros. +rewrite (mult_assoc n m p). +rewrite (mult_comm n m). +rewrite <- (mult_assoc m n p). +trivial. +Qed. + +Hint Resolve SSR_plus_permute SSR_mult_permute. + +Lemma SSR_distr_right : forall n m p:A, n * (m + p) == n * m + n * p. +intros. +rewrite (mult_comm n (m + p)). +rewrite (mult_comm n m). +rewrite (mult_comm n p). +auto. +Qed. + +Lemma SSR_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p). +intros. +apply equiv_sym. +apply SSR_distr_right. +Qed. + +Lemma SSR_mult_zero_right : forall n:A, n * 0 == 0. +intro; rewrite (mult_comm n 0); auto. +Qed. + +Lemma SSR_mult_zero_right2 : forall n:A, 0 == n * 0. +intro; rewrite (mult_comm n 0); auto. +Qed. + +Lemma SSR_plus_zero_right : forall n:A, n + 0 == n. +intro; rewrite (plus_comm n 0); auto. +Qed. + +Lemma SSR_plus_zero_right2 : forall n:A, n == n + 0. +intro; rewrite (plus_comm n 0); auto. +Qed. + +Lemma SSR_mult_one_right : forall n:A, n * 1 == n. +intro; rewrite (mult_comm n 1); auto. +Qed. + +Lemma SSR_mult_one_right2 : forall n:A, n == n * 1. +intro; rewrite (mult_comm n 1); auto. +Qed. + +Lemma SSR_plus_reg_right : forall n m p:A, m + n == p + n -> m == p. +intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n). +intro; apply plus_reg_left with n; trivial. +Qed. + +End Theory_of_semi_setoid_rings. + +Section Theory_of_setoid_rings. + +Record Setoid_Ring_Theory : Prop := + {STh_plus_comm : forall n m:A, n + m == m + n; + STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p; + STh_mult_comm : forall n m:A, n * m == m * n; + STh_mult_assoc : forall n m p:A, n * (m * p) == n * m * p; + STh_plus_zero_left : forall n:A, 0 + n == n; + STh_mult_one_left : forall n:A, 1 * n == n; + STh_opp_def : forall n:A, n + - n == 0; + STh_distr_left : forall n m p:A, (n + m) * p == n * p + m * p; + STh_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}. + +Variable T : Setoid_Ring_Theory. + +Let plus_comm := STh_plus_comm T. +Let plus_assoc := STh_plus_assoc T. +Let mult_comm := STh_mult_comm T. +Let mult_assoc := STh_mult_assoc T. +Let plus_zero_left := STh_plus_zero_left T. +Let mult_one_left := STh_mult_one_left T. +Let opp_def := STh_opp_def T. +Let distr_left := STh_distr_left T. +Let equiv_refl := Seq_refl A Aequiv S. +Let equiv_sym := Seq_sym A Aequiv S. +Let equiv_trans := Seq_trans A Aequiv S. + +Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left + mult_one_left opp_def distr_left equiv_refl equiv_sym. + +(* Lemmas whose form is x=y are also provided in form y=x because Auto does + not symmetry *) + +Lemma STh_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p). +auto. Qed. + +Lemma STh_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p). +auto. Qed. + +Lemma STh_plus_zero_left2 : forall n:A, n == 0 + n. +auto. Qed. + +Lemma STh_mult_one_left2 : forall n:A, n == 1 * n. +auto. Qed. + +Lemma STh_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p. +auto. Qed. + +Lemma STh_opp_def2 : forall n:A, 0 == n + - n. +auto. Qed. + +Lemma STh_plus_permute : forall n m p:A, n + (m + p) == m + (n + p). +intros. +rewrite (plus_assoc n m p). +rewrite (plus_comm n m). +rewrite <- (plus_assoc m n p). +trivial. +Qed. + +Lemma STh_mult_permute : forall n m p:A, n * (m * p) == m * (n * p). +intros. +rewrite (mult_assoc n m p). +rewrite (mult_comm n m). +rewrite <- (mult_assoc m n p). +trivial. +Qed. + +Hint Resolve STh_plus_permute STh_mult_permute. + +Lemma Saux1 : forall a:A, a + a == a -> a == 0. +intros. +rewrite <- (plus_zero_left a). +rewrite (plus_comm 0 a). +setoid_replace (a + 0) with (a + (a + - a)) by auto. +rewrite (plus_assoc a a (- a)). +rewrite H. +apply opp_def. +Qed. + +Lemma STh_mult_zero_left : forall n:A, 0 * n == 0. +intros. +apply Saux1. +rewrite <- (distr_left 0 0 n). +rewrite (plus_zero_left 0). +trivial. +Qed. +Hint Resolve STh_mult_zero_left. + +Lemma STh_mult_zero_left2 : forall n:A, 0 == 0 * n. +auto. +Qed. + +Lemma Saux2 : forall x y z:A, x + y == 0 -> x + z == 0 -> y == z. +intros. +rewrite <- (plus_zero_left y). +rewrite <- H0. +rewrite <- (plus_assoc x z y). +rewrite (plus_comm z y). +rewrite (plus_assoc x y z). +rewrite H. +auto. +Qed. + +Lemma STh_opp_mult_left : forall x y:A, - (x * y) == - x * y. +intros. +apply Saux2 with (x * y); auto. +rewrite <- (distr_left x (- x) y). +rewrite (opp_def x). +auto. +Qed. +Hint Resolve STh_opp_mult_left. + +Lemma STh_opp_mult_left2 : forall x y:A, - x * y == - (x * y). +auto. +Qed. + +Lemma STh_mult_zero_right : forall n:A, n * 0 == 0. +intro; rewrite (mult_comm n 0); auto. +Qed. + +Lemma STh_mult_zero_right2 : forall n:A, 0 == n * 0. +intro; rewrite (mult_comm n 0); auto. +Qed. + +Lemma STh_plus_zero_right : forall n:A, n + 0 == n. +intro; rewrite (plus_comm n 0); auto. +Qed. + +Lemma STh_plus_zero_right2 : forall n:A, n == n + 0. +intro; rewrite (plus_comm n 0); auto. +Qed. + +Lemma STh_mult_one_right : forall n:A, n * 1 == n. +intro; rewrite (mult_comm n 1); auto. +Qed. + +Lemma STh_mult_one_right2 : forall n:A, n == n * 1. +intro; rewrite (mult_comm n 1); auto. +Qed. + +Lemma STh_opp_mult_right : forall x y:A, - (x * y) == x * - y. +intros. +rewrite (mult_comm x y). +rewrite (mult_comm x (- y)). +auto. +Qed. + +Lemma STh_opp_mult_right2 : forall x y:A, x * - y == - (x * y). +intros. +rewrite (mult_comm x y). +rewrite (mult_comm x (- y)). +auto. +Qed. + +Lemma STh_plus_opp_opp : forall x y:A, - x + - y == - (x + y). +intros. +apply Saux2 with (x + y); auto. +rewrite (STh_plus_permute (x + y) (- x) (- y)). +rewrite <- (plus_assoc x y (- y)). +rewrite (opp_def y); rewrite (STh_plus_zero_right x). +rewrite (STh_opp_def2 x); trivial. +Qed. + +Lemma STh_plus_permute_opp : forall n m p:A, - m + (n + p) == n + (- m + p). +auto. +Qed. + +Lemma STh_opp_opp : forall n:A, - - n == n. +intro. +apply Saux2 with (- n); auto. +rewrite (plus_comm (- n) n); auto. +Qed. +Hint Resolve STh_opp_opp. + +Lemma STh_opp_opp2 : forall n:A, n == - - n. +auto. +Qed. + +Lemma STh_mult_opp_opp : forall x y:A, - x * - y == x * y. +intros. +rewrite (STh_opp_mult_left2 x (- y)). +rewrite (STh_opp_mult_right2 x y). +trivial. +Qed. + +Lemma STh_mult_opp_opp2 : forall x y:A, x * y == - x * - y. +intros. +apply equiv_sym. +apply STh_mult_opp_opp. +Qed. + +Lemma STh_opp_zero : - 0 == 0. +rewrite <- (plus_zero_left (- 0)). +trivial. +Qed. + +Lemma STh_plus_reg_left : forall n m p:A, n + m == n + p -> m == p. +intros. +rewrite <- (plus_zero_left m). +rewrite <- (plus_zero_left p). +rewrite <- (opp_def n). +rewrite (plus_comm n (- n)). +rewrite <- (plus_assoc (- n) n m). +rewrite <- (plus_assoc (- n) n p). +auto. +Qed. + +Lemma STh_plus_reg_right : forall n m p:A, m + n == p + n -> m == p. +intros. +apply STh_plus_reg_left with n. +rewrite (plus_comm n m); rewrite (plus_comm n p); assumption. +Qed. + +Lemma STh_distr_right : forall n m p:A, n * (m + p) == n * m + n * p. +intros. +rewrite (mult_comm n (m + p)). +rewrite (mult_comm n m). +rewrite (mult_comm n p). +trivial. +Qed. + +Lemma STh_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p). +intros. +apply equiv_sym. +apply STh_distr_right. +Qed. + +End Theory_of_setoid_rings. + +Hint Resolve STh_mult_zero_left STh_plus_reg_left: core. + +Unset Implicit Arguments. + +Definition Semi_Setoid_Ring_Theory_of : + Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory. +intros until 1; case H. +split; intros; simpl in |- *; eauto. +Defined. + +Coercion Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory >-> + Semi_Setoid_Ring_Theory. + + + +Section product_ring. + +End product_ring. + +Section power_ring. + +End power_ring. + +End Setoid_rings. diff --git a/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4 new file mode 100644 index 00000000..d766e344 --- /dev/null +++ b/plugins/ring/g_ring.ml4 @@ -0,0 +1,136 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ polynom l ] +END + +(* The vernac commands "Add Ring" and co *) + +let cset_of_constrarg_list l = + List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty + +VERNAC COMMAND EXTEND AddRing + [ "Add" "Legacy" "Ring" + constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) + constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] + -> [ add_theory true false false + (constr_of a) + None + None + None + (constr_of aplus) + (constr_of amult) + (constr_of aone) + (constr_of azero) + (Some (constr_of aopp)) + (constr_of aeq) + (constr_of t) + (cset_of_constrarg_list l) ] + +| [ "Add" "Legacy" "Semi" "Ring" + constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) + constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] + -> [ add_theory false false false + (constr_of a) + None + None + None + (constr_of aplus) + (constr_of amult) + (constr_of aone) + (constr_of azero) + None + (constr_of aeq) + (constr_of t) + (cset_of_constrarg_list l) ] + +| [ "Add" "Legacy" "Abstract" "Ring" + constr(a) constr(aplus) constr(amult) constr(aone) + constr(azero) constr(aopp) constr(aeq) constr(t) ] + -> [ add_theory true true false + (constr_of a) + None + None + None + (constr_of aplus) + (constr_of amult) + (constr_of aone) + (constr_of azero) + (Some (constr_of aopp)) + (constr_of aeq) + (constr_of t) + ConstrSet.empty ] + +| [ "Add" "Legacy" "Abstract" "Semi" "Ring" + constr(a) constr(aplus) constr(amult) constr(aone) + constr(azero) constr(aeq) constr(t) ] + -> [ add_theory false true false + (constr_of a) + None + None + None + (constr_of aplus) + (constr_of amult) + (constr_of aone) + (constr_of azero) + None + (constr_of aeq) + (constr_of t) + ConstrSet.empty ] + +| [ "Add" "Legacy" "Setoid" "Ring" + constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) + constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm) + constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] + -> [ add_theory true false true + (constr_of a) + (Some (constr_of aequiv)) + (Some (constr_of asetth)) + (Some { + plusm = (constr_of pm); + multm = (constr_of mm); + oppm = Some (constr_of om) }) + (constr_of aplus) + (constr_of amult) + (constr_of aone) + (constr_of azero) + (Some (constr_of aopp)) + (constr_of aeq) + (constr_of t) + (cset_of_constrarg_list l) ] + +| [ "Add" "Legacy" "Semi" "Setoid" "Ring" + constr(a) constr(aequiv) constr(asetth) constr(aplus) + constr(amult) constr(aone) constr(azero) constr(aeq) + constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] + -> [ add_theory false false true + (constr_of a) + (Some (constr_of aequiv)) + (Some (constr_of asetth)) + (Some { + plusm = (constr_of pm); + multm = (constr_of mm); + oppm = None }) + (constr_of aplus) + (constr_of amult) + (constr_of aone) + (constr_of azero) + None + (constr_of aeq) + (constr_of t) + (cset_of_constrarg_list l) ] +END diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml new file mode 100644 index 00000000..1e3765da --- /dev/null +++ b/plugins/ring/ring.ml @@ -0,0 +1,924 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* to be found in Coqlib *) +open Coqlib + +let mkLApp(fc,v) = mkApp(Lazy.force fc, v) + +(*********** Useful types and functions ************) + +module OperSet = + Set.Make (struct + type t = global_reference + let compare = (Pervasives.compare : t->t->int) + end) + +type morph = + { plusm : constr; + multm : constr; + oppm : constr option; + } + +type theory = + { th_ring : bool; (* false for a semi-ring *) + th_abstract : bool; + th_setoid : bool; (* true for a setoid ring *) + th_equiv : constr option; + th_setoid_th : constr option; + th_morph : morph option; + th_a : constr; (* e.g. nat *) + th_plus : constr; + th_mult : constr; + th_one : constr; + th_zero : constr; + th_opp : constr option; (* None if semi-ring *) + th_eq : constr; + th_t : constr; (* e.g. NatTheory *) + th_closed : ConstrSet.t; (* e.g. [S; O] *) + (* Must be empty for an abstract ring *) + } + +(* Theories are stored in a table which is synchronised with the Reset + mechanism. *) + +module Cmap = Map.Make(struct type t = constr let compare = compare end) + +let theories_map = ref Cmap.empty + +let theories_map_add (c,t) = theories_map := Cmap.add c t !theories_map +let theories_map_find c = Cmap.find c !theories_map +let theories_map_mem c = Cmap.mem c !theories_map + +let _ = + Summary.declare_summary "tactic-ring-table" + { Summary.freeze_function = (fun () -> !theories_map); + Summary.unfreeze_function = (fun t -> theories_map := t); + Summary.init_function = (fun () -> theories_map := Cmap.empty) } + +(* declare a new type of object in the environment, "tactic-ring-theory" + The functions theory_to_obj and obj_to_theory do the conversions + between theories and environement objects. *) + + +let subst_morph subst morph = + let plusm' = subst_mps subst morph.plusm in + let multm' = subst_mps subst morph.multm in + let oppm' = Option.smartmap (subst_mps subst) morph.oppm in + if plusm' == morph.plusm + && multm' == morph.multm + && oppm' == morph.oppm then + morph + else + { plusm = plusm' ; + multm = multm' ; + oppm = oppm' ; + } + +let subst_set subst cset = + let same = ref true in + let copy_subst c newset = + let c' = subst_mps subst c in + if not (c' == c) then same := false; + ConstrSet.add c' newset + in + let cset' = ConstrSet.fold copy_subst cset ConstrSet.empty in + if !same then cset else cset' + +let subst_theory subst th = + let th_equiv' = Option.smartmap (subst_mps subst) th.th_equiv in + let th_setoid_th' = Option.smartmap (subst_mps subst) th.th_setoid_th in + let th_morph' = Option.smartmap (subst_morph subst) th.th_morph in + let th_a' = subst_mps subst th.th_a in + let th_plus' = subst_mps subst th.th_plus in + let th_mult' = subst_mps subst th.th_mult in + let th_one' = subst_mps subst th.th_one in + let th_zero' = subst_mps subst th.th_zero in + let th_opp' = Option.smartmap (subst_mps subst) th.th_opp in + let th_eq' = subst_mps subst th.th_eq in + let th_t' = subst_mps subst th.th_t in + let th_closed' = subst_set subst th.th_closed in + if th_equiv' == th.th_equiv + && th_setoid_th' == th.th_setoid_th + && th_morph' == th.th_morph + && th_a' == th.th_a + && th_plus' == th.th_plus + && th_mult' == th.th_mult + && th_one' == th.th_one + && th_zero' == th.th_zero + && th_opp' == th.th_opp + && th_eq' == th.th_eq + && th_t' == th.th_t + && th_closed' == th.th_closed + then + th + else + { th_ring = th.th_ring ; + th_abstract = th.th_abstract ; + th_setoid = th.th_setoid ; + th_equiv = th_equiv' ; + th_setoid_th = th_setoid_th' ; + th_morph = th_morph' ; + th_a = th_a' ; + th_plus = th_plus' ; + th_mult = th_mult' ; + th_one = th_one' ; + th_zero = th_zero' ; + th_opp = th_opp' ; + th_eq = th_eq' ; + th_t = th_t' ; + th_closed = th_closed' ; + } + + +let subst_th (subst,(c,th as obj)) = + let c' = subst_mps subst c in + let th' = subst_theory subst th in + if c' == c && th' == th then obj else + (c',th') + + +let (theory_to_obj, obj_to_theory) = + let cache_th (_,(c, th)) = theories_map_add (c,th) in + declare_object {(default_object "tactic-ring-theory") with + open_function = (fun i o -> if i=1 then cache_th o); + cache_function = cache_th; + subst_function = subst_th; + classify_function = (fun x -> Substitute x) } + +(* from the set A, guess the associated theory *) +(* With this simple solution, the theory to use is automatically guessed *) +(* But only one theory can be declared for a given Set *) + +let guess_theory a = + try + theories_map_find a + with Not_found -> + errorlabstrm "Ring" + (str "No Declared Ring Theory for " ++ + pr_lconstr a ++ fnl () ++ + str "Use Add [Semi] Ring to declare it") + +(* Looks up an option *) + +let unbox = function + | Some w -> w + | None -> anomaly "Ring : Not in case of a setoid ring." + +(* Protects the convertibility test against undue exceptions when using it + with untyped terms *) + +let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false + + +(* Add a Ring or a Semi-Ring to the database after a type verification *) + +let implement_theory env t th args = + is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (th, args)) + +(* (\* The following test checks whether the provided morphism is the default *) +(* one for the given operation. In principle the test is too strict, since *) +(* it should possible to provide another proof for the same fact (proof *) +(* irrelevance). In particular, the error message is be not very explicative. *\) *) +let states_compatibility_for env plus mult opp morphs = + let check op compat = true in +(* is_conv env Evd.empty (Setoid_replace.default_morphism op).Setoid_replace.lem *) +(* compat in *) + check plus morphs.plusm && + check mult morphs.multm && + (match (opp,morphs.oppm) with + None, None -> true + | Some opp, Some compat -> check opp compat + | _,_ -> assert false) + +let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset = + if theories_map_mem a then errorlabstrm "Add Semi Ring" + (str "A (Semi-)(Setoid-)Ring Structure is already declared for " ++ + pr_lconstr a); + let env = Global.env () in + if (want_ring & want_setoid & ( + not (implement_theory env t coq_Setoid_Ring_Theory + [| a; (unbox aequiv); aplus; amult; aone; azero; (unbox aopp); aeq|]) + || + not (implement_theory env (unbox asetth) coq_Setoid_Theory + [| a; (unbox aequiv) |]) || + not (states_compatibility_for env aplus amult aopp (unbox amorph)) + )) then + errorlabstrm "addring" (str "Not a valid Setoid-Ring theory"); + if (not want_ring & want_setoid & ( + not (implement_theory env t coq_Semi_Setoid_Ring_Theory + [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) || + not (implement_theory env (unbox asetth) coq_Setoid_Theory + [| a; (unbox aequiv) |]) || + not (states_compatibility_for env aplus amult aopp (unbox amorph)))) + then + errorlabstrm "addring" (str "Not a valid Semi-Setoid-Ring theory"); + if (want_ring & not want_setoid & + not (implement_theory env t coq_Ring_Theory + [| a; aplus; amult; aone; azero; (unbox aopp); aeq |])) then + errorlabstrm "addring" (str "Not a valid Ring theory"); + if (not want_ring & not want_setoid & + not (implement_theory env t coq_Semi_Ring_Theory + [| a; aplus; amult; aone; azero; aeq |])) then + errorlabstrm "addring" (str "Not a valid Semi-Ring theory"); + Lib.add_anonymous_leaf + (theory_to_obj + (a, { th_ring = want_ring; + th_abstract = want_abstract; + th_setoid = want_setoid; + th_equiv = aequiv; + th_setoid_th = asetth; + th_morph = amorph; + th_a = a; + th_plus = aplus; + th_mult = amult; + th_one = aone; + th_zero = azero; + th_opp = aopp; + th_eq = aeq; + th_t = t; + th_closed = cset })) + +(******** The tactic itself *********) + +(* + gl : goal sigma + th : semi-ring theory (concrete) + cl : constr list [c1; c2; ...] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + where c'i is convertible with ci and + c'i_eq_c''i is a proof of equality of c'i and c''i + +*) + +let build_spolynom gl th lc = + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + (* aux creates the spolynom p by a recursive destructuration of c + and builds the varmap with side-effects *) + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with + | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> + mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |]) + | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> + mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |]) + | _ when closed_under th.th_closed c -> + mkLApp(coq_SPconst, [|th.th_a; c |]) + | _ -> + try Hashtbl.find varhash c + with Not_found -> + let newvar = + mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + in + let lp = List.map aux lc in + let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in + List.map + (fun p -> + (mkLApp (coq_interp_sp, + [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), + mkLApp (coq_interp_cs, + [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; + pf_reduce cbv_betadeltaiota gl + (mkLApp (coq_spolynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; + th.th_eq; p|])) |]), + mkLApp (coq_spolynomial_simplify_ok, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + th.th_eq; v; th.th_t; p |]))) + lp + +(* + gl : goal sigma + th : ring theory (concrete) + cl : constr list [c1; c2; ...] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + where c'i is convertible with ci and + c'i_eq_c''i is a proof of equality of c'i and c''i + +*) + +let build_polynom gl th lc = + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> + mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> + mkLApp(coq_Pmult, [|th.th_a; aux c1; aux c2 |]) + (* The special case of Zminus *) + | App (binop, [|c1; c2|]) + when safe_pf_conv_x gl c + (mkApp (th.th_plus, [|c1; mkApp(unbox th.th_opp, [|c2|])|])) -> + mkLApp(coq_Pplus, + [|th.th_a; aux c1; + mkLApp(coq_Popp, [|th.th_a; aux c2|]) |]) + | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) -> + mkLApp(coq_Popp, [|th.th_a; aux c1|]) + | _ when closed_under th.th_closed c -> + mkLApp(coq_Pconst, [|th.th_a; c |]) + | _ -> + try Hashtbl.find varhash c + with Not_found -> + let newvar = + mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + in + let lp = List.map aux lc in + let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in + List.map + (fun p -> + (mkLApp(coq_interp_p, + [| th.th_a; th.th_plus; th.th_mult; th.th_zero; + (unbox th.th_opp); v; p |])), + mkLApp(coq_interp_cs, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; + pf_reduce cbv_betadeltaiota gl + (mkLApp(coq_polynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; + (unbox th.th_opp); th.th_eq; p |])) |]), + mkLApp(coq_polynomial_simplify_ok, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + (unbox th.th_opp); th.th_eq; v; th.th_t; p |])) + lp + +(* + gl : goal sigma + th : semi-ring theory (abstract) + cl : constr list [c1; c2; ...] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + where c'i is convertible with ci and + c'i_eq_c''i is a proof of equality of c'i and c''i + +*) + +let build_aspolynom gl th lc = + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + (* aux creates the aspolynom p by a recursive destructuration of c + and builds the varmap with side-effects *) + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> + mkLApp(coq_ASPplus, [| aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> + mkLApp(coq_ASPmult, [| aux c1; aux c2 |]) + | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0 + | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1 + | _ -> + try Hashtbl.find varhash c + with Not_found -> + let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + in + let lp = List.map aux lc in + let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in + List.map + (fun p -> + (mkLApp(coq_interp_asp, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; v; p |]), + mkLApp(coq_interp_acs, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; v; + pf_reduce cbv_betadeltaiota gl + (mkLApp(coq_aspolynomial_normalize,[|p|])) |]), + mkLApp(coq_spolynomial_simplify_ok, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + th.th_eq; v; th.th_t; p |]))) + lp + +(* + gl : goal sigma + th : ring theory (abstract) + cl : constr list [c1; c2; ...] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + where c'i is convertible with ci and + c'i_eq_c''i is a proof of equality of c'i and c''i + +*) + +let build_apolynom gl th lc = + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> + mkLApp(coq_APplus, [| aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> + mkLApp(coq_APmult, [| aux c1; aux c2 |]) + (* The special case of Zminus *) + | App (binop, [|c1; c2|]) + when safe_pf_conv_x gl c + (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) -> + mkLApp(coq_APplus, + [|aux c1; mkLApp(coq_APopp,[|aux c2|]) |]) + | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) -> + mkLApp(coq_APopp, [| aux c1 |]) + | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0 + | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1 + | _ -> + try Hashtbl.find varhash c + with Not_found -> + let newvar = + mkLApp(coq_APvar, [| path_of_int !counter |]) in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + in + let lp = List.map aux lc in + let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in + List.map + (fun p -> + (mkLApp(coq_interp_ap, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; + th.th_zero; (unbox th.th_opp); v; p |]), + mkLApp(coq_interp_sacs, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; (unbox th.th_opp); v; + pf_reduce cbv_betadeltaiota gl + (mkLApp(coq_apolynomial_normalize, [|p|])) |]), + mkLApp(coq_apolynomial_normalize_ok, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))) + lp + +(* + gl : goal sigma + th : setoid ring theory (concrete) + cl : constr list [c1; c2; ...] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + where c'i is convertible with ci and + c'i_eq_c''i is a proof of equality of c'i and c''i + +*) + +let build_setpolynom gl th lc = + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> + mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> + mkLApp(coq_SetPmult, [|th.th_a; aux c1; aux c2 |]) + (* The special case of Zminus *) + | App (binop, [|c1; c2|]) + when safe_pf_conv_x gl c + (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|])|])) -> + mkLApp(coq_SetPplus, + [| th.th_a; aux c1; + mkLApp(coq_SetPopp, [|th.th_a; aux c2|]) |]) + | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) -> + mkLApp(coq_SetPopp, [| th.th_a; aux c1 |]) + | _ when closed_under th.th_closed c -> + mkLApp(coq_SetPconst, [| th.th_a; c |]) + | _ -> + try Hashtbl.find varhash c + with Not_found -> + let newvar = + mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + in + let lp = List.map aux lc in + let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in + List.map + (fun p -> + (mkLApp(coq_interp_setp, + [| th.th_a; th.th_plus; th.th_mult; th.th_zero; + (unbox th.th_opp); v; p |]), + mkLApp(coq_interp_setcs, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; + pf_reduce cbv_betadeltaiota gl + (mkLApp(coq_setpolynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; + (unbox th.th_opp); th.th_eq; p |])) |]), + mkLApp(coq_setpolynomial_simplify_ok, + [| th.th_a; (unbox th.th_equiv); th.th_plus; + th.th_mult; th.th_one; th.th_zero;(unbox th.th_opp); + th.th_eq; (unbox th.th_setoid_th); + (unbox th.th_morph).plusm; (unbox th.th_morph).multm; + (unbox (unbox th.th_morph).oppm); v; th.th_t; p |]))) + lp + +(* + gl : goal sigma + th : semi setoid ring theory (concrete) + cl : constr list [c1; c2; ...] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + where c'i is convertible with ci and + c'i_eq_c''i is a proof of equality of c'i and c''i + +*) + +let build_setspolynom gl th lc = + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> + mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> + mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |]) + | _ when closed_under th.th_closed c -> + mkLApp(coq_SetSPconst, [| th.th_a; c |]) + | _ -> + try Hashtbl.find varhash c + with Not_found -> + let newvar = + mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + in + let lp = List.map aux lc in + let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in + List.map + (fun p -> + (mkLApp(coq_interp_setsp, + [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), + mkLApp(coq_interp_setcs, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; + pf_reduce cbv_betadeltaiota gl + (mkLApp(coq_setspolynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; + th.th_eq; p |])) |]), + mkLApp(coq_setspolynomial_simplify_ok, + [| th.th_a; (unbox th.th_equiv); th.th_plus; + th.th_mult; th.th_one; th.th_zero; th.th_eq; + (unbox th.th_setoid_th); + (unbox th.th_morph).plusm; + (unbox th.th_morph).multm; v; th.th_t; p |]))) + lp + +module SectionPathSet = + Set.Make(struct + type t = full_path + let compare = Pervasives.compare + end) + +(* Avec l'uniformisation des red_kind, on perd ici sur la structure + SectionPathSet; peut-être faudra-t-il la déplacer dans Closure *) +let constants_to_unfold = +(* List.fold_right SectionPathSet.add *) + let transform s = + let sp = path_of_string s in + let dir, id = repr_path sp in + Libnames.encode_con dir id + in + List.map transform + [ "Coq.ring.Ring_normalize.interp_cs"; + "Coq.ring.Ring_normalize.interp_var"; + "Coq.ring.Ring_normalize.interp_vl"; + "Coq.ring.Ring_abstract.interp_acs"; + "Coq.ring.Ring_abstract.interp_sacs"; + "Coq.quote.Quote.varmap_find"; + (* anciennement des Local devenus Definition *) + "Coq.ring.Ring_normalize.ics_aux"; + "Coq.ring.Ring_normalize.ivl_aux"; + "Coq.ring.Ring_normalize.interp_m"; + "Coq.ring.Ring_abstract.iacs_aux"; + "Coq.ring.Ring_abstract.isacs_aux"; + "Coq.ring.Setoid_ring_normalize.interp_cs"; + "Coq.ring.Setoid_ring_normalize.interp_var"; + "Coq.ring.Setoid_ring_normalize.interp_vl"; + "Coq.ring.Setoid_ring_normalize.ics_aux"; + "Coq.ring.Setoid_ring_normalize.ivl_aux"; + "Coq.ring.Setoid_ring_normalize.interp_m"; + ] +(* SectionPathSet.empty *) + +(* Unfolds the functions interp and find_btree in the term c of goal gl *) +open RedFlags +let polynom_unfold_tac = + let flags = + (mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in + reduct_in_concl (cbv_norm_flags flags,DEFAULTcast) + +let polynom_unfold_tac_in_term gl = + let flags = + (mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold))) + in + cbv_norm_flags flags (pf_env gl) (project gl) + +(* lc : constr list *) +(* th : theory associated to t *) +(* op : clause (None for conclusion or Some id for hypothesis id) *) +(* gl : goal *) +(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i)) + where the ring R, the Ring theory RC, the varmap v and the polynomials p_i + are guessed and such that c_i = (interp R RC v p_i) *) +let raw_polynom th op lc gl = + (* first we sort the terms : if t' is a subterm of t it must appear + after t in the list. This is to avoid that the normalization of t' + modifies t in a non-desired way *) + let lc = sort_subterm gl lc in + let ltriplets = + if th.th_setoid then + if th.th_ring + then build_setpolynom gl th lc + else build_setspolynom gl th lc + else + if th.th_ring then + if th.th_abstract + then build_apolynom gl th lc + else build_polynom gl th lc + else + if th.th_abstract + then build_aspolynom gl th lc + else build_spolynom gl th lc in + let polynom_tac = + List.fold_right2 + (fun ci (c'i, c''i, c'i_eq_c''i) tac -> + let c'''i = + if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i + in + if !term_quality && safe_pf_conv_x gl c'''i ci then + tac (* convertible terms *) + else if th.th_setoid + then + (tclORELSE + (tclORELSE + (h_exact c'i_eq_c''i) + (h_exact (mkLApp(coq_seq_sym, + [| th.th_a; (unbox th.th_equiv); + (unbox th.th_setoid_th); + c'''i; ci; c'i_eq_c''i |])))) + (tclTHENS + (tclORELSE + (Equality.general_rewrite true + Termops.all_occurrences false c'i_eq_c''i) + (Equality.general_rewrite false + Termops.all_occurrences false c'i_eq_c''i)) + [tac])) + else + (tclORELSE + (tclORELSE + (h_exact c'i_eq_c''i) + (h_exact (mkApp(build_coq_eq_sym (), + [|th.th_a; c'''i; ci; c'i_eq_c''i |])))) + (tclTHENS + (elim_type + (mkApp(build_coq_eq (), [|th.th_a; c'''i; ci |]))) + [ tac; + h_exact c'i_eq_c''i ])) +) + lc ltriplets polynom_unfold_tac + in + polynom_tac gl + +let guess_eq_tac th = + (tclORELSE reflexivity + (tclTHEN + polynom_unfold_tac + (tclTHEN + (* Normalized sums associate on the right *) + (tclREPEAT + (tclTHENFIRST + (apply (mkApp(build_coq_f_equal2 (), + [| th.th_a; th.th_a; th.th_a; + th.th_plus |]))) + reflexivity)) + (tclTRY + (tclTHENLAST + (apply (mkApp(build_coq_f_equal2 (), + [| th.th_a; th.th_a; th.th_a; + th.th_plus |]))) + reflexivity))))) + +let guess_equiv_tac th = + (tclORELSE (apply (mkLApp(coq_seq_refl, + [| th.th_a; (unbox th.th_equiv); + (unbox th.th_setoid_th)|]))) + (tclTHEN + polynom_unfold_tac + (tclREPEAT + (tclORELSE + (apply (unbox th.th_morph).plusm) + (apply (unbox th.th_morph).multm))))) + +let match_with_equiv c = match (kind_of_term c) with + | App (e,a) -> + if (List.mem e []) (* (Setoid_replace.equiv_list ())) *) + then Some (decompose_app c) + else None + | _ -> None + +let polynom lc gl = + Coqlib.check_required_library ["Coq";"ring";"LegacyRing"]; + match lc with + (* If no argument is given, try to recognize either an equality or + a declared relation with arguments c1 ... cn, + do "Ring c1 c2 ... cn" and then try to apply the simplification + theorems declared for the relation *) + | [] -> + (try + match Hipattern.match_with_equation (pf_concl gl) with + | _,_,Hipattern.PolymorphicLeibnizEq (t,c1,c2) -> + let th = guess_theory t in + (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl + | _,_,Hipattern.HeterogenousEq (t1,c1,t2,c2) + when safe_pf_conv_x gl t1 t2 -> + let th = guess_theory t1 in + (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl + | _ -> raise Exit + with Hipattern.NoEquationFound | Exit -> + (match match_with_equiv (pf_concl gl) with + | Some (equiv, c1::args) -> + let t = (pf_type_of gl c1) in + let th = (guess_theory t) in + if List.exists + (fun c2 -> not (safe_pf_conv_x gl t (pf_type_of gl c2))) args + then + errorlabstrm "Ring :" + (str" All terms must have the same type"); + (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl + | _ -> errorlabstrm "polynom :" + (str" This goal is not an equality nor a setoid equivalence"))) + (* Elsewhere, guess the theory, check that all terms have the same type + and apply raw_polynom *) + | c :: lc' -> + let t = pf_type_of gl c in + let th = guess_theory t in + if List.exists + (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) lc' + then + errorlabstrm "Ring :" + (str" All terms must have the same type"); + (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl diff --git a/plugins/ring/ring_plugin.mllib b/plugins/ring/ring_plugin.mllib new file mode 100644 index 00000000..3c5f995f --- /dev/null +++ b/plugins/ring/ring_plugin.mllib @@ -0,0 +1,3 @@ +Ring +G_ring +Ring_plugin_mod diff --git a/plugins/ring/vo.itarget b/plugins/ring/vo.itarget new file mode 100644 index 00000000..da387be8 --- /dev/null +++ b/plugins/ring/vo.itarget @@ -0,0 +1,10 @@ +LegacyArithRing.vo +LegacyNArithRing.vo +LegacyRing_theory.vo +LegacyRing.vo +LegacyZArithRing.vo +Ring_abstract.vo +Ring_normalize.vo +Setoid_ring_normalize.vo +Setoid_ring_theory.vo +Setoid_ring.vo diff --git a/plugins/romega/README b/plugins/romega/README new file mode 100644 index 00000000..86c9e58a --- /dev/null +++ b/plugins/romega/README @@ -0,0 +1,6 @@ +This work was done for the RNRT Project Calife. +As such it is distributed under the LGPL licence. + +Report bugs to : + pierre.cregut@francetelecom.com + diff --git a/plugins/romega/ROmega.v b/plugins/romega/ROmega.v new file mode 100644 index 00000000..3ddb6bed --- /dev/null +++ b/plugins/romega/ROmega.v @@ -0,0 +1,14 @@ +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence : LGPL version 2.1 + + *************************************************************************) + +Require Import ReflOmegaCore. +Require Export Setoid. +Require Export PreOmega. +Require Export ZArith_base. +Require Import OmegaPlugin. +Declare ML Module "romega_plugin". \ No newline at end of file diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v new file mode 100644 index 00000000..c82abfc8 --- /dev/null +++ b/plugins/romega/ReflOmegaCore.v @@ -0,0 +1,3216 @@ +(* -*- coding: utf-8 -*- *) +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence du projet : LGPL version 2.1 + + *************************************************************************) + +Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable ZArith_base. +Delimit Scope Int_scope with I. + +(* Abstract Integers. *) + +Module Type Int. + + Parameter int : Set. + + Parameter zero : int. + Parameter one : int. + Parameter plus : int -> int -> int. + Parameter opp : int -> int. + Parameter minus : int -> int -> int. + Parameter mult : int -> int -> int. + + Notation "0" := zero : Int_scope. + Notation "1" := one : Int_scope. + Infix "+" := plus : Int_scope. + Infix "-" := minus : Int_scope. + Infix "*" := mult : Int_scope. + Notation "- x" := (opp x) : Int_scope. + + Open Scope Int_scope. + + (* First, int is a ring: *) + Axiom ring : @ring_theory int 0 1 plus mult minus opp (@eq int). + + (* int should also be ordered: *) + + Parameter le : int -> int -> Prop. + Parameter lt : int -> int -> Prop. + Parameter ge : int -> int -> Prop. + Parameter gt : int -> int -> Prop. + Notation "x <= y" := (le x y): Int_scope. + Notation "x < y" := (lt x y) : Int_scope. + Notation "x >= y" := (ge x y) : Int_scope. + Notation "x > y" := (gt x y): Int_scope. + Axiom le_lt_iff : forall i j, (i<=j) <-> ~(j=j) <-> (j<=i). + Axiom gt_lt_iff : forall i j, (i>j) <-> (j j i i<>j. + + (* Compatibilities *) + Axiom lt_0_1 : 0<1. + Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l. + Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i). + Axiom mult_lt_compat_l : + forall i j k, 0 < k -> i < j -> k*i int -> comparison. + Infix "?=" := compare (at level 70, no associativity) : Int_scope. + Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. + Axiom compare_Lt : forall i j, compare i j = Lt <-> i i>j. + + (* Up to here, these requirements could be fulfilled + by any totally ordered ring. Let's now be int-specific: *) + Axiom le_lt_int : forall x y, x x<=y+-(1). + + (* Btw, lt_0_1 could be deduced from this last axiom *) + +End Int. + + + +(* Of course, Z is a model for our abstract int *) + +Module Z_as_Int <: Int. + + Open Scope Z_scope. + + Definition int := Z. + Definition zero := 0. + Definition one := 1. + Definition plus := Zplus. + Definition opp := Zopp. + Definition minus := Zminus. + Definition mult := Zmult. + + Lemma ring : @ring_theory int zero one plus mult minus opp (@eq int). + Proof. + constructor. + exact Zplus_0_l. + exact Zplus_comm. + exact Zplus_assoc. + exact Zmult_1_l. + exact Zmult_comm. + exact Zmult_assoc. + exact Zmult_plus_distr_l. + unfold minus, Zminus; auto. + exact Zplus_opp_r. + Qed. + + Definition le := Zle. + Definition lt := Zlt. + Definition ge := Zge. + Definition gt := Zgt. + Lemma le_lt_iff : forall i j, (i<=j) <-> ~(j (-j)<=(-i). + Proof. + unfold Zle; intros; rewrite <- Zcompare_opp; auto. + Qed. + + Definition compare := Zcompare. + Definition compare_Eq := Zcompare_Eq_iff_eq. + Lemma compare_Lt : forall i j, compare i j = Lt <-> i i>j. + Proof. intros; unfold compare, Zgt; intuition. Qed. + + Lemma le_lt_int : forall x y, x x<=y+-(1). + Proof. + intros; split; intros. + generalize (Zlt_left _ _ H); simpl; intros. + apply Zle_left_rev; auto. + apply Zlt_0_minus_lt. + generalize (Zplus_le_lt_compat x (y+-1) (-x) (-x+1) H). + rewrite Zplus_opp_r. + rewrite <-Zplus_assoc. + rewrite (Zplus_permute (-1)). + simpl in *. + rewrite Zplus_0_r. + intro H'; apply H'. + replace (-x+1) with (Zsucc (-x)); auto. + apply Zlt_succ. + Qed. + +End Z_as_Int. + + + + +Module IntProperties (I:Int). + Import I. + + (* Primo, some consequences of being a ring theory... *) + + Definition two := 1+1. + Notation "2" := two : Int_scope. + + (* Aliases for properties packed in the ring record. *) + + Definition plus_assoc := ring.(Radd_assoc). + Definition plus_comm := ring.(Radd_comm). + Definition plus_0_l := ring.(Radd_0_l). + Definition mult_assoc := ring.(Rmul_assoc). + Definition mult_comm := ring.(Rmul_comm). + Definition mult_1_l := ring.(Rmul_1_l). + Definition mult_plus_distr_r := ring.(Rdistr_l). + Definition opp_def := ring.(Ropp_def). + Definition minus_def := ring.(Rsub_def). + + Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l + mult_plus_distr_r opp_def minus_def. + + (* More facts about plus *) + + Lemma plus_0_r : forall x, x+0 = x. + Proof. intros; rewrite plus_comm; apply plus_0_l. Qed. + + Lemma plus_0_r_reverse : forall x, x = x+0. + Proof. intros; symmetry; apply plus_0_r. Qed. + + Lemma plus_assoc_reverse : forall x y z, x+y+z = x+(y+z). + Proof. intros; symmetry; apply plus_assoc. Qed. + + Lemma plus_permute : forall x y z, x+(y+z) = y+(x+z). + Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed. + + Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z. + Proof. + intros. + rewrite (plus_0_r_reverse y), (plus_0_r_reverse z), <-(opp_def x). + now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. + Qed. + + (* More facts about mult *) + + Lemma mult_assoc_reverse : forall x y z, x*y*z = x*(y*z). + Proof. intros; symmetry; apply mult_assoc. Qed. + + Lemma mult_plus_distr_l : forall x y z, x*(y+z)=x*y+x*z. + Proof. + intros. + rewrite (mult_comm x (y+z)), (mult_comm x y), (mult_comm x z). + apply mult_plus_distr_r. + Qed. + + Lemma mult_0_l : forall x, 0*x = 0. + Proof. + intros. + generalize (mult_plus_distr_r 0 1 x). + rewrite plus_0_l, mult_1_l, plus_comm; intros. + apply plus_reg_l with x. + rewrite <- H. + apply plus_0_r_reverse. + Qed. + + + (* More facts about opp *) + + Definition plus_opp_r := opp_def. + + Lemma plus_opp_l : forall x, -x + x = 0. + Proof. intros; now rewrite plus_comm, opp_def. Qed. + + Lemma mult_opp_comm : forall x y, - x * y = x * - y. + Proof. + intros. + apply plus_reg_l with (x*y). + rewrite <- mult_plus_distr_l, <- mult_plus_distr_r. + now rewrite opp_def, opp_def, mult_0_l, mult_comm, mult_0_l. + Qed. + + Lemma opp_eq_mult_neg_1 : forall x, -x = x * -(1). + Proof. + intros; now rewrite mult_comm, mult_opp_comm, mult_1_l. + Qed. + + Lemma opp_involutive : forall x, -(-x) = x. + Proof. + intros. + apply plus_reg_l with (-x). + now rewrite opp_def, plus_comm, opp_def. + Qed. + + Lemma opp_plus_distr : forall x y, -(x+y) = -x + -y. + Proof. + intros. + apply plus_reg_l with (x+y). + rewrite opp_def. + rewrite plus_permute. + do 2 rewrite plus_assoc. + now rewrite (plus_comm (-x)), opp_def, plus_0_l, opp_def. + Qed. + + Lemma opp_mult_distr_r : forall x y, -(x*y) = x * -y. + Proof. + intros. + rewrite <- mult_opp_comm. + apply plus_reg_l with (x*y). + now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l. + Qed. + + Lemma egal_left : forall n m, n=m -> n+-m = 0. + Proof. intros; subst; apply opp_def. Qed. + + Lemma ne_left_2 : forall x y : int, x<>y -> 0<>(x + - y). + Proof. + intros; contradict H. + apply (plus_reg_l (-y)). + now rewrite plus_opp_l, plus_comm, H. + Qed. + + (* Special lemmas for factorisation. *) + + Lemma red_factor0 : forall n, n = n*1. + Proof. symmetry; rewrite mult_comm; apply mult_1_l. Qed. + + Lemma red_factor1 : forall n, n+n = n*2. + Proof. + intros; unfold two. + now rewrite mult_comm, mult_plus_distr_r, mult_1_l. + Qed. + + Lemma red_factor2 : forall n m, n + n*m = n * (1+m). + Proof. + intros; rewrite mult_plus_distr_l. + f_equal; now rewrite mult_comm, mult_1_l. + Qed. + + Lemma red_factor3 : forall n m, n*m + n = n*(1+m). + Proof. intros; now rewrite plus_comm, red_factor2. Qed. + + Lemma red_factor4 : forall n m p, n*m + n*p = n*(m+p). + Proof. + intros; now rewrite mult_plus_distr_l. + Qed. + + Lemma red_factor5 : forall n m , n * 0 + m = m. + Proof. intros; now rewrite mult_comm, mult_0_l, plus_0_l. Qed. + + Definition red_factor6 := plus_0_r_reverse. + + + (* Specialized distributivities *) + + Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int. + Hint Rewrite <- plus_assoc : int. + + Lemma OMEGA10 : + forall v c1 c2 l1 l2 k1 k2 : int, + (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = + v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). + Proof. + intros; autorewrite with int; f_equal; now rewrite plus_permute. + Qed. + + Lemma OMEGA11 : + forall v1 c1 l1 l2 k1 : int, + (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). + Proof. + intros; now autorewrite with int. + Qed. + + Lemma OMEGA12 : + forall v2 c2 l1 l2 k2 : int, + l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). + Proof. + intros; autorewrite with int; now rewrite plus_permute. + Qed. + + Lemma OMEGA13 : + forall v l1 l2 x : int, + v * -x + l1 + (v * x + l2) = l1 + l2. + Proof. + intros; autorewrite with int. + rewrite plus_permute; f_equal. + rewrite plus_assoc. + now rewrite <- mult_plus_distr_l, plus_opp_l, mult_comm, mult_0_l, plus_0_l. + Qed. + + Lemma OMEGA15 : + forall v c1 c2 l1 l2 k2 : int, + v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). + Proof. + intros; autorewrite with int; f_equal; now rewrite plus_permute. + Qed. + + Lemma OMEGA16 : forall v c l k : int, (v * c + l) * k = v * (c * k) + l * k. + Proof. + intros; now autorewrite with int. + Qed. + + Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d. + Proof. + intros; elim H; elim H0; simpl in |- *; auto. + now rewrite mult_0_l, mult_0_l, plus_0_l. + Qed. + + + (* Secondo, some results about order (and equality) *) + + Lemma lt_irrefl : forall n, ~ n m False. + Proof. + intros; elim (lt_irrefl _ (lt_trans _ _ _ H H0)); auto. + Qed. + + Lemma lt_le_weak : forall n m, n n<=m. + Proof. + intros; rewrite le_lt_iff; intro H'; eapply lt_antisym; eauto. + Qed. + + Lemma le_refl : forall n, n<=n. + Proof. + intros; rewrite le_lt_iff; apply lt_irrefl; auto. + Qed. + + Lemma le_antisym : forall n m, n<=m -> m<=n -> n=m. + Proof. + intros n m; do 2 rewrite le_lt_iff; intros. + rewrite <- compare_Lt in H0. + rewrite <- gt_lt_iff, <- compare_Gt in H. + rewrite <- compare_Eq. + destruct compare; intuition. + Qed. + + Lemma lt_eq_lt_dec : forall n m, { n ~(m<=n). + Proof. + intros. + rewrite le_lt_iff. + destruct (lt_dec n m); intuition. + Qed. + + Lemma le_dec : forall n m: int, { n<=m } + { ~n<=m }. + Proof. + intros; destruct (lt_dec m n); [right|left]; rewrite le_lt_iff; intuition. + Qed. + + Lemma le_lt_dec : forall n m, { n<=m } + { m true | _ => false end. + + Lemma beq_iff : forall i j, beq i j = true <-> i=j. + Proof. + intros; unfold beq; generalize (compare_Eq i j). + destruct compare; intuition discriminate. + Qed. + + Lemma beq_true : forall i j, beq i j = true -> i=j. + Proof. + intros. + rewrite <- beq_iff; auto. + Qed. + + Lemma beq_false : forall i j, beq i j = false -> i<>j. + Proof. + intros. + intro H'. + rewrite <- beq_iff in H'; rewrite H' in H; discriminate. + Qed. + + Lemma eq_dec : forall n m:int, { n=m } + { n<>m }. + Proof. + intros; generalize (beq_iff n m); destruct beq; [left|right]; intuition. + Qed. + + Definition bgt i j := match compare i j with Gt => true | _ => false end. + + Lemma bgt_iff : forall i j, bgt i j = true <-> i>j. + Proof. + intros; unfold bgt; generalize (compare_Gt i j). + destruct compare; intuition discriminate. + Qed. + + Lemma bgt_true : forall i j, bgt i j = true -> i>j. + Proof. intros; now rewrite <- bgt_iff. Qed. + + Lemma bgt_false : forall i j, bgt i j = false -> i<=j. + Proof. + intros. + rewrite le_lt_iff, <-gt_lt_iff, <-bgt_iff; intro H'; now rewrite H' in H. + Qed. + + Lemma le_is_lt_or_eq : forall n m, n<=m -> { n n<>m -> n m<=p -> n<=p. + Proof. + intros n m p; do 3 rewrite le_lt_iff; intros A B C. + destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto. + generalize (lt_trans _ _ _ H C); intuition. + Qed. + + (* order and operations *) + + Lemma le_0_neg : forall n, 0 <= n <-> -n <= 0. + Proof. + intros. + pattern 0 at 2; rewrite <- (mult_0_l (-(1))). + rewrite <- opp_eq_mult_neg_1. + split; intros. + apply opp_le_compat; auto. + rewrite <-(opp_involutive 0), <-(opp_involutive n). + apply opp_le_compat; auto. + Qed. + + Lemma le_0_neg' : forall n, n <= 0 <-> 0 <= -n. + Proof. + intros; rewrite le_0_neg, opp_involutive; intuition. + Qed. + + Lemma plus_le_reg_r : forall n m p, n + p <= m + p -> n <= m. + Proof. + intros. + replace n with ((n+p)+-p). + replace m with ((m+p)+-p). + apply plus_le_compat; auto. + apply le_refl. + now rewrite <- plus_assoc, opp_def, plus_0_r. + now rewrite <- plus_assoc, opp_def, plus_0_r. + Qed. + + Lemma plus_le_lt_compat : forall n m p q, n<=m -> p n+p p n+p -m < -n. + Proof. + intros n m; do 2 rewrite lt_le_iff; intros H; contradict H. + rewrite <-(opp_involutive m), <-(opp_involutive n). + apply opp_le_compat; auto. + Qed. + + Lemma lt_0_neg : forall n, 0 < n <-> -n < 0. + Proof. + intros. + pattern 0 at 2; rewrite <- (mult_0_l (-(1))). + rewrite <- opp_eq_mult_neg_1. + split; intros. + apply opp_lt_compat; auto. + rewrite <-(opp_involutive 0), <-(opp_involutive n). + apply opp_lt_compat; auto. + Qed. + + Lemma lt_0_neg' : forall n, n < 0 <-> 0 < -n. + Proof. + intros; rewrite lt_0_neg, opp_involutive; intuition. + Qed. + + Lemma mult_lt_0_compat : forall n m, 0 < n -> 0 < m -> 0 < n*m. + Proof. + intros. + rewrite <- (mult_0_l n), mult_comm. + apply mult_lt_compat_l; auto. + Qed. + + Lemma mult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0. + Proof. + intros. + destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto; + destruct (lt_eq_lt_dec m 0) as [[Hm|Hm]|Hm]; auto; exfalso. + + rewrite lt_0_neg' in Hn. + rewrite lt_0_neg' in Hm. + generalize (mult_lt_0_compat _ _ Hn Hm). + rewrite <- opp_mult_distr_r, mult_comm, <- opp_mult_distr_r, opp_involutive. + rewrite mult_comm, H. + exact (lt_irrefl 0). + + rewrite lt_0_neg' in Hn. + generalize (mult_lt_0_compat _ _ Hn Hm). + rewrite mult_comm, <- opp_mult_distr_r, mult_comm. + rewrite H. + rewrite opp_eq_mult_neg_1, mult_0_l. + exact (lt_irrefl 0). + + rewrite lt_0_neg' in Hm. + generalize (mult_lt_0_compat _ _ Hn Hm). + rewrite <- opp_mult_distr_r. + rewrite H. + rewrite opp_eq_mult_neg_1, mult_0_l. + exact (lt_irrefl 0). + + generalize (mult_lt_0_compat _ _ Hn Hm). + rewrite H. + exact (lt_irrefl 0). + Qed. + + Lemma mult_le_compat : + forall i j k l, i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. + Proof. + intros. + destruct (le_is_lt_or_eq _ _ H1). + + apply le_trans with (i*l). + destruct (le_is_lt_or_eq _ _ H0); [ | subst; apply le_refl]. + apply lt_le_weak. + apply mult_lt_compat_l; auto. + + generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. + rewrite (mult_comm i), (mult_comm j). + destruct (le_is_lt_or_eq _ _ H0); + [ | subst; do 2 rewrite mult_0_l; apply le_refl]. + destruct (le_is_lt_or_eq _ _ H); + [ | subst; apply le_refl]. + apply lt_le_weak. + apply mult_lt_compat_l; auto. + + subst i. + rewrite mult_0_l. + generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. + destruct (le_is_lt_or_eq _ _ H); + [ | subst; rewrite mult_0_l; apply le_refl]. + destruct (le_is_lt_or_eq _ _ H0); + [ | subst; rewrite mult_comm, mult_0_l; apply le_refl]. + apply lt_le_weak. + apply mult_lt_0_compat; auto. + Qed. + + Lemma sum5 : + forall a b c d : int, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. + Proof. + intros. + subst b; rewrite mult_0_l, plus_0_r. + contradict H. + symmetry in H; destruct (mult_integral _ _ H); congruence. + Qed. + + Lemma one_neq_zero : 1 <> 0. + Proof. + red; intro. + symmetry in H. + apply (lt_not_eq 0 1); auto. + apply lt_0_1. + Qed. + + Lemma minus_one_neq_zero : -(1) <> 0. + Proof. + apply lt_not_eq. + rewrite <- lt_0_neg. + apply lt_0_1. + Qed. + + Lemma le_left : forall n m, n <= m -> 0 <= m + - n. + Proof. + intros. + rewrite <- (opp_def m). + apply plus_le_compat. + apply le_refl. + apply opp_le_compat; auto. + Qed. + + Lemma OMEGA2 : forall x y, 0 <= x -> 0 <= y -> 0 <= x + y. + Proof. + intros. + replace 0 with (0+0). + apply plus_le_compat; auto. + rewrite plus_0_l; auto. + Qed. + + Lemma OMEGA8 : forall x y, 0 <= x -> 0 <= y -> x = - y -> x = 0. + Proof. + intros. + assert (y=-x). + subst x; symmetry; apply opp_involutive. + clear H1; subst y. + destruct (eq_dec 0 x) as [H'|H']; auto. + assert (H'':=le_neq_lt _ _ H H'). + generalize (plus_le_lt_compat _ _ _ _ H0 H''). + rewrite plus_opp_l, plus_0_l. + intros. + elim (lt_not_eq _ _ H1); auto. + Qed. + + Lemma sum2 : + forall a b c d : int, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. + Proof. + intros. + subst a; rewrite mult_0_l, plus_0_l. + rewrite <- (mult_0_l 0). + apply mult_le_compat; auto; apply le_refl. + Qed. + + Lemma sum3 : + forall a b c d : int, + 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d. + Proof. + intros. + rewrite <- (plus_0_l 0). + apply plus_le_compat; auto. + rewrite <- (mult_0_l 0). + apply mult_le_compat; auto; apply le_refl. + rewrite <- (mult_0_l 0). + apply mult_le_compat; auto; apply le_refl. + Qed. + + Lemma sum4 : forall k : int, k>0 -> 0 <= k. + Proof. + intros k; rewrite gt_lt_iff; apply lt_le_weak. + Qed. + + (* Lemmas specific to integers (they use lt_le_int) *) + + Lemma lt_left : forall n m, n < m -> 0 <= m + -(1) + - n. + Proof. + intros; apply le_left. + now rewrite <- le_lt_int. + Qed. + + Lemma lt_left_inv : forall x y, 0 <= y + -(1) + - x -> x < y. + Proof. + intros. + generalize (plus_le_compat _ _ _ _ H (le_refl x)); clear H. + now rewrite plus_0_l, <-plus_assoc, plus_opp_l, plus_0_r, le_lt_int. + Qed. + + Lemma OMEGA4 : forall x y z, x > 0 -> y > x -> z * y + x <> 0. + Proof. + intros. + intro H'. + rewrite gt_lt_iff in H,H0. + destruct (lt_eq_lt_dec z 0) as [[G|G]|G]. + + rewrite lt_0_neg' in G. + generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). + rewrite H'. + pattern y at 2; rewrite <-(mult_1_l y), <-mult_plus_distr_r. + intros. + rewrite le_lt_int in G. + rewrite <- opp_plus_distr in G. + assert (0 < y) by (apply lt_trans with x; auto). + generalize (mult_le_compat _ _ _ _ G (lt_le_weak _ _ H2) (le_refl 0) (le_refl 0)). + rewrite mult_0_l, mult_comm, <- opp_mult_distr_r, mult_comm, <-le_0_neg', le_lt_iff. + intuition. + + subst; rewrite mult_0_l, plus_0_l in H'; subst. + apply (lt_not_eq _ _ H); auto. + + apply (lt_not_eq 0 (z*y+x)); auto. + rewrite <- (plus_0_l 0). + apply plus_lt_compat; auto. + apply mult_lt_0_compat; auto. + apply lt_trans with x; auto. + Qed. + + Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). + Proof. + intros. + do 2 rewrite <- le_lt_int. + rewrite <- opp_eq_mult_neg_1. + destruct (lt_eq_lt_dec 0 x) as [[H'|H']|H']. + auto. + congruence. + right. + rewrite <-(mult_0_l (-(1))), <-(opp_eq_mult_neg_1 0). + apply opp_lt_compat; auto. + Qed. + + Lemma mult_le_approx : + forall n m p, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. + Proof. + intros n m p. + do 2 rewrite gt_lt_iff. + do 2 rewrite le_lt_iff; intros. + contradict H1. + rewrite lt_0_neg' in H1. + rewrite lt_0_neg'. + rewrite opp_plus_distr. + rewrite mult_comm, opp_mult_distr_r. + rewrite le_lt_int. + rewrite <- plus_assoc, (plus_comm (-p)), plus_assoc. + apply lt_left. + rewrite le_lt_int. + rewrite le_lt_int in H0. + apply le_trans with (n+-(1)); auto. + apply plus_le_compat; [ | apply le_refl ]. + rewrite le_lt_int in H1. + generalize (mult_le_compat _ _ _ _ (lt_le_weak _ _ H) H1 (le_refl 0) (le_refl 0)). + rewrite mult_0_l. + rewrite mult_plus_distr_l. + rewrite <- opp_eq_mult_neg_1. + intros. + generalize (plus_le_compat _ _ _ _ (le_refl n) H2). + now rewrite plus_permute, opp_def, plus_0_r, plus_0_r. + Qed. + + (* Some decidabilities *) + + Lemma dec_eq : forall i j:int, decidable (i=j). + Proof. + red; intros; destruct (eq_dec i j); auto. + Qed. + + Lemma dec_ne : forall i j:int, decidable (i<>j). + Proof. + red; intros; destruct (eq_dec i j); auto. + Qed. + + Lemma dec_le : forall i j:int, decidable (i<=j). + Proof. + red; intros; destruct (le_dec i j); auto. + Qed. + + Lemma dec_lt : forall i j:int, decidable (i=j). + Proof. + red; intros; rewrite ge_le_iff; destruct (le_dec j i); auto. + Qed. + + Lemma dec_gt : forall i j:int, decidable (i>j). + Proof. + red; intros; rewrite gt_lt_iff; destruct (lt_dec j i); auto. + Qed. + +End IntProperties. + + + + +Module IntOmega (I:Int). +Import I. +Module IP:=IntProperties(I). +Import IP. + +(* \subsubsection{Definition of reified integer expressions} + Terms are either: + \begin{itemize} + \item integers [Tint] + \item variables [Tvar] + \item operation over integers (addition, product, opposite, subtraction) + The last two are translated in additions and products. *) + +Inductive term : Set := + | Tint : int -> term + | Tplus : term -> term -> term + | Tmult : term -> term -> term + | Tminus : term -> term -> term + | Topp : term -> term + | Tvar : nat -> term. + +Delimit Scope romega_scope with term. +Arguments Scope Tint [Int_scope]. +Arguments Scope Tplus [romega_scope romega_scope]. +Arguments Scope Tmult [romega_scope romega_scope]. +Arguments Scope Tminus [romega_scope romega_scope]. +Arguments Scope Topp [romega_scope romega_scope]. + +Infix "+" := Tplus : romega_scope. +Infix "*" := Tmult : romega_scope. +Infix "-" := Tminus : romega_scope. +Notation "- x" := (Topp x) : romega_scope. +Notation "[ x ]" := (Tvar x) (at level 0) : romega_scope. + +(* \subsubsection{Definition of reified goals} *) + +(* Very restricted definition of handled predicates that should be extended + to cover a wider set of operations. + Taking care of negations and disequations require solving more than a + goal in parallel. This is a major improvement over previous versions. *) + +Inductive proposition : Set := + | EqTerm : term -> term -> proposition (* equality between terms *) + | LeqTerm : term -> term -> proposition (* less or equal on terms *) + | TrueTerm : proposition (* true *) + | FalseTerm : proposition (* false *) + | Tnot : proposition -> proposition (* negation *) + | GeqTerm : term -> term -> proposition + | GtTerm : term -> term -> proposition + | LtTerm : term -> term -> proposition + | NeqTerm : term -> term -> proposition + | Tor : proposition -> proposition -> proposition + | Tand : proposition -> proposition -> proposition + | Timp : proposition -> proposition -> proposition + | Tprop : nat -> proposition. + +(* Definition of goals as a list of hypothesis *) +Notation hyps := (list proposition). + +(* Definition of lists of subgoals (set of open goals) *) +Notation lhyps := (list hyps). + +(* a single goal packed in a subgoal list *) +Notation singleton := (fun a : hyps => a :: nil). + +(* an absurd goal *) +Definition absurd := FalseTerm :: nil. + +(* \subsubsection{Traces for merging equations} + This inductive type describes how the monomial of two equations should be + merged when the equations are added. + + For [F_equal], both equations have the same head variable and coefficient + must be added, furthermore if coefficients are opposite, [F_cancel] should + be used to collapse the term. [F_left] and [F_right] indicate which monomial + should be put first in the result *) + +Inductive t_fusion : Set := + | F_equal : t_fusion + | F_cancel : t_fusion + | F_left : t_fusion + | F_right : t_fusion. + +(* \subsubsection{Rewriting steps to normalize terms} *) +Inductive step : Set := + (* apply the rewriting steps to both subterms of an operation *) + | C_DO_BOTH : step -> step -> step + (* apply the rewriting step to the first branch *) + | C_LEFT : step -> step + (* apply the rewriting step to the second branch *) + | C_RIGHT : step -> step + (* apply two steps consecutively to a term *) + | C_SEQ : step -> step -> step + (* empty step *) + | C_NOP : step + (* the following operations correspond to actual rewriting *) + | C_OPP_PLUS : step + | C_OPP_OPP : step + | C_OPP_MULT_R : step + | C_OPP_ONE : step + (* This is a special step that reduces the term (computation) *) + | C_REDUCE : step + | C_MULT_PLUS_DISTR : step + | C_MULT_OPP_LEFT : step + | C_MULT_ASSOC_R : step + | C_PLUS_ASSOC_R : step + | C_PLUS_ASSOC_L : step + | C_PLUS_PERMUTE : step + | C_PLUS_COMM : step + | C_RED0 : step + | C_RED1 : step + | C_RED2 : step + | C_RED3 : step + | C_RED4 : step + | C_RED5 : step + | C_RED6 : step + | C_MULT_ASSOC_REDUCED : step + | C_MINUS : step + | C_MULT_COMM : step. + +(* \subsubsection{Omega steps} *) +(* The following inductive type describes steps as they can be found in + the trace coming from the decision procedure Omega. *) + +Inductive t_omega : Set := + (* n = 0 and n!= 0 *) + | O_CONSTANT_NOT_NUL : nat -> t_omega + | O_CONSTANT_NEG : nat -> t_omega + (* division and approximation of an equation *) + | O_DIV_APPROX : int -> int -> term -> nat -> t_omega -> nat -> t_omega + (* no solution because no exact division *) + | O_NOT_EXACT_DIVIDE : int -> int -> term -> nat -> nat -> t_omega + (* exact division *) + | O_EXACT_DIVIDE : int -> term -> nat -> t_omega -> nat -> t_omega + | O_SUM : int -> nat -> int -> nat -> list t_fusion -> t_omega -> t_omega + | O_CONTRADICTION : nat -> nat -> nat -> t_omega + | O_MERGE_EQ : nat -> nat -> nat -> t_omega -> t_omega + | O_SPLIT_INEQ : nat -> nat -> t_omega -> t_omega -> t_omega + | O_CONSTANT_NUL : nat -> t_omega + | O_NEGATE_CONTRADICT : nat -> nat -> t_omega + | O_NEGATE_CONTRADICT_INV : nat -> nat -> nat -> t_omega + | O_STATE : int -> step -> nat -> nat -> t_omega -> t_omega. + +(* \subsubsection{Rules for normalizing the hypothesis} *) +(* These rules indicate how to normalize useful propositions + of each useful hypothesis before the decomposition of hypothesis. + The rules include the inversion phase for negation removal. *) + +Inductive p_step : Set := + | P_LEFT : p_step -> p_step + | P_RIGHT : p_step -> p_step + | P_INVERT : step -> p_step + | P_STEP : step -> p_step + | P_NOP : p_step. + +(* List of normalizations to perform : with a constructor of type + [p_step] allowing to visit both left and right branches, we would be + able to restrict to only one normalization by hypothesis. + And since all hypothesis are useful (otherwise they wouldn't be included), + we would be able to replace [h_step] by a simple list. *) + +Inductive h_step : Set := + pair_step : nat -> p_step -> h_step. + +(* \subsubsection{Rules for decomposing the hypothesis} *) +(* This type allows to navigate in the logical constructors that + form the predicats of the hypothesis in order to decompose them. + This allows in particular to extract one hypothesis from a + conjonction with possibly the right level of negations. *) + +Inductive direction : Set := + | D_left : direction + | D_right : direction + | D_mono : direction. + +(* This type allows to extract useful components from hypothesis, either + hypothesis generated by splitting a disjonction, or equations. + The last constructor indicates how to solve the obtained system + via the use of the trace type of Omega [t_omega] *) + +Inductive e_step : Set := + | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step + | E_EXTRACT : nat -> list direction -> e_step -> e_step + | E_SOLVE : t_omega -> e_step. + +(* \subsection{Efficient decidable equality} *) +(* For each reified data-type, we define an efficient equality test. + It is not the one produced by [Decide Equality]. + + Then we prove two theorem allowing to eliminate such equalities : + \begin{verbatim} + (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2. + (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2. + \end{verbatim} *) + +(* \subsubsection{Reified terms} *) + +Open Scope romega_scope. + +Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := + match t1, t2 with + | Tint st1, Tint st2 => beq st1 st2 + | (st11 + st12), (st21 + st22) => eq_term st11 st21 && eq_term st12 st22 + | (st11 * st12), (st21 * st22) => eq_term st11 st21 && eq_term st12 st22 + | (st11 - st12), (st21 - st22) => eq_term st11 st21 && eq_term st12 st22 + | (- st1), (- st2) => eq_term st1 st2 + | [st1], [st2] => beq_nat st1 st2 + | _, _ => false + end. + +Close Scope romega_scope. + +Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2. +Proof. + simple induction t1; intros until t2; case t2; simpl in *; + try (intros; discriminate; fail); + [ intros; elim beq_true with (1 := H); trivial + | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; + elim H with (1 := H4); elim H0 with (1 := H5); + trivial + | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; + elim H with (1 := H4); elim H0 with (1 := H5); + trivial + | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; + elim H with (1 := H4); elim H0 with (1 := H5); + trivial + | intros t21 H3; elim H with (1 := H3); trivial + | intros; elim beq_nat_true with (1 := H); trivial ]. +Qed. + +Ltac trivial_case := unfold not in |- *; intros; discriminate. + +Theorem eq_term_false : + forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2. +Proof. + simple induction t1; + [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; + intros; elim beq_false with (1 := H); simplify_eq H0; + auto + | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; + intros t21 t22 H3; unfold not in |- *; intro H4; + elim andb_false_elim with (1 := H3); intros H5; + [ elim H1 with (1 := H5); simplify_eq H4; auto + | elim H2 with (1 := H5); simplify_eq H4; auto ] + | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; + intros t21 t22 H3; unfold not in |- *; intro H4; + elim andb_false_elim with (1 := H3); intros H5; + [ elim H1 with (1 := H5); simplify_eq H4; auto + | elim H2 with (1 := H5); simplify_eq H4; auto ] + | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; + intros t21 t22 H3; unfold not in |- *; intro H4; + elim andb_false_elim with (1 := H3); intros H5; + [ elim H1 with (1 := H5); simplify_eq H4; auto + | elim H2 with (1 := H5); simplify_eq H4; auto ] + | intros t11 H1 t2; case t2; try trivial_case; simpl in |- *; intros t21 H3; + unfold not in |- *; intro H4; elim H1 with (1 := H3); + simplify_eq H4; auto + | intros n t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; + intros; elim beq_nat_false with (1 := H); simplify_eq H0; + auto ]. +Qed. + +(* \subsubsection{Tactiques pour éliminer ces tests} + + Si on se contente de faire un [Case (eq_typ t1 t2)] on perd + totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2]. + + Initialement, les développements avaient été réalisés avec les + tests rendus par [Decide Equality], c'est à dire un test rendant + des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un + tel test préserve bien l'information voulue mais calculatoirement de + telles fonctions sont trop lentes. *) + +(* Les tactiques définies si après se comportent exactement comme si on + avait utilisé le test précédent et fait une elimination dessus. *) + +Ltac elim_eq_term t1 t2 := + pattern (eq_term t1 t2) in |- *; apply bool_eq_ind; intro Aux; + [ generalize (eq_term_true t1 t2 Aux); clear Aux + | generalize (eq_term_false t1 t2 Aux); clear Aux ]. + +Ltac elim_beq t1 t2 := + pattern (beq t1 t2) in |- *; apply bool_eq_ind; intro Aux; + [ generalize (beq_true t1 t2 Aux); clear Aux + | generalize (beq_false t1 t2 Aux); clear Aux ]. + +Ltac elim_bgt t1 t2 := + pattern (bgt t1 t2) in |- *; apply bool_eq_ind; intro Aux; + [ generalize (bgt_true t1 t2 Aux); clear Aux + | generalize (bgt_false t1 t2 Aux); clear Aux ]. + + +(* \subsection{Interprétations} + \subsubsection{Interprétation des termes dans Z} *) + +Fixpoint interp_term (env : list int) (t : term) {struct t} : int := + match t with + | Tint x => x + | (t1 + t2)%term => interp_term env t1 + interp_term env t2 + | (t1 * t2)%term => interp_term env t1 * interp_term env t2 + | (t1 - t2)%term => interp_term env t1 - interp_term env t2 + | (- t)%term => - interp_term env t + | [n]%term => nth n env 0 + end. + +(* \subsubsection{Interprétation des prédicats} *) + +Fixpoint interp_proposition (envp : list Prop) (env : list int) + (p : proposition) {struct p} : Prop := + match p with + | EqTerm t1 t2 => interp_term env t1 = interp_term env t2 + | LeqTerm t1 t2 => interp_term env t1 <= interp_term env t2 + | TrueTerm => True + | FalseTerm => False + | Tnot p' => ~ interp_proposition envp env p' + | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2 + | GtTerm t1 t2 => interp_term env t1 > interp_term env t2 + | LtTerm t1 t2 => interp_term env t1 < interp_term env t2 + | NeqTerm t1 t2 => (interp_term env t1)<>(interp_term env t2) + | Tor p1 p2 => + interp_proposition envp env p1 \/ interp_proposition envp env p2 + | Tand p1 p2 => + interp_proposition envp env p1 /\ interp_proposition envp env p2 + | Timp p1 p2 => + interp_proposition envp env p1 -> interp_proposition envp env p2 + | Tprop n => nth n envp True + end. + +(* \subsubsection{Inteprétation des listes d'hypothèses} + \paragraph{Sous forme de conjonction} + Interprétation sous forme d'une conjonction d'hypothèses plus faciles + à manipuler individuellement *) + +Fixpoint interp_hyps (envp : list Prop) (env : list int) + (l : hyps) {struct l} : Prop := + match l with + | nil => True + | p' :: l' => interp_proposition envp env p' /\ interp_hyps envp env l' + end. + +(* \paragraph{sous forme de but} + C'est cette interpétation que l'on utilise sur le but (car on utilise + [Generalize] et qu'une conjonction est forcément lourde (répétition des + types dans les conjonctions intermédiaires) *) + +Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) + (env : list int) (l : hyps) {struct l} : Prop := + match l with + | nil => interp_proposition envp env c + | p' :: l' => + interp_proposition envp env p' -> interp_goal_concl c envp env l' + end. + +Notation interp_goal := (interp_goal_concl FalseTerm). + +(* Les théorèmes qui suivent assurent la correspondance entre les deux + interprétations. *) + +Theorem goal_to_hyps : + forall (envp : list Prop) (env : list int) (l : hyps), + (interp_hyps envp env l -> False) -> interp_goal envp env l. +Proof. + simple induction l; + [ simpl in |- *; auto + | simpl in |- *; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ]. +Qed. + +Theorem hyps_to_goal : + forall (envp : list Prop) (env : list int) (l : hyps), + interp_goal envp env l -> interp_hyps envp env l -> False. +Proof. + simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ]. +Qed. + +(* \subsection{Manipulations sur les hypothèses} *) + +(* \subsubsection{Définitions de base de stabilité pour la réflexion} *) +(* Une opération laisse un terme stable si l'égalité est préservée *) +Definition term_stable (f : term -> term) := + forall (e : list int) (t : term), interp_term e t = interp_term e (f t). + +(* Une opération est valide sur une hypothèse, si l'hypothèse implique le + résultat de l'opération. \emph{Attention : cela ne concerne que des + opérations sur les hypothèses et non sur les buts (contravariance)}. + On définit la validité pour une opération prenant une ou deux propositions + en argument (cela suffit pour omega). *) + +Definition valid1 (f : proposition -> proposition) := + forall (ep : list Prop) (e : list int) (p1 : proposition), + interp_proposition ep e p1 -> interp_proposition ep e (f p1). + +Definition valid2 (f : proposition -> proposition -> proposition) := + forall (ep : list Prop) (e : list int) (p1 p2 : proposition), + interp_proposition ep e p1 -> + interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2). + +(* Dans cette notion de validité, la fonction prend directement une + liste de propositions et rend une nouvelle liste de proposition. + On reste contravariant *) + +Definition valid_hyps (f : hyps -> hyps) := + forall (ep : list Prop) (e : list int) (lp : hyps), + interp_hyps ep e lp -> interp_hyps ep e (f lp). + +(* Enfin ce théorème élimine la contravariance et nous ramène à une + opération sur les buts *) + +Theorem valid_goal : + forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps), + valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. +Proof. + intros; simpl in |- *; apply goal_to_hyps; intro H1; + apply (hyps_to_goal ep env (a l) H0); apply H; assumption. +Qed. + +(* \subsubsection{Généralisation a des listes de buts (disjonctions)} *) + + +Fixpoint interp_list_hyps (envp : list Prop) (env : list int) + (l : lhyps) {struct l} : Prop := + match l with + | nil => False + | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l' + end. + +Fixpoint interp_list_goal (envp : list Prop) (env : list int) + (l : lhyps) {struct l} : Prop := + match l with + | nil => True + | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l' + end. + +Theorem list_goal_to_hyps : + forall (envp : list Prop) (env : list int) (l : lhyps), + (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. +Proof. + simple induction l; simpl in |- *; + [ auto + | intros h1 l1 H H1; split; + [ apply goal_to_hyps; intro H2; apply H1; auto + | apply H; intro H2; apply H1; auto ] ]. +Qed. + +Theorem list_hyps_to_goal : + forall (envp : list Prop) (env : list int) (l : lhyps), + interp_list_goal envp env l -> interp_list_hyps envp env l -> False. +Proof. + simple induction l; simpl in |- *; + [ auto + | intros h1 l1 H (H1, H2) H3; elim H3; intro H4; + [ apply hyps_to_goal with (1 := H1); assumption | auto ] ]. +Qed. + +Definition valid_list_hyps (f : hyps -> lhyps) := + forall (ep : list Prop) (e : list int) (lp : hyps), + interp_hyps ep e lp -> interp_list_hyps ep e (f lp). + +Definition valid_list_goal (f : hyps -> lhyps) := + forall (ep : list Prop) (e : list int) (lp : hyps), + interp_list_goal ep e (f lp) -> interp_goal ep e lp. + +Theorem goal_valid : + forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. +Proof. + unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps; + intro H2; apply list_hyps_to_goal with (1 := H1); + apply (H ep e lp); assumption. +Qed. + +Theorem append_valid : + forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), + interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> + interp_list_hyps ep e (l1 ++ l2). +Proof. + intros ep e; simple induction l1; + [ simpl in |- *; intros l2 [H| H]; [ contradiction | trivial ] + | simpl in |- *; intros h1 t1 HR l2 [[H| H]| H]; + [ auto + | right; apply (HR l2); left; trivial + | right; apply (HR l2); right; trivial ] ]. + +Qed. + +(* \subsubsection{Opérateurs valides sur les hypothèses} *) + +(* Extraire une hypothèse de la liste *) +Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. + +Theorem nth_valid : + forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), + interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). +Proof. + unfold nth_hyps in |- *; simple induction i; + [ simple induction l; simpl in |- *; [ auto | intros; elim H0; auto ] + | intros n H; simple induction l; + [ simpl in |- *; trivial + | intros; simpl in |- *; apply H; elim H1; auto ] ]. +Qed. + +(* Appliquer une opération (valide) sur deux hypothèses extraites de + la liste et ajouter le résultat à la liste. *) +Definition apply_oper_2 (i j : nat) + (f : proposition -> proposition -> proposition) (l : hyps) := + f (nth_hyps i l) (nth_hyps j l) :: l. + +Theorem apply_oper_2_valid : + forall (i j : nat) (f : proposition -> proposition -> proposition), + valid2 f -> valid_hyps (apply_oper_2 i j f). +Proof. + intros i j f Hf; unfold apply_oper_2, valid_hyps in |- *; simpl in |- *; + intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ]. +Qed. + +(* Modifier une hypothèse par application d'une opération valide *) + +Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) + (l : hyps) {struct i} : hyps := + match l with + | nil => nil (A:=proposition) + | p :: l' => + match i with + | O => f p :: l' + | S j => p :: apply_oper_1 j f l' + end + end. + +Theorem apply_oper_1_valid : + forall (i : nat) (f : proposition -> proposition), + valid1 f -> valid_hyps (apply_oper_1 i f). +Proof. + unfold valid_hyps in |- *; intros i f Hf ep e; elim i; + [ intro lp; case lp; + [ simpl in |- *; trivial + | simpl in |- *; intros p l' (H1, H2); split; + [ apply Hf with (1 := H1) | assumption ] ] + | intros n Hrec lp; case lp; + [ simpl in |- *; auto + | simpl in |- *; intros p l' (H1, H2); split; + [ assumption | apply Hrec; assumption ] ] ]. +Qed. + +(* \subsubsection{Manipulations de termes} *) +(* Les fonctions suivantes permettent d'appliquer une fonction de + réécriture sur un sous terme du terme principal. Avec la composition, + cela permet de construire des réécritures complexes proches des + tactiques de conversion *) + +Definition apply_left (f : term -> term) (t : term) := + match t with + | (x + y)%term => (f x + y)%term + | (x * y)%term => (f x * y)%term + | (- x)%term => (- f x)%term + | x => x + end. + +Definition apply_right (f : term -> term) (t : term) := + match t with + | (x + y)%term => (x + f y)%term + | (x * y)%term => (x * f y)%term + | x => x + end. + +Definition apply_both (f g : term -> term) (t : term) := + match t with + | (x + y)%term => (f x + g y)%term + | (x * y)%term => (f x * g y)%term + | x => x + end. + +(* Les théorèmes suivants montrent la stabilité (conditionnée) des + fonctions. *) + +Theorem apply_left_stable : + forall f : term -> term, term_stable f -> term_stable (apply_left f). +Proof. + unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *; + intros; elim H; trivial. +Qed. + +Theorem apply_right_stable : + forall f : term -> term, term_stable f -> term_stable (apply_right f). +Proof. + unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *; + intros t0 t1; elim H; trivial. +Qed. + +Theorem apply_both_stable : + forall f g : term -> term, + term_stable f -> term_stable g -> term_stable (apply_both f g). +Proof. + unfold term_stable in |- *; intros f g H1 H2 e t; case t; auto; simpl in |- *; + intros t0 t1; elim H1; elim H2; trivial. +Qed. + +Theorem compose_term_stable : + forall f g : term -> term, + term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)). +Proof. + unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg. +Qed. + +(* \subsection{Les règles de réécriture} *) +(* Chacune des règles de réécriture est accompagnée par sa preuve de + stabilité. Toutes ces preuves ont la même forme : il faut analyser + suivant la forme du terme (élimination de chaque Case). On a besoin d'une + élimination uniquement dans les cas d'utilisation d'égalité décidable. + + Cette tactique itère la décomposition des Case. Elle est + constituée de deux fonctions s'appelant mutuellement : + \begin{itemize} + \item une fonction d'enrobage qui lance la recherche sur le but, + \item une fonction récursive qui décompose ce but. Quand elle a trouvé un + Case, elle l'élimine. + \end{itemize} + Les motifs sur les cas sont très imparfaits et dans certains cas, il + semble que cela ne marche pas. On aimerait plutot un motif de la + forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on + utilise le bon type. + + Chaque élimination introduit correctement exactement le nombre d'hypothèses + nécessaires et conserve dans le cas d'une égalité la connaissance du + résultat du test en faisant la réécriture. Pour un test de comparaison, + on conserve simplement le résultat. + + Cette fonction déborde très largement la résolution des réécritures + simples et fait une bonne partie des preuves des pas de Omega. +*) + +(* \subsubsection{La tactique pour prouver la stabilité} *) + +Ltac loop t := + match t with + (* Global *) + | (?X1 = ?X2) => loop X1 || loop X2 + | (_ -> ?X1) => loop X1 + (* Interpretations *) + | (interp_hyps _ _ ?X1) => loop X1 + | (interp_list_hyps _ _ ?X1) => loop X1 + | (interp_proposition _ _ ?X1) => loop X1 + | (interp_term _ ?X1) => loop X1 + (* Propositions *) + | (EqTerm ?X1 ?X2) => loop X1 || loop X2 + | (LeqTerm ?X1 ?X2) => loop X1 || loop X2 + (* Termes *) + | (?X1 + ?X2)%term => loop X1 || loop X2 + | (?X1 - ?X2)%term => loop X1 || loop X2 + | (?X1 * ?X2)%term => loop X1 || loop X2 + | (- ?X1)%term => loop X1 + | (Tint ?X1) => loop X1 + (* Eliminations *) + | match ?X1 with + | EqTerm x x0 => _ + | LeqTerm x x0 => _ + | TrueTerm => _ + | FalseTerm => _ + | Tnot x => _ + | GeqTerm x x0 => _ + | GtTerm x x0 => _ + | LtTerm x x0 => _ + | NeqTerm x x0 => _ + | Tor x x0 => _ + | Tand x x0 => _ + | Timp x x0 => _ + | Tprop x => _ + end => destruct X1; auto; Simplify + | match ?X1 with + | Tint x => _ + | (x + x0)%term => _ + | (x * x0)%term => _ + | (x - x0)%term => _ + | (- x)%term => _ + | [x]%term => _ + end => destruct X1; auto; Simplify + | (if beq ?X1 ?X2 then _ else _) => + let H := fresh "H" in + elim_beq X1 X2; intro H; try (rewrite H in *; clear H); + simpl in |- *; auto; Simplify + | (if bgt ?X1 ?X2 then _ else _) => + let H := fresh "H" in + elim_bgt X1 X2; intro H; simpl in |- *; auto; Simplify + | (if eq_term ?X1 ?X2 then _ else _) => + let H := fresh "H" in + elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H); + simpl in |- *; auto; Simplify + | (if _ && _ then _ else _) => rewrite andb_if; Simplify + | (if negb _ then _ else _) => rewrite negb_if; Simplify + | _ => fail + end + +with Simplify := match goal with + | |- ?X1 => try loop X1 + | _ => idtac + end. + +Ltac prove_stable x th := + match constr:x with + | ?X1 => + unfold term_stable, X1 in |- *; intros; Simplify; simpl in |- *; + apply th + end. + +(* \subsubsection{Les règles elle mêmes} *) +Definition Tplus_assoc_l (t : term) := + match t with + | (n + (m + p))%term => (n + m + p)%term + | _ => t + end. + +Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l. +Proof. + prove_stable Tplus_assoc_l (ring.(Radd_assoc)). +Qed. + +Definition Tplus_assoc_r (t : term) := + match t with + | (n + m + p)%term => (n + (m + p))%term + | _ => t + end. + +Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r. +Proof. + prove_stable Tplus_assoc_r plus_assoc_reverse. +Qed. + +Definition Tmult_assoc_r (t : term) := + match t with + | (n * m * p)%term => (n * (m * p))%term + | _ => t + end. + +Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r. +Proof. + prove_stable Tmult_assoc_r mult_assoc_reverse. +Qed. + +Definition Tplus_permute (t : term) := + match t with + | (n + (m + p))%term => (m + (n + p))%term + | _ => t + end. + +Theorem Tplus_permute_stable : term_stable Tplus_permute. +Proof. + prove_stable Tplus_permute plus_permute. +Qed. + +Definition Tplus_comm (t : term) := + match t with + | (x + y)%term => (y + x)%term + | _ => t + end. + +Theorem Tplus_comm_stable : term_stable Tplus_comm. +Proof. + prove_stable Tplus_comm plus_comm. +Qed. + +Definition Tmult_comm (t : term) := + match t with + | (x * y)%term => (y * x)%term + | _ => t + end. + +Theorem Tmult_comm_stable : term_stable Tmult_comm. +Proof. + prove_stable Tmult_comm mult_comm. +Qed. + +Definition T_OMEGA10 (t : term) := + match t with + | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term => + if eq_term v v' + then (v * Tint (c1 * k1 + c2 * k2)%I + (l1 * Tint k1 + l2 * Tint k2))%term + else t + | _ => t + end. + +Theorem T_OMEGA10_stable : term_stable T_OMEGA10. +Proof. + prove_stable T_OMEGA10 OMEGA10. +Qed. + +Definition T_OMEGA11 (t : term) := + match t with + | ((v1 * Tint c1 + l1) * Tint k1 + l2)%term => + (v1 * Tint (c1 * k1) + (l1 * Tint k1 + l2))%term + | _ => t + end. + +Theorem T_OMEGA11_stable : term_stable T_OMEGA11. +Proof. + prove_stable T_OMEGA11 OMEGA11. +Qed. + +Definition T_OMEGA12 (t : term) := + match t with + | (l1 + (v2 * Tint c2 + l2) * Tint k2)%term => + (v2 * Tint (c2 * k2) + (l1 + l2 * Tint k2))%term + | _ => t + end. + +Theorem T_OMEGA12_stable : term_stable T_OMEGA12. +Proof. + prove_stable T_OMEGA12 OMEGA12. +Qed. + +Definition T_OMEGA13 (t : term) := + match t with + | (v * Tint x + l1 + (v' * Tint x' + l2))%term => + if eq_term v v' && beq x (-x') + then (l1+l2)%term + else t + | _ => t + end. + +Theorem T_OMEGA13_stable : term_stable T_OMEGA13. +Proof. + unfold term_stable, T_OMEGA13 in |- *; intros; Simplify; simpl in |- *; + apply OMEGA13. +Qed. + +Definition T_OMEGA15 (t : term) := + match t with + | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term => + if eq_term v v' + then (v * Tint (c1 + c2 * k2)%I + (l1 + l2 * Tint k2))%term + else t + | _ => t + end. + +Theorem T_OMEGA15_stable : term_stable T_OMEGA15. +Proof. + prove_stable T_OMEGA15 OMEGA15. +Qed. + +Definition T_OMEGA16 (t : term) := + match t with + | ((v * Tint c + l) * Tint k)%term => (v * Tint (c * k) + l * Tint k)%term + | _ => t + end. + + +Theorem T_OMEGA16_stable : term_stable T_OMEGA16. +Proof. + prove_stable T_OMEGA16 OMEGA16. +Qed. + +Definition Tred_factor5 (t : term) := + match t with + | (x * Tint c + y)%term => if beq c 0 then y else t + | _ => t + end. + +Theorem Tred_factor5_stable : term_stable Tred_factor5. +Proof. + prove_stable Tred_factor5 red_factor5. +Qed. + +Definition Topp_plus (t : term) := + match t with + | (- (x + y))%term => (- x + - y)%term + | _ => t + end. + +Theorem Topp_plus_stable : term_stable Topp_plus. +Proof. + prove_stable Topp_plus opp_plus_distr. +Qed. + + +Definition Topp_opp (t : term) := + match t with + | (- - x)%term => x + | _ => t + end. + +Theorem Topp_opp_stable : term_stable Topp_opp. +Proof. + prove_stable Topp_opp opp_involutive. +Qed. + +Definition Topp_mult_r (t : term) := + match t with + | (- (x * Tint k))%term => (x * Tint (- k))%term + | _ => t + end. + +Theorem Topp_mult_r_stable : term_stable Topp_mult_r. +Proof. + prove_stable Topp_mult_r opp_mult_distr_r. +Qed. + +Definition Topp_one (t : term) := + match t with + | (- x)%term => (x * Tint (-(1)))%term + | _ => t + end. + +Theorem Topp_one_stable : term_stable Topp_one. +Proof. + prove_stable Topp_one opp_eq_mult_neg_1. +Qed. + +Definition Tmult_plus_distr (t : term) := + match t with + | ((n + m) * p)%term => (n * p + m * p)%term + | _ => t + end. + +Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr. +Proof. + prove_stable Tmult_plus_distr mult_plus_distr_r. +Qed. + +Definition Tmult_opp_left (t : term) := + match t with + | (- x * Tint y)%term => (x * Tint (- y))%term + | _ => t + end. + +Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left. +Proof. + prove_stable Tmult_opp_left mult_opp_comm. +Qed. + +Definition Tmult_assoc_reduced (t : term) := + match t with + | (n * Tint m * Tint p)%term => (n * Tint (m * p))%term + | _ => t + end. + +Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced. +Proof. + prove_stable Tmult_assoc_reduced mult_assoc_reverse. +Qed. + +Definition Tred_factor0 (t : term) := (t * Tint 1)%term. + +Theorem Tred_factor0_stable : term_stable Tred_factor0. +Proof. + prove_stable Tred_factor0 red_factor0. +Qed. + +Definition Tred_factor1 (t : term) := + match t with + | (x + y)%term => + if eq_term x y + then (x * Tint 2)%term + else t + | _ => t + end. + +Theorem Tred_factor1_stable : term_stable Tred_factor1. +Proof. + prove_stable Tred_factor1 red_factor1. +Qed. + +Definition Tred_factor2 (t : term) := + match t with + | (x + y * Tint k)%term => + if eq_term x y + then (x * Tint (1 + k))%term + else t + | _ => t + end. + +Theorem Tred_factor2_stable : term_stable Tred_factor2. +Proof. + prove_stable Tred_factor2 red_factor2. +Qed. + +Definition Tred_factor3 (t : term) := + match t with + | (x * Tint k + y)%term => + if eq_term x y + then (x * Tint (1 + k))%term + else t + | _ => t + end. + +Theorem Tred_factor3_stable : term_stable Tred_factor3. +Proof. + prove_stable Tred_factor3 red_factor3. +Qed. + + +Definition Tred_factor4 (t : term) := + match t with + | (x * Tint k1 + y * Tint k2)%term => + if eq_term x y + then (x * Tint (k1 + k2))%term + else t + | _ => t + end. + +Theorem Tred_factor4_stable : term_stable Tred_factor4. +Proof. + prove_stable Tred_factor4 red_factor4. +Qed. + +Definition Tred_factor6 (t : term) := (t + Tint 0)%term. + +Theorem Tred_factor6_stable : term_stable Tred_factor6. +Proof. + prove_stable Tred_factor6 red_factor6. +Qed. + +Definition Tminus_def (t : term) := + match t with + | (x - y)%term => (x + - y)%term + | _ => t + end. + +Theorem Tminus_def_stable : term_stable Tminus_def. +Proof. + prove_stable Tminus_def minus_def. +Qed. + +(* \subsection{Fonctions de réécriture complexes} *) + +(* \subsubsection{Fonction de réduction} *) +(* Cette fonction réduit un terme dont la forme normale est un entier. Il + suffit pour cela d'échanger le constructeur [Tint] avec les opérateurs + réifiés. La réduction est ``gratuite''. *) + +Fixpoint reduce (t : term) : term := + match t with + | (x + y)%term => + match reduce x with + | Tint x' => + match reduce y with + | Tint y' => Tint (x' + y') + | y' => (Tint x' + y')%term + end + | x' => (x' + reduce y)%term + end + | (x * y)%term => + match reduce x with + | Tint x' => + match reduce y with + | Tint y' => Tint (x' * y') + | y' => (Tint x' * y')%term + end + | x' => (x' * reduce y)%term + end + | (x - y)%term => + match reduce x with + | Tint x' => + match reduce y with + | Tint y' => Tint (x' - y') + | y' => (Tint x' - y')%term + end + | x' => (x' - reduce y)%term + end + | (- x)%term => + match reduce x with + | Tint x' => Tint (- x') + | x' => (- x')%term + end + | _ => t + end. + +Theorem reduce_stable : term_stable reduce. +Proof. + unfold term_stable in |- *; intros e t; elim t; auto; + try + (intros t0 H0 t1 H1; simpl in |- *; rewrite H0; rewrite H1; + (case (reduce t0); + [ intro z0; case (reduce t1); intros; auto + | intros; auto + | intros; auto + | intros; auto + | intros; auto + | intros; auto ])); intros t0 H0; simpl in |- *; + rewrite H0; case (reduce t0); intros; auto. +Qed. + +(* \subsubsection{Fusions} + \paragraph{Fusion de deux équations} *) +(* On donne une somme de deux équations qui sont supposées normalisées. + Cette fonction prend une trace de fusion en argument et transforme + le terme en une équation normalisée. C'est une version très simplifiée + du moteur de réécriture [rewrite]. *) + +Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := + match trace with + | nil => reduce t + | step :: trace' => + match step with + | F_equal => apply_right (fusion trace') (T_OMEGA10 t) + | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA10 t)) + | F_left => apply_right (fusion trace') (T_OMEGA11 t) + | F_right => apply_right (fusion trace') (T_OMEGA12 t) + end + end. + +Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t). +Proof. + simple induction t; simpl in |- *; + [ exact reduce_stable + | intros stp l H; case stp; + [ apply compose_term_stable; + [ apply apply_right_stable; assumption | exact T_OMEGA10_stable ] + | unfold term_stable in |- *; intros e t1; rewrite T_OMEGA10_stable; + rewrite Tred_factor5_stable; apply H + | apply compose_term_stable; + [ apply apply_right_stable; assumption | exact T_OMEGA11_stable ] + | apply compose_term_stable; + [ apply apply_right_stable; assumption | exact T_OMEGA12_stable ] ] ]. +Qed. + +(* \paragraph{Fusion de deux équations dont une sans coefficient} *) + +Definition fusion_right (trace : list t_fusion) (t : term) : term := + match trace with + | nil => reduce t (* Il faut mettre un compute *) + | step :: trace' => + match step with + | F_equal => apply_right (fusion trace') (T_OMEGA15 t) + | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA15 t)) + | F_left => apply_right (fusion trace') (Tplus_assoc_r t) + | F_right => apply_right (fusion trace') (T_OMEGA12 t) + end + end. + +(* \paragraph{Fusion avec annihilation} *) +(* Normalement le résultat est une constante *) + +Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term := + match trace with + | O => reduce t + | S trace' => fusion_cancel trace' (T_OMEGA13 t) + end. + +Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t). +Proof. + unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace; + [ exact (reduce_stable e) + | intros n H t; elim H; exact (T_OMEGA13_stable e t) ]. +Qed. + +(* \subsubsection{Opérations affines sur une équation} *) +(* \paragraph{Multiplication scalaire et somme d'une constante} *) + +Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term := + match trace with + | O => reduce t + | S trace' => apply_right (scalar_norm_add trace') (T_OMEGA11 t) + end. + +Theorem scalar_norm_add_stable : + forall t : nat, term_stable (scalar_norm_add t). +Proof. + unfold term_stable, scalar_norm_add in |- *; intros trace; elim trace; + [ exact reduce_stable + | intros n H e t; elim apply_right_stable; + [ exact (T_OMEGA11_stable e t) | exact H ] ]. +Qed. + +(* \paragraph{Multiplication scalaire} *) +Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term := + match trace with + | O => reduce t + | S trace' => apply_right (scalar_norm trace') (T_OMEGA16 t) + end. + +Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t). +Proof. + unfold term_stable, scalar_norm in |- *; intros trace; elim trace; + [ exact reduce_stable + | intros n H e t; elim apply_right_stable; + [ exact (T_OMEGA16_stable e t) | exact H ] ]. +Qed. + +(* \paragraph{Somme d'une constante} *) +Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term := + match trace with + | O => reduce t + | S trace' => apply_right (add_norm trace') (Tplus_assoc_r t) + end. + +Theorem add_norm_stable : forall t : nat, term_stable (add_norm t). +Proof. + unfold term_stable, add_norm in |- *; intros trace; elim trace; + [ exact reduce_stable + | intros n H e t; elim apply_right_stable; + [ exact (Tplus_assoc_r_stable e t) | exact H ] ]. +Qed. + +(* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *) + + +Fixpoint rewrite (s : step) : term -> term := + match s with + | C_DO_BOTH s1 s2 => apply_both (rewrite s1) (rewrite s2) + | C_LEFT s => apply_left (rewrite s) + | C_RIGHT s => apply_right (rewrite s) + | C_SEQ s1 s2 => fun t : term => rewrite s2 (rewrite s1 t) + | C_NOP => fun t : term => t + | C_OPP_PLUS => Topp_plus + | C_OPP_OPP => Topp_opp + | C_OPP_MULT_R => Topp_mult_r + | C_OPP_ONE => Topp_one + | C_REDUCE => reduce + | C_MULT_PLUS_DISTR => Tmult_plus_distr + | C_MULT_OPP_LEFT => Tmult_opp_left + | C_MULT_ASSOC_R => Tmult_assoc_r + | C_PLUS_ASSOC_R => Tplus_assoc_r + | C_PLUS_ASSOC_L => Tplus_assoc_l + | C_PLUS_PERMUTE => Tplus_permute + | C_PLUS_COMM => Tplus_comm + | C_RED0 => Tred_factor0 + | C_RED1 => Tred_factor1 + | C_RED2 => Tred_factor2 + | C_RED3 => Tred_factor3 + | C_RED4 => Tred_factor4 + | C_RED5 => Tred_factor5 + | C_RED6 => Tred_factor6 + | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced + | C_MINUS => Tminus_def + | C_MULT_COMM => Tmult_comm + end. + +Theorem rewrite_stable : forall s : step, term_stable (rewrite s). +Proof. + simple induction s; simpl in |- *; + [ intros; apply apply_both_stable; auto + | intros; apply apply_left_stable; auto + | intros; apply apply_right_stable; auto + | unfold term_stable in |- *; intros; elim H0; apply H + | unfold term_stable in |- *; auto + | exact Topp_plus_stable + | exact Topp_opp_stable + | exact Topp_mult_r_stable + | exact Topp_one_stable + | exact reduce_stable + | exact Tmult_plus_distr_stable + | exact Tmult_opp_left_stable + | exact Tmult_assoc_r_stable + | exact Tplus_assoc_r_stable + | exact Tplus_assoc_l_stable + | exact Tplus_permute_stable + | exact Tplus_comm_stable + | exact Tred_factor0_stable + | exact Tred_factor1_stable + | exact Tred_factor2_stable + | exact Tred_factor3_stable + | exact Tred_factor4_stable + | exact Tred_factor5_stable + | exact Tred_factor6_stable + | exact Tmult_assoc_reduced_stable + | exact Tminus_def_stable + | exact Tmult_comm_stable ]. +Qed. + +(* \subsection{tactiques de résolution d'un but omega normalisé} + Trace de la procédure +\subsubsection{Tactiques générant une contradiction} +\paragraph{[O_CONSTANT_NOT_NUL]} *) + +Definition constant_not_nul (i : nat) (h : hyps) := + match nth_hyps i h with + | EqTerm (Tint Nul) (Tint n) => + if beq n Nul then h else absurd + | _ => h + end. + +Theorem constant_not_nul_valid : + forall i : nat, valid_hyps (constant_not_nul i). +Proof. + unfold valid_hyps, constant_not_nul in |- *; intros; + generalize (nth_valid ep e i lp); Simplify; simpl in |- *. + + elim_beq i1 i0; auto; simpl in |- *; intros H1 H2; + elim H1; symmetry in |- *; auto. +Qed. + +(* \paragraph{[O_CONSTANT_NEG]} *) + +Definition constant_neg (i : nat) (h : hyps) := + match nth_hyps i h with + | LeqTerm (Tint Nul) (Tint Neg) => + if bgt Nul Neg then absurd else h + | _ => h + end. + +Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i). +Proof. + unfold valid_hyps, constant_neg in |- *; intros; + generalize (nth_valid ep e i lp); Simplify; simpl in |- *. + rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. +Qed. + +(* \paragraph{[NOT_EXACT_DIVIDE]} *) +Definition not_exact_divide (k1 k2 : int) (body : term) + (t i : nat) (l : hyps) := + match nth_hyps i l with + | EqTerm (Tint Nul) b => + if beq Nul 0 && + eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && + bgt k2 0 && + bgt k1 k2 + then absurd + else l + | _ => l + end. + +Theorem not_exact_divide_valid : + forall (k1 k2 : int) (body : term) (t i : nat), + valid_hyps (not_exact_divide k1 k2 body t i). +Proof. + unfold valid_hyps, not_exact_divide in |- *; intros; + generalize (nth_valid ep e i lp); Simplify. + rewrite (scalar_norm_add_stable t e), <-H1. + do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros. + absurd (interp_term e body * k1 + k2 = 0); + [ now apply OMEGA4 | symmetry; auto ]. +Qed. + +(* \paragraph{[O_CONTRADICTION]} *) + +Definition contradiction (t i j : nat) (l : hyps) := + match nth_hyps i l with + | LeqTerm (Tint Nul) b1 => + match nth_hyps j l with + | LeqTerm (Tint Nul') b2 => + match fusion_cancel t (b1 + b2)%term with + | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k + then absurd + else l + | _ => l + end + | _ => l + end + | _ => l + end. + +Theorem contradiction_valid : + forall t i j : nat, valid_hyps (contradiction t i j). +Proof. + unfold valid_hyps, contradiction in |- *; intros t i j ep e l H; + generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); + case (nth_hyps i l); auto; intros t1 t2; case t1; + auto; case (nth_hyps j l); + auto; intros t3 t4; case t3; auto; + simpl in |- *; intros z z' H1 H2; + generalize (refl_equal (interp_term e (fusion_cancel t (t2 + t4)%term))); + pattern (fusion_cancel t (t2 + t4)%term) at 2 3 in |- *; + case (fusion_cancel t (t2 + t4)%term); simpl in |- *; + auto; intro k; elim (fusion_cancel_stable t); simpl in |- *. + Simplify; intro H3. + generalize (OMEGA2 _ _ H2 H1); rewrite H3. + rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. +Qed. + +(* \paragraph{[O_NEGATE_CONTRADICT]} *) + +Definition negate_contradict (i1 i2 : nat) (h : hyps) := + match nth_hyps i1 h with + | EqTerm (Tint Nul) b1 => + match nth_hyps i2 h with + | NeqTerm (Tint Nul') b2 => + if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 + then absurd + else h + | _ => h + end + | NeqTerm (Tint Nul) b1 => + match nth_hyps i2 h with + | EqTerm (Tint Nul') b2 => + if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 + then absurd + else h + | _ => h + end + | _ => h + end. + +Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := + match nth_hyps i1 h with + | EqTerm (Tint Nul) b1 => + match nth_hyps i2 h with + | NeqTerm (Tint Nul') b2 => + if beq Nul 0 && beq Nul' 0 && + eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) + then absurd + else h + | _ => h + end + | NeqTerm (Tint Nul) b1 => + match nth_hyps i2 h with + | EqTerm (Tint Nul') b2 => + if beq Nul 0 && beq Nul' 0 && + eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) + then absurd + else h + | _ => h + end + | _ => h + end. + +Theorem negate_contradict_valid : + forall i j : nat, valid_hyps (negate_contradict i j). +Proof. + unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H; + generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); + case (nth_hyps i l); auto; intros t1 t2; case t1; + auto; intros z; auto; case (nth_hyps j l); + auto; intros t3 t4; case t3; auto; intros z'; + auto; simpl in |- *; intros H1 H2; Simplify. +Qed. + +Theorem negate_contradict_inv_valid : + forall t i j : nat, valid_hyps (negate_contradict_inv t i j). +Proof. + unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H; + generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); + case (nth_hyps i l); auto; intros t1 t2; case t1; + auto; intros z; auto; case (nth_hyps j l); + auto; intros t3 t4; case t3; auto; intros z'; + auto; simpl in |- *; intros H1 H2; Simplify; + [ + rewrite <- scalar_norm_stable in H2; simpl in *; + elim (mult_integral (interp_term e t4) (-(1))); intuition; + elim minus_one_neq_zero; auto + | + elim H2; clear H2; + rewrite <- scalar_norm_stable; simpl in *; + now rewrite <- H1, mult_0_l + ]. +Qed. + +(* \subsubsection{Tactiques générant une nouvelle équation} *) +(* \paragraph{[O_SUM]} + C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant + les opérateurs de comparaison des deux arguments) d'où une + preuve un peu compliquée. On utilise quelques lemmes qui sont des + généralisations des théorèmes utilisés par OMEGA. *) + +Definition sum (k1 k2 : int) (trace : list t_fusion) + (prop1 prop2 : proposition) := + match prop1 with + | EqTerm (Tint Null) b1 => + match prop2 with + | EqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 + then EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + else TrueTerm + | LeqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 && bgt k2 0 + then LeqTerm (Tint 0) + (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + else TrueTerm + | _ => TrueTerm + end + | LeqTerm (Tint Null) b1 => + if beq Null 0 && bgt k1 0 + then match prop2 with + | EqTerm (Tint Null') b2 => + if beq Null' 0 then + LeqTerm (Tint 0) + (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + else TrueTerm + | LeqTerm (Tint Null') b2 => + if beq Null' 0 && bgt k2 0 + then LeqTerm (Tint 0) + (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + else TrueTerm + | _ => TrueTerm + end + else TrueTerm + | NeqTerm (Tint Null) b1 => + match prop2 with + | EqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 && (negb (beq k1 0)) + then NeqTerm (Tint 0) + (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + else TrueTerm + | _ => TrueTerm + end + | _ => TrueTerm + end. + + +Theorem sum_valid : + forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t). +Proof. + unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *; + Simplify; simpl in |- *; auto; try elim (fusion_stable t); + simpl in |- *; intros; + [ apply sum1; assumption + | apply sum2; try assumption; apply sum4; assumption + | rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption + | apply sum3; try assumption; apply sum4; assumption + | apply sum5; auto ]. +Qed. + +(* \paragraph{[O_EXACT_DIVIDE]} + c'est une oper1 valide mais on préfère une substitution a ce point la *) + +Definition exact_divide (k : int) (body : term) (t : nat) + (prop : proposition) := + match prop with + | EqTerm (Tint Null) b => + if beq Null 0 && + eq_term (scalar_norm t (body * Tint k)%term) b && + negb (beq k 0) + then EqTerm (Tint 0) body + else TrueTerm + | NeqTerm (Tint Null) b => + if beq Null 0 && + eq_term (scalar_norm t (body * Tint k)%term) b && + negb (beq k 0) + then NeqTerm (Tint 0) body + else TrueTerm + | _ => TrueTerm + end. + +Theorem exact_divide_valid : + forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n). +Proof. + unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; + Simplify; simpl; auto; subst; + rewrite <- scalar_norm_stable; simpl; intros; + [ destruct (mult_integral _ _ (sym_eq H0)); intuition + | contradict H0; rewrite <- H0, mult_0_l; auto + ]. +Qed. + + +(* \paragraph{[O_DIV_APPROX]} + La preuve reprend le schéma de la précédente mais on + est sur une opération de type valid1 et non sur une opération terminale. *) + +Definition divide_and_approx (k1 k2 : int) (body : term) + (t : nat) (prop : proposition) := + match prop with + | LeqTerm (Tint Null) b => + if beq Null 0 && + eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && + bgt k1 0 && + bgt k1 k2 + then LeqTerm (Tint 0) body + else prop + | _ => prop + end. + +Theorem divide_and_approx_valid : + forall (k1 k2 : int) (body : term) (t : nat), + valid1 (divide_and_approx k1 k2 body t). +Proof. + unfold valid1, divide_and_approx in |- *; intros k1 k2 body t ep e p1; + Simplify; simpl; auto; subst; + elim (scalar_norm_add_stable t e); simpl in |- *. + intro H2; apply mult_le_approx with (3 := H2); assumption. +Qed. + +(* \paragraph{[MERGE_EQ]} *) + +Definition merge_eq (t : nat) (prop1 prop2 : proposition) := + match prop1 with + | LeqTerm (Tint Null) b1 => + match prop2 with + | LeqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 && + eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) + then EqTerm (Tint 0) b1 + else TrueTerm + | _ => TrueTerm + end + | _ => TrueTerm + end. + +Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n). +Proof. + unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *; + auto; elim (scalar_norm_stable n e); simpl in |- *; + intros; symmetry in |- *; apply OMEGA8 with (2 := H0); + [ assumption | elim opp_eq_mult_neg_1; trivial ]. +Qed. + + + +(* \paragraph{[O_CONSTANT_NUL]} *) + +Definition constant_nul (i : nat) (h : hyps) := + match nth_hyps i h with + | NeqTerm (Tint Null) (Tint Null') => + if beq Null Null' then absurd else h + | _ => h + end. + +Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i). +Proof. + unfold valid_hyps, constant_nul in |- *; intros; + generalize (nth_valid ep e i lp); Simplify; simpl in |- *; + intro H1; absurd (0 = 0); intuition. +Qed. + +(* \paragraph{[O_STATE]} *) + +Definition state (m : int) (s : step) (prop1 prop2 : proposition) := + match prop1 with + | EqTerm (Tint Null) b1 => + match prop2 with + | EqTerm b2 b3 => + if beq Null 0 + then EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term) + else TrueTerm + | _ => TrueTerm + end + | _ => TrueTerm + end. + +Theorem state_valid : forall (m : int) (s : step), valid2 (state m s). +Proof. + unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify; + simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *; + intros H1 H2; elim H1. + now rewrite H2, plus_opp_l, plus_0_l, mult_0_l. +Qed. + +(* \subsubsection{Tactiques générant plusieurs but} + \paragraph{[O_SPLIT_INEQ]} + La seule pour le moment (tant que la normalisation n'est pas réfléchie). *) + +Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) + (l : hyps) := + match nth_hyps i l with + | NeqTerm (Tint Null) b1 => + if beq Null 0 then + f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-(1)))%term) :: l) ++ + f2 + (LeqTerm (Tint 0) + (scalar_norm_add t (b1 * Tint (-(1)) + Tint (-(1)))%term) :: l) + else l :: nil + | _ => l :: nil + end. + +Theorem split_ineq_valid : + forall (i t : nat) (f1 f2 : hyps -> lhyps), + valid_list_hyps f1 -> + valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2). +Proof. + unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H; + generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); + simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *; + auto; intros z; simpl in |- *; auto; intro H3. + Simplify. + apply append_valid; elim (OMEGA19 (interp_term e t2)); + [ intro H4; left; apply H1; simpl in |- *; elim (add_norm_stable t); + simpl in |- *; auto + | intro H4; right; apply H2; simpl in |- *; elim (scalar_norm_add_stable t); + simpl in |- *; auto + | generalize H3; unfold not in |- *; intros E1 E2; apply E1; + symmetry in |- *; trivial ]. +Qed. + + +(* \subsection{La fonction de rejeu de la trace} *) + +Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := + match t with + | O_CONSTANT_NOT_NUL n => singleton (constant_not_nul n l) + | O_CONSTANT_NEG n => singleton (constant_neg n l) + | O_DIV_APPROX k1 k2 body t cont n => + execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body t) l) + | O_NOT_EXACT_DIVIDE k1 k2 body t i => + singleton (not_exact_divide k1 k2 body t i l) + | O_EXACT_DIVIDE k body t cont n => + execute_omega cont (apply_oper_1 n (exact_divide k body t) l) + | O_SUM k1 i1 k2 i2 t cont => + execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2 t) l) + | O_CONTRADICTION t i j => singleton (contradiction t i j l) + | O_MERGE_EQ t i1 i2 cont => + execute_omega cont (apply_oper_2 i1 i2 (merge_eq t) l) + | O_SPLIT_INEQ t i cont1 cont2 => + split_ineq i t (execute_omega cont1) (execute_omega cont2) l + | O_CONSTANT_NUL i => singleton (constant_nul i l) + | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l) + | O_NEGATE_CONTRADICT_INV t i j => + singleton (negate_contradict_inv t i j l) + | O_STATE m s i1 i2 cont => + execute_omega cont (apply_oper_2 i1 i2 (state m s) l) + end. + +Theorem omega_valid : forall t : t_omega, valid_list_hyps (execute_omega t). +Proof. + simple induction t; simpl in |- *; + [ unfold valid_list_hyps in |- *; simpl in |- *; intros; left; + apply (constant_not_nul_valid n ep e lp H) + | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; + apply (constant_neg_valid n ep e lp H) + | unfold valid_list_hyps, valid_hyps in |- *; + intros k1 k2 body n t' Ht' m ep e lp H; apply Ht'; + apply + (apply_oper_1_valid m (divide_and_approx k1 k2 body n) + (divide_and_approx_valid k1 k2 body n) ep e lp H) + | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; + apply (not_exact_divide_valid i i0 t0 n n0 ep e lp H) + | unfold valid_list_hyps, valid_hyps in |- *; + intros k body n t' Ht' m ep e lp H; apply Ht'; + apply + (apply_oper_1_valid m (exact_divide k body n) + (exact_divide_valid k body n) ep e lp H) + | unfold valid_list_hyps, valid_hyps in |- *; + intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht'; + apply + (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e + lp H) + | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; + apply (contradiction_valid n n0 n1 ep e lp H) + | unfold valid_list_hyps, valid_hyps in |- *; + intros trace i1 i2 t' Ht' ep e lp H; apply Ht'; + apply + (apply_oper_2_valid i1 i2 (merge_eq trace) (merge_eq_valid trace) ep e + lp H) + | intros t' i k1 H1 k2 H2; unfold valid_list_hyps in |- *; simpl in |- *; + intros ep e lp H; + apply + (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) H1 H2 ep e + lp H) + | unfold valid_list_hyps in |- *; simpl in |- *; intros i ep e lp H; left; + apply (constant_nul_valid i ep e lp H) + | unfold valid_list_hyps in |- *; simpl in |- *; intros i j ep e lp H; left; + apply (negate_contradict_valid i j ep e lp H) + | unfold valid_list_hyps in |- *; simpl in |- *; intros n i j ep e lp H; + left; apply (negate_contradict_inv_valid n i j ep e lp H) + | unfold valid_list_hyps, valid_hyps in |- *; + intros m s i1 i2 t' Ht' ep e lp H; apply Ht'; + apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H) ]. +Qed. + + +(* \subsection{Les opérations globales sur le but} + \subsubsection{Normalisation} *) + +Definition move_right (s : step) (p : proposition) := + match p with + | EqTerm t1 t2 => EqTerm (Tint 0) (rewrite s (t1 + - t2)%term) + | LeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + - t1)%term) + | GeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + - t2)%term) + | LtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + Tint (-(1)) + - t1)%term) + | GtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + Tint (-(1)) + - t2)%term) + | NeqTerm t1 t2 => NeqTerm (Tint 0) (rewrite s (t1 + - t2)%term) + | p => p + end. + +Theorem move_right_valid : forall s : step, valid1 (move_right s). +Proof. + unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *; + elim (rewrite_stable s e); simpl in |- *; + [ symmetry in |- *; apply egal_left; assumption + | intro; apply le_left; assumption + | intro; apply le_left; rewrite <- ge_le_iff; assumption + | intro; apply lt_left; rewrite <- gt_lt_iff; assumption + | intro; apply lt_left; assumption + | intro; apply ne_left_2; assumption ]. +Qed. + +Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s). + +Theorem do_normalize_valid : + forall (i : nat) (s : step), valid_hyps (do_normalize i s). +Proof. + intros; unfold do_normalize in |- *; apply apply_oper_1_valid; + apply move_right_valid. +Qed. + +Fixpoint do_normalize_list (l : list step) (i : nat) + (h : hyps) {struct l} : hyps := + match l with + | s :: l' => do_normalize_list l' (S i) (do_normalize i s h) + | nil => h + end. + +Theorem do_normalize_list_valid : + forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i). +Proof. + simple induction l; simpl in |- *; unfold valid_hyps in |- *; + [ auto + | intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl'; + apply (do_normalize_valid i a ep e lp); assumption ]. +Qed. + +Theorem normalize_goal : + forall (s : list step) (ep : list Prop) (env : list int) (l : hyps), + interp_goal ep env (do_normalize_list s 0 l) -> interp_goal ep env l. +Proof. + intros; apply valid_goal with (2 := H); apply do_normalize_list_valid. +Qed. + +(* \subsubsection{Exécution de la trace} *) + +Theorem execute_goal : + forall (t : t_omega) (ep : list Prop) (env : list int) (l : hyps), + interp_list_goal ep env (execute_omega t l) -> interp_goal ep env l. +Proof. + intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H). +Qed. + + +Theorem append_goal : + forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), + interp_list_goal ep e l1 /\ interp_list_goal ep e l2 -> + interp_list_goal ep e (l1 ++ l2). +Proof. + intros ep e; simple induction l1; + [ simpl in |- *; intros l2 (H1, H2); assumption + | simpl in |- *; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ]. +Qed. + +(* A simple decidability checker : if the proposition belongs to the + simple grammar describe below then it is decidable. Proof is by + induction and uses well known theorem about arithmetic and propositional + calculus *) + +Fixpoint decidability (p : proposition) : bool := + match p with + | EqTerm _ _ => true + | LeqTerm _ _ => true + | GeqTerm _ _ => true + | GtTerm _ _ => true + | LtTerm _ _ => true + | NeqTerm _ _ => true + | FalseTerm => true + | TrueTerm => true + | Tnot t => decidability t + | Tand t1 t2 => decidability t1 && decidability t2 + | Timp t1 t2 => decidability t1 && decidability t2 + | Tor t1 t2 => decidability t1 && decidability t2 + | Tprop _ => false + end. + +Theorem decidable_correct : + forall (ep : list Prop) (e : list int) (p : proposition), + decidability p = true -> decidable (interp_proposition ep e p). +Proof. + simple induction p; simpl in |- *; intros; + [ apply dec_eq + | apply dec_le + | left; auto + | right; unfold not in |- *; auto + | apply dec_not; auto + | apply dec_ge + | apply dec_gt + | apply dec_lt + | apply dec_ne + | apply dec_or; elim andb_prop with (1 := H1); auto + | apply dec_and; elim andb_prop with (1 := H1); auto + | apply dec_imp; elim andb_prop with (1 := H1); auto + | discriminate H ]. +Qed. + +(* An interpretation function for a complete goal with an explicit + conclusion. We use an intermediate fixpoint. *) + +Fixpoint interp_full_goal (envp : list Prop) (env : list int) + (c : proposition) (l : hyps) {struct l} : Prop := + match l with + | nil => interp_proposition envp env c + | p' :: l' => + interp_proposition envp env p' -> interp_full_goal envp env c l' + end. + +Definition interp_full (ep : list Prop) (e : list int) + (lc : hyps * proposition) : Prop := + match lc with + | (l, c) => interp_full_goal ep e c l + end. + +(* Relates the interpretation of a complete goal with the interpretation + of its hypothesis and conclusion *) + +Theorem interp_full_false : + forall (ep : list Prop) (e : list int) (l : hyps) (c : proposition), + (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c). +Proof. + simple induction l; unfold interp_full in |- *; simpl in |- *; + [ auto | intros a l1 H1 c H2 H3; apply H1; auto ]. +Qed. + +(* Push the conclusion in the list of hypothesis using a double negation + If the decidability cannot be "proven", then just forget about the + conclusion (equivalent of replacing it with false) *) + +Definition to_contradict (lc : hyps * proposition) := + match lc with + | (l, c) => if decidability c then Tnot c :: l else l + end. + +(* The previous operation is valid in the sense that the new list of + hypothesis implies the original goal *) + +Theorem to_contradict_valid : + forall (ep : list Prop) (e : list int) (lc : hyps * proposition), + interp_goal ep e (to_contradict lc) -> interp_full ep e lc. +Proof. + intros ep e lc; case lc; intros l c; simpl in |- *; + pattern (decidability c) in |- *; apply bool_eq_ind; + [ simpl in |- *; intros H H1; apply interp_full_false; intros H2; + apply not_not; + [ apply decidable_correct; assumption + | unfold not at 1 in |- *; intro H3; apply hyps_to_goal with (2 := H2); + auto ] + | intros H1 H2; apply interp_full_false; intro H3; + elim hyps_to_goal with (1 := H2); assumption ]. +Qed. + +(* [map_cons x l] adds [x] at the head of each list in [l] (which is a list + of lists *) + +Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} : + list (list A) := + match l with + | nil => nil + | l :: ll => (x :: l) :: map_cons A x ll + end. + +(* This function breaks up a list of hypothesis in a list of simpler + list of hypothesis that together implie the original one. The goal + of all this is to transform the goal in a list of solvable problems. + Note that : + - we need a way to drive the analysis as some hypotheis may not + require a split. + - this procedure must be perfectly mimicked by the ML part otherwise + hypothesis will get desynchronised and this will be a mess. + *) + +Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps := + match nn with + | O => ll :: nil + | S n => + match ll with + | nil => nil :: nil + | Tor p1 p2 :: l => + destructure_hyps n (p1 :: l) ++ destructure_hyps n (p2 :: l) + | Tand p1 p2 :: l => destructure_hyps n (p1 :: p2 :: l) + | Timp p1 p2 :: l => + if decidability p1 + then + destructure_hyps n (Tnot p1 :: l) ++ destructure_hyps n (p2 :: l) + else map_cons _ (Timp p1 p2) (destructure_hyps n l) + | Tnot p :: l => + match p with + | Tnot p1 => + if decidability p1 + then destructure_hyps n (p1 :: l) + else map_cons _ (Tnot (Tnot p1)) (destructure_hyps n l) + | Tor p1 p2 => destructure_hyps n (Tnot p1 :: Tnot p2 :: l) + | Tand p1 p2 => + if decidability p1 + then + destructure_hyps n (Tnot p1 :: l) ++ + destructure_hyps n (Tnot p2 :: l) + else map_cons _ (Tnot p) (destructure_hyps n l) + | _ => map_cons _ (Tnot p) (destructure_hyps n l) + end + | x :: l => map_cons _ x (destructure_hyps n l) + end + end. + +Theorem map_cons_val : + forall (ep : list Prop) (e : list int) (p : proposition) (l : lhyps), + interp_proposition ep e p -> + interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l). +Proof. + simple induction l; simpl in |- *; [ auto | intros; elim H1; intro H2; auto ]. +Qed. + +Hint Resolve map_cons_val append_valid decidable_correct. + +Theorem destructure_hyps_valid : + forall n : nat, valid_list_hyps (destructure_hyps n). +Proof. + simple induction n; + [ unfold valid_list_hyps in |- *; simpl in |- *; auto + | unfold valid_list_hyps at 2 in |- *; intros n1 H ep e lp; case lp; + [ simpl in |- *; auto + | intros p l; case p; + try + (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0; + auto); + [ intro p'; case p'; + try + (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0; + auto); + [ simpl in |- *; intros p1 (H1, H2); + pattern (decidability p1) in |- *; apply bool_eq_ind; + intro H3; + [ apply H; simpl in |- *; split; + [ apply not_not; auto | assumption ] + | auto ] + | simpl in |- *; intros p1 p2 (H1, H2); apply H; simpl in |- *; + elim not_or with (1 := H1); auto + | simpl in |- *; intros p1 p2 (H1, H2); + pattern (decidability p1) in |- *; apply bool_eq_ind; + intro H3; + [ apply append_valid; elim not_and with (2 := H1); + [ intro; left; apply H; simpl in |- *; auto + | intro; right; apply H; simpl in |- *; auto + | auto ] + | auto ] ] + | simpl in |- *; intros p1 p2 (H1, H2); apply append_valid; + (elim H1; intro H3; simpl in |- *; [ left | right ]); + apply H; simpl in |- *; auto + | simpl in |- *; intros; apply H; simpl in |- *; tauto + | simpl in |- *; intros p1 p2 (H1, H2); + pattern (decidability p1) in |- *; apply bool_eq_ind; + intro H3; + [ apply append_valid; elim imp_simp with (2 := H1); + [ intro H4; left; simpl in |- *; apply H; simpl in |- *; auto + | intro H4; right; simpl in |- *; apply H; simpl in |- *; auto + | auto ] + | auto ] ] ] ]. +Qed. + +Definition prop_stable (f : proposition -> proposition) := + forall (ep : list Prop) (e : list int) (p : proposition), + interp_proposition ep e p <-> interp_proposition ep e (f p). + +Definition p_apply_left (f : proposition -> proposition) + (p : proposition) := + match p with + | Timp x y => Timp (f x) y + | Tor x y => Tor (f x) y + | Tand x y => Tand (f x) y + | Tnot x => Tnot (f x) + | x => x + end. + +Theorem p_apply_left_stable : + forall f : proposition -> proposition, + prop_stable f -> prop_stable (p_apply_left f). +Proof. + unfold prop_stable in |- *; intros f H ep e p; split; + (case p; simpl in |- *; auto; intros p1; elim (H ep e p1); tauto). +Qed. + +Definition p_apply_right (f : proposition -> proposition) + (p : proposition) := + match p with + | Timp x y => Timp x (f y) + | Tor x y => Tor x (f y) + | Tand x y => Tand x (f y) + | Tnot x => Tnot (f x) + | x => x + end. + +Theorem p_apply_right_stable : + forall f : proposition -> proposition, + prop_stable f -> prop_stable (p_apply_right f). +Proof. + unfold prop_stable in |- *; intros f H ep e p; split; + (case p; simpl in |- *; auto; + [ intros p1; elim (H ep e p1); tauto + | intros p1 p2; elim (H ep e p2); tauto + | intros p1 p2; elim (H ep e p2); tauto + | intros p1 p2; elim (H ep e p2); tauto ]). +Qed. + +Definition p_invert (f : proposition -> proposition) + (p : proposition) := + match p with + | EqTerm x y => Tnot (f (NeqTerm x y)) + | LeqTerm x y => Tnot (f (GtTerm x y)) + | GeqTerm x y => Tnot (f (LtTerm x y)) + | GtTerm x y => Tnot (f (LeqTerm x y)) + | LtTerm x y => Tnot (f (GeqTerm x y)) + | NeqTerm x y => Tnot (f (EqTerm x y)) + | x => x + end. + +Theorem p_invert_stable : + forall f : proposition -> proposition, + prop_stable f -> prop_stable (p_invert f). +Proof. + unfold prop_stable in |- *; intros f H ep e p; split; + (case p; simpl in |- *; auto; + [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl in |- *; + generalize (dec_eq (interp_term e t1) (interp_term e t2)); + unfold decidable in |- *; tauto + | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl in |- *; + generalize (dec_gt (interp_term e t1) (interp_term e t2)); + unfold decidable in |- *; rewrite le_lt_iff, <- gt_lt_iff; tauto + | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl in |- *; + generalize (dec_lt (interp_term e t1) (interp_term e t2)); + unfold decidable in |- *; rewrite ge_le_iff, le_lt_iff; tauto + | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl in |- *; + generalize (dec_gt (interp_term e t1) (interp_term e t2)); + unfold decidable in |- *; repeat rewrite le_lt_iff; + repeat rewrite gt_lt_iff; tauto + | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl in |- *; + generalize (dec_lt (interp_term e t1) (interp_term e t2)); + unfold decidable in |- *; repeat rewrite ge_le_iff; + repeat rewrite le_lt_iff; tauto + | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl in |- *; + generalize (dec_eq (interp_term e t1) (interp_term e t2)); + unfold decidable; tauto ]). +Qed. + +Theorem move_right_stable : forall s : step, prop_stable (move_right s). +Proof. + unfold move_right, prop_stable in |- *; intros s ep e p; split; + [ Simplify; simpl in |- *; elim (rewrite_stable s e); simpl in |- *; + [ symmetry in |- *; apply egal_left; assumption + | intro; apply le_left; assumption + | intro; apply le_left; rewrite <- ge_le_iff; assumption + | intro; apply lt_left; rewrite <- gt_lt_iff; assumption + | intro; apply lt_left; assumption + | intro; apply ne_left_2; assumption ] + | case p; simpl in |- *; intros; auto; generalize H; elim (rewrite_stable s); + simpl in |- *; intro H1; + [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1; + rewrite plus_permute; rewrite plus_opp_r; + rewrite plus_0_r; trivial + | apply (fun a b => plus_le_reg_r a b (- interp_term e t)); + rewrite plus_opp_r; assumption + | rewrite ge_le_iff; + apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); + rewrite plus_opp_r; assumption + | rewrite gt_lt_iff; apply lt_left_inv; assumption + | apply lt_left_inv; assumption + | unfold not in |- *; intro H2; apply H1; + rewrite H2; rewrite plus_opp_r; trivial ] ]. +Qed. + + +Fixpoint p_rewrite (s : p_step) : proposition -> proposition := + match s with + | P_LEFT s => p_apply_left (p_rewrite s) + | P_RIGHT s => p_apply_right (p_rewrite s) + | P_STEP s => move_right s + | P_INVERT s => p_invert (move_right s) + | P_NOP => fun p : proposition => p + end. + +Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s). +Proof. + simple induction s; simpl in |- *; + [ intros; apply p_apply_left_stable; trivial + | intros; apply p_apply_right_stable; trivial + | intros; apply p_invert_stable; apply move_right_stable + | apply move_right_stable + | unfold prop_stable in |- *; simpl in |- *; intros; split; auto ]. +Qed. + +Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps := + match l with + | nil => lh + | pair_step i s :: r => normalize_hyps r (apply_oper_1 i (p_rewrite s) lh) + end. + +Theorem normalize_hyps_valid : + forall l : list h_step, valid_hyps (normalize_hyps l). +Proof. + simple induction l; unfold valid_hyps in |- *; simpl in |- *; + [ auto + | intros n_s r; case n_s; intros n s H ep e lp H1; apply H; + apply apply_oper_1_valid; + [ unfold valid1 in |- *; intros ep1 e1 p1 H2; + elim (p_rewrite_stable s ep1 e1 p1); auto + | assumption ] ]. +Qed. + +Theorem normalize_hyps_goal : + forall (s : list h_step) (ep : list Prop) (env : list int) (l : hyps), + interp_goal ep env (normalize_hyps s l) -> interp_goal ep env l. +Proof. + intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. +Qed. + +Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} : + proposition := + match s with + | D_left :: l => + match p with + | Tand x y => extract_hyp_pos l x + | _ => p + end + | D_right :: l => + match p with + | Tand x y => extract_hyp_pos l y + | _ => p + end + | D_mono :: l => match p with + | Tnot x => extract_hyp_neg l x + | _ => p + end + | _ => p + end + + with extract_hyp_neg (s : list direction) (p : proposition) {struct s} : + proposition := + match s with + | D_left :: l => + match p with + | Tor x y => extract_hyp_neg l x + | Timp x y => if decidability x then extract_hyp_pos l x else Tnot p + | _ => Tnot p + end + | D_right :: l => + match p with + | Tor x y => extract_hyp_neg l y + | Timp x y => extract_hyp_neg l y + | _ => Tnot p + end + | D_mono :: l => + match p with + | Tnot x => if decidability x then extract_hyp_pos l x else Tnot p + | _ => Tnot p + end + | _ => + match p with + | Tnot x => if decidability x then x else Tnot p + | _ => Tnot p + end + end. + +Definition co_valid1 (f : proposition -> proposition) := + forall (ep : list Prop) (e : list int) (p1 : proposition), + interp_proposition ep e (Tnot p1) -> interp_proposition ep e (f p1). + +Theorem extract_valid : + forall s : list direction, + valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s). +Proof. + unfold valid1, co_valid1 in |- *; simple induction s; + [ split; + [ simpl in |- *; auto + | intros ep e p1; case p1; simpl in |- *; auto; intro p; + pattern (decidability p) in |- *; apply bool_eq_ind; + [ intro H; generalize (decidable_correct ep e p H); + unfold decidable in |- *; tauto + | simpl in |- *; auto ] ] + | intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto; + case p; auto; simpl in |- *; intros; + (apply H1; tauto) || + (apply H2; tauto) || + (pattern (decidability p0) in |- *; apply bool_eq_ind; + [ intro H3; generalize (decidable_correct ep e p0 H3); + unfold decidable in |- *; intro H4; apply H1; + tauto + | intro; tauto ]) ]. +Qed. + +Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := + match s with + | E_SPLIT i dl s1 s2 => + match extract_hyp_pos dl (nth_hyps i h) with + | Tor x y => decompose_solve s1 (x :: h) ++ decompose_solve s2 (y :: h) + | Tnot (Tand x y) => + if decidability x + then + decompose_solve s1 (Tnot x :: h) ++ + decompose_solve s2 (Tnot y :: h) + else h :: nil + | Timp x y => + if decidability x then + decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h) + else h::nil + | _ => h :: nil + end + | E_EXTRACT i dl s1 => + decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h) + | E_SOLVE t => execute_omega t h + end. + +Theorem decompose_solve_valid : + forall s : e_step, valid_list_goal (decompose_solve s). +Proof. + intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s; + simpl in |- *; intros; + [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))); + [ case (extract_hyp_pos l (nth_hyps n lp)); simpl in |- *; auto; + [ intro p; case p; simpl in |- *; auto; intros p1 p2 H2; + pattern (decidability p1) in |- *; apply bool_eq_ind; + [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; + apply append_valid; elim H4; intro H5; + [ right; apply H0; simpl in |- *; tauto + | left; apply H; simpl in |- *; tauto ] + | simpl in |- *; auto ] + | intros p1 p2 H2; apply append_valid; simpl in |- *; elim H2; + [ intros H3; left; apply H; simpl in |- *; auto + | intros H3; right; apply H0; simpl in |- *; auto ] + | intros p1 p2 H2; + pattern (decidability p1) in |- *; apply bool_eq_ind; + [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; + apply append_valid; elim H4; intro H5; + [ right; apply H0; simpl in |- *; tauto + | left; apply H; simpl in |- *; tauto ] + | simpl in |- *; auto ] ] + | elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto ] + | intros; apply H; simpl in |- *; split; + [ elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto + | auto ] + | apply omega_valid with (1 := H) ]. +Qed. + +(* \subsection{La dernière étape qui élimine tous les séquents inutiles} *) + +Definition valid_lhyps (f : lhyps -> lhyps) := + forall (ep : list Prop) (e : list int) (lp : lhyps), + interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp). + +Fixpoint reduce_lhyps (lp : lhyps) : lhyps := + match lp with + | (FalseTerm :: nil) :: lp' => reduce_lhyps lp' + | x :: lp' => x :: reduce_lhyps lp' + | nil => nil (A:=hyps) + end. + +Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. +Proof. + unfold valid_lhyps in |- *; intros ep e lp; elim lp; + [ simpl in |- *; auto + | intros a l HR; elim a; + [ simpl in |- *; tauto + | intros a1 l1; case l1; case a1; simpl in |- *; try tauto ] ]. +Qed. + +Theorem do_reduce_lhyps : + forall (envp : list Prop) (env : list int) (l : lhyps), + interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l. +Proof. + intros envp env l H; apply list_goal_to_hyps; intro H1; + apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; + assumption. +Qed. + +Definition concl_to_hyp (p : proposition) := + if decidability p then Tnot p else TrueTerm. + +Definition do_concl_to_hyp : + forall (envp : list Prop) (env : list int) (c : proposition) (l : hyps), + interp_goal envp env (concl_to_hyp c :: l) -> + interp_goal_concl c envp env l. +Proof. + simpl in |- *; intros envp env c l; induction l as [| a l Hrecl]; + [ simpl in |- *; unfold concl_to_hyp in |- *; + pattern (decidability c) in |- *; apply bool_eq_ind; + [ intro H; generalize (decidable_correct envp env c H); + unfold decidable in |- *; simpl in |- *; tauto + | simpl in |- *; intros H1 H2; elim H2; trivial ] + | simpl in |- *; tauto ]. +Qed. + +Definition omega_tactic (t1 : e_step) (t2 : list h_step) + (c : proposition) (l : hyps) := + reduce_lhyps (decompose_solve t1 (normalize_hyps t2 (concl_to_hyp c :: l))). + +Theorem do_omega : + forall (t1 : e_step) (t2 : list h_step) (envp : list Prop) + (env : list int) (c : proposition) (l : hyps), + interp_list_goal envp env (omega_tactic t1 t2 c l) -> + interp_goal_concl c envp env l. +Proof. + unfold omega_tactic in |- *; intros; apply do_concl_to_hyp; + apply (normalize_hyps_goal t2); apply (decompose_solve_valid t1); + apply do_reduce_lhyps; assumption. +Qed. + +End IntOmega. + +(* For now, the above modular construction is instanciated on Z, + in order to retrieve the initial ROmega. *) + +Module ZOmega := IntOmega(Z_as_Int). diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml new file mode 100644 index 00000000..f4368a1b --- /dev/null +++ b/plugins/romega/const_omega.ml @@ -0,0 +1,352 @@ +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence : LGPL version 2.1 + + *************************************************************************) + +let module_refl_name = "ReflOmegaCore" +let module_refl_path = ["Coq"; "romega"; module_refl_name] + +type result = + Kvar of string + | Kapp of string * Term.constr list + | Kimp of Term.constr * Term.constr + | Kufo;; + +let destructurate t = + let c, args = Term.decompose_app t in + match Term.kind_of_term c, args with + | Term.Const sp, args -> + Kapp (Names.string_of_id + (Nametab.basename_of_global (Libnames.ConstRef sp)), + args) + | Term.Construct csp , args -> + Kapp (Names.string_of_id + (Nametab.basename_of_global (Libnames.ConstructRef csp)), + args) + | Term.Ind isp, args -> + Kapp (Names.string_of_id + (Nametab.basename_of_global (Libnames.IndRef isp)), + args) + | Term.Var id,[] -> Kvar(Names.string_of_id id) + | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) + | Term.Prod (Names.Name _,_,_),[] -> + Util.error "Omega: Not a quantifier-free goal" + | _ -> Kufo + +exception Destruct + +let dest_const_apply t = + let f,args = Term.decompose_app t in + let ref = + match Term.kind_of_term f with + | Term.Const sp -> Libnames.ConstRef sp + | Term.Construct csp -> Libnames.ConstructRef csp + | Term.Ind isp -> Libnames.IndRef isp + | _ -> raise Destruct + in Nametab.basename_of_global ref, args + +let logic_dir = ["Coq";"Logic";"Decidable"] + +let coq_modules = + Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules + @ [["Coq"; "Lists"; "List"]] + @ [module_refl_path] + @ [module_refl_path@["ZOmega"]] + + +let init_constant = Coqlib.gen_constant_in_modules "Omega" Coqlib.init_modules +let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules + +(* Logic *) +let coq_eq = lazy(init_constant "eq") +let coq_refl_equal = lazy(init_constant "eq_refl") +let coq_and = lazy(init_constant "and") +let coq_not = lazy(init_constant "not") +let coq_or = lazy(init_constant "or") +let coq_True = lazy(init_constant "True") +let coq_False = lazy(init_constant "False") +let coq_I = lazy(init_constant "I") + +(* ReflOmegaCore/ZOmega *) + +let coq_h_step = lazy (constant "h_step") +let coq_pair_step = lazy (constant "pair_step") +let coq_p_left = lazy (constant "P_LEFT") +let coq_p_right = lazy (constant "P_RIGHT") +let coq_p_invert = lazy (constant "P_INVERT") +let coq_p_step = lazy (constant "P_STEP") + +let coq_t_int = lazy (constant "Tint") +let coq_t_plus = lazy (constant "Tplus") +let coq_t_mult = lazy (constant "Tmult") +let coq_t_opp = lazy (constant "Topp") +let coq_t_minus = lazy (constant "Tminus") +let coq_t_var = lazy (constant "Tvar") + +let coq_proposition = lazy (constant "proposition") +let coq_p_eq = lazy (constant "EqTerm") +let coq_p_leq = lazy (constant "LeqTerm") +let coq_p_geq = lazy (constant "GeqTerm") +let coq_p_lt = lazy (constant "LtTerm") +let coq_p_gt = lazy (constant "GtTerm") +let coq_p_neq = lazy (constant "NeqTerm") +let coq_p_true = lazy (constant "TrueTerm") +let coq_p_false = lazy (constant "FalseTerm") +let coq_p_not = lazy (constant "Tnot") +let coq_p_or = lazy (constant "Tor") +let coq_p_and = lazy (constant "Tand") +let coq_p_imp = lazy (constant "Timp") +let coq_p_prop = lazy (constant "Tprop") + +(* Constructors for shuffle tactic *) +let coq_t_fusion = lazy (constant "t_fusion") +let coq_f_equal = lazy (constant "F_equal") +let coq_f_cancel = lazy (constant "F_cancel") +let coq_f_left = lazy (constant "F_left") +let coq_f_right = lazy (constant "F_right") + +(* Constructors for reordering tactics *) +let coq_c_do_both = lazy (constant "C_DO_BOTH") +let coq_c_do_left = lazy (constant "C_LEFT") +let coq_c_do_right = lazy (constant "C_RIGHT") +let coq_c_do_seq = lazy (constant "C_SEQ") +let coq_c_nop = lazy (constant "C_NOP") +let coq_c_opp_plus = lazy (constant "C_OPP_PLUS") +let coq_c_opp_opp = lazy (constant "C_OPP_OPP") +let coq_c_opp_mult_r = lazy (constant "C_OPP_MULT_R") +let coq_c_opp_one = lazy (constant "C_OPP_ONE") +let coq_c_reduce = lazy (constant "C_REDUCE") +let coq_c_mult_plus_distr = lazy (constant "C_MULT_PLUS_DISTR") +let coq_c_opp_left = lazy (constant "C_MULT_OPP_LEFT") +let coq_c_mult_assoc_r = lazy (constant "C_MULT_ASSOC_R") +let coq_c_plus_assoc_r = lazy (constant "C_PLUS_ASSOC_R") +let coq_c_plus_assoc_l = lazy (constant "C_PLUS_ASSOC_L") +let coq_c_plus_permute = lazy (constant "C_PLUS_PERMUTE") +let coq_c_plus_comm = lazy (constant "C_PLUS_COMM") +let coq_c_red0 = lazy (constant "C_RED0") +let coq_c_red1 = lazy (constant "C_RED1") +let coq_c_red2 = lazy (constant "C_RED2") +let coq_c_red3 = lazy (constant "C_RED3") +let coq_c_red4 = lazy (constant "C_RED4") +let coq_c_red5 = lazy (constant "C_RED5") +let coq_c_red6 = lazy (constant "C_RED6") +let coq_c_mult_opp_left = lazy (constant "C_MULT_OPP_LEFT") +let coq_c_mult_assoc_reduced = lazy (constant "C_MULT_ASSOC_REDUCED") +let coq_c_minus = lazy (constant "C_MINUS") +let coq_c_mult_comm = lazy (constant "C_MULT_COMM") + +let coq_s_constant_not_nul = lazy (constant "O_CONSTANT_NOT_NUL") +let coq_s_constant_neg = lazy (constant "O_CONSTANT_NEG") +let coq_s_div_approx = lazy (constant "O_DIV_APPROX") +let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE") +let coq_s_exact_divide = lazy (constant "O_EXACT_DIVIDE") +let coq_s_sum = lazy (constant "O_SUM") +let coq_s_state = lazy (constant "O_STATE") +let coq_s_contradiction = lazy (constant "O_CONTRADICTION") +let coq_s_merge_eq = lazy (constant "O_MERGE_EQ") +let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ") +let coq_s_constant_nul =lazy (constant "O_CONSTANT_NUL") +let coq_s_negate_contradict =lazy (constant "O_NEGATE_CONTRADICT") +let coq_s_negate_contradict_inv =lazy (constant "O_NEGATE_CONTRADICT_INV") + +(* construction for the [extract_hyp] tactic *) +let coq_direction = lazy (constant "direction") +let coq_d_left = lazy (constant "D_left") +let coq_d_right = lazy (constant "D_right") +let coq_d_mono = lazy (constant "D_mono") + +let coq_e_split = lazy (constant "E_SPLIT") +let coq_e_extract = lazy (constant "E_EXTRACT") +let coq_e_solve = lazy (constant "E_SOLVE") + +let coq_interp_sequent = lazy (constant "interp_goal_concl") +let coq_do_omega = lazy (constant "do_omega") + +(* \subsection{Construction d'expressions} *) + +let do_left t = + if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop + else Term.mkApp (Lazy.force coq_c_do_left, [|t |] ) + +let do_right t = + if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop + else Term.mkApp (Lazy.force coq_c_do_right, [|t |]) + +let do_both t1 t2 = + if t1 = Lazy.force coq_c_nop then do_right t2 + else if t2 = Lazy.force coq_c_nop then do_left t1 + else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |]) + +let do_seq t1 t2 = + if t1 = Lazy.force coq_c_nop then t2 + else if t2 = Lazy.force coq_c_nop then t1 + else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |]) + +let rec do_list = function + | [] -> Lazy.force coq_c_nop + | [x] -> x + | (x::l) -> do_seq x (do_list l) + +(* Nat *) + +let coq_S = lazy(init_constant "S") +let coq_O = lazy(init_constant "O") + +let rec mk_nat = function + | 0 -> Lazy.force coq_O + | n -> Term.mkApp (Lazy.force coq_S, [| mk_nat (n-1) |]) + +(* Lists *) + +let coq_cons = lazy (constant "cons") +let coq_nil = lazy (constant "nil") + +let mk_list typ l = + let rec loop = function + | [] -> + Term.mkApp (Lazy.force coq_nil, [|typ|]) + | (step :: l) -> + Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in + loop l + +let mk_plist l = mk_list Term.mkProp l + +let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l + + +type parse_term = + | Tplus of Term.constr * Term.constr + | Tmult of Term.constr * Term.constr + | Tminus of Term.constr * Term.constr + | Topp of Term.constr + | Tsucc of Term.constr + | Tnum of Bigint.bigint + | Tother + +type parse_rel = + | Req of Term.constr * Term.constr + | Rne of Term.constr * Term.constr + | Rlt of Term.constr * Term.constr + | Rle of Term.constr * Term.constr + | Rgt of Term.constr * Term.constr + | Rge of Term.constr * Term.constr + | Rtrue + | Rfalse + | Rnot of Term.constr + | Ror of Term.constr * Term.constr + | Rand of Term.constr * Term.constr + | Rimp of Term.constr * Term.constr + | Riff of Term.constr * Term.constr + | Rother + +let parse_logic_rel c = + try match destructurate c with + | Kapp("True",[]) -> Rtrue + | Kapp("False",[]) -> Rfalse + | Kapp("not",[t]) -> Rnot t + | Kapp("or",[t1;t2]) -> Ror (t1,t2) + | Kapp("and",[t1;t2]) -> Rand (t1,t2) + | Kimp(t1,t2) -> Rimp (t1,t2) + | Kapp("iff",[t1;t2]) -> Riff (t1,t2) + | _ -> Rother + with e when Logic.catchable_exception e -> Rother + + +module type Int = sig + val typ : Term.constr Lazy.t + val plus : Term.constr Lazy.t + val mult : Term.constr Lazy.t + val opp : Term.constr Lazy.t + val minus : Term.constr Lazy.t + + val mk : Bigint.bigint -> Term.constr + val parse_term : Term.constr -> parse_term + val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel + (* check whether t is built only with numbers and + * - *) + val is_scalar : Term.constr -> bool +end + +module Z : Int = struct + +let typ = lazy (constant "Z") +let plus = lazy (constant "Zplus") +let mult = lazy (constant "Zmult") +let opp = lazy (constant "Zopp") +let minus = lazy (constant "Zminus") + +let coq_xH = lazy (constant "xH") +let coq_xO = lazy (constant "xO") +let coq_xI = lazy (constant "xI") +let coq_Z0 = lazy (constant "Z0") +let coq_Zpos = lazy (constant "Zpos") +let coq_Zneg = lazy (constant "Zneg") + +let recognize t = + let rec loop t = + let f,l = dest_const_apply t in + match Names.string_of_id f,l with + "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) + | "xO",[t] -> Bigint.mult Bigint.two (loop t) + | "xH",[] -> Bigint.one + | _ -> failwith "not a number" in + let f,l = dest_const_apply t in + match Names.string_of_id f,l with + "Zpos",[t] -> loop t + | "Zneg",[t] -> Bigint.neg (loop t) + | "Z0",[] -> Bigint.zero + | _ -> failwith "not a number";; + +let rec mk_positive n = + if n=Bigint.one then Lazy.force coq_xH + else + let (q,r) = Bigint.euclid n Bigint.two in + Term.mkApp + ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI), + [| mk_positive q |]) + +let mk_Z n = + if n = Bigint.zero then Lazy.force coq_Z0 + else if Bigint.is_strictly_pos n then + Term.mkApp (Lazy.force coq_Zpos, [| mk_positive n |]) + else + Term.mkApp (Lazy.force coq_Zneg, [| mk_positive (Bigint.neg n) |]) + +let mk = mk_Z + +let parse_term t = + try match destructurate t with + | Kapp("Zplus",[t1;t2]) -> Tplus (t1,t2) + | Kapp("Zminus",[t1;t2]) -> Tminus (t1,t2) + | Kapp("Zmult",[t1;t2]) -> Tmult (t1,t2) + | Kapp("Zopp",[t]) -> Topp t + | Kapp("Zsucc",[t]) -> Tsucc t + | Kapp("Zpred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) + | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> + (try Tnum (recognize t) with _ -> Tother) + | _ -> Tother + with e when Logic.catchable_exception e -> Tother + +let parse_rel gl t = + try match destructurate t with + | Kapp("eq",[typ;t1;t2]) + when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> Req (t1,t2) + | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) + | Kapp("Zle",[t1;t2]) -> Rle (t1,t2) + | Kapp("Zlt",[t1;t2]) -> Rlt (t1,t2) + | Kapp("Zge",[t1;t2]) -> Rge (t1,t2) + | Kapp("Zgt",[t1;t2]) -> Rgt (t1,t2) + | _ -> parse_logic_rel t + with e when Logic.catchable_exception e -> Rother + +let is_scalar t = + let rec aux t = match destructurate t with + | Kapp(("Zplus"|"Zminus"|"Zmult"),[t1;t2]) -> aux t1 & aux t2 + | Kapp(("Zopp"|"Zsucc"|"Zpred"),[t]) -> aux t + | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true + | _ -> false in + try aux t with _ -> false + +end diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli new file mode 100644 index 00000000..b8db71e4 --- /dev/null +++ b/plugins/romega/const_omega.mli @@ -0,0 +1,176 @@ +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence : LGPL version 2.1 + + *************************************************************************) + + +(** Coq objects used in romega *) + +(* from Logic *) +val coq_refl_equal : Term.constr lazy_t +val coq_and : Term.constr lazy_t +val coq_not : Term.constr lazy_t +val coq_or : Term.constr lazy_t +val coq_True : Term.constr lazy_t +val coq_False : Term.constr lazy_t +val coq_I : Term.constr lazy_t + +(* from ReflOmegaCore/ZOmega *) +val coq_h_step : Term.constr lazy_t +val coq_pair_step : Term.constr lazy_t +val coq_p_left : Term.constr lazy_t +val coq_p_right : Term.constr lazy_t +val coq_p_invert : Term.constr lazy_t +val coq_p_step : Term.constr lazy_t + +val coq_t_int : Term.constr lazy_t +val coq_t_plus : Term.constr lazy_t +val coq_t_mult : Term.constr lazy_t +val coq_t_opp : Term.constr lazy_t +val coq_t_minus : Term.constr lazy_t +val coq_t_var : Term.constr lazy_t + +val coq_proposition : Term.constr lazy_t +val coq_p_eq : Term.constr lazy_t +val coq_p_leq : Term.constr lazy_t +val coq_p_geq : Term.constr lazy_t +val coq_p_lt : Term.constr lazy_t +val coq_p_gt : Term.constr lazy_t +val coq_p_neq : Term.constr lazy_t +val coq_p_true : Term.constr lazy_t +val coq_p_false : Term.constr lazy_t +val coq_p_not : Term.constr lazy_t +val coq_p_or : Term.constr lazy_t +val coq_p_and : Term.constr lazy_t +val coq_p_imp : Term.constr lazy_t +val coq_p_prop : Term.constr lazy_t + +val coq_f_equal : Term.constr lazy_t +val coq_f_cancel : Term.constr lazy_t +val coq_f_left : Term.constr lazy_t +val coq_f_right : Term.constr lazy_t + +val coq_c_do_both : Term.constr lazy_t +val coq_c_do_left : Term.constr lazy_t +val coq_c_do_right : Term.constr lazy_t +val coq_c_do_seq : Term.constr lazy_t +val coq_c_nop : Term.constr lazy_t +val coq_c_opp_plus : Term.constr lazy_t +val coq_c_opp_opp : Term.constr lazy_t +val coq_c_opp_mult_r : Term.constr lazy_t +val coq_c_opp_one : Term.constr lazy_t +val coq_c_reduce : Term.constr lazy_t +val coq_c_mult_plus_distr : Term.constr lazy_t +val coq_c_opp_left : Term.constr lazy_t +val coq_c_mult_assoc_r : Term.constr lazy_t +val coq_c_plus_assoc_r : Term.constr lazy_t +val coq_c_plus_assoc_l : Term.constr lazy_t +val coq_c_plus_permute : Term.constr lazy_t +val coq_c_plus_comm : Term.constr lazy_t +val coq_c_red0 : Term.constr lazy_t +val coq_c_red1 : Term.constr lazy_t +val coq_c_red2 : Term.constr lazy_t +val coq_c_red3 : Term.constr lazy_t +val coq_c_red4 : Term.constr lazy_t +val coq_c_red5 : Term.constr lazy_t +val coq_c_red6 : Term.constr lazy_t +val coq_c_mult_opp_left : Term.constr lazy_t +val coq_c_mult_assoc_reduced : Term.constr lazy_t +val coq_c_minus : Term.constr lazy_t +val coq_c_mult_comm : Term.constr lazy_t + +val coq_s_constant_not_nul : Term.constr lazy_t +val coq_s_constant_neg : Term.constr lazy_t +val coq_s_div_approx : Term.constr lazy_t +val coq_s_not_exact_divide : Term.constr lazy_t +val coq_s_exact_divide : Term.constr lazy_t +val coq_s_sum : Term.constr lazy_t +val coq_s_state : Term.constr lazy_t +val coq_s_contradiction : Term.constr lazy_t +val coq_s_merge_eq : Term.constr lazy_t +val coq_s_split_ineq : Term.constr lazy_t +val coq_s_constant_nul : Term.constr lazy_t +val coq_s_negate_contradict : Term.constr lazy_t +val coq_s_negate_contradict_inv : Term.constr lazy_t + +val coq_direction : Term.constr lazy_t +val coq_d_left : Term.constr lazy_t +val coq_d_right : Term.constr lazy_t +val coq_d_mono : Term.constr lazy_t + +val coq_e_split : Term.constr lazy_t +val coq_e_extract : Term.constr lazy_t +val coq_e_solve : Term.constr lazy_t + +val coq_interp_sequent : Term.constr lazy_t +val coq_do_omega : Term.constr lazy_t + +(** Building expressions *) + +val do_left : Term.constr -> Term.constr +val do_right : Term.constr -> Term.constr +val do_both : Term.constr -> Term.constr -> Term.constr +val do_seq : Term.constr -> Term.constr -> Term.constr +val do_list : Term.constr list -> Term.constr + +val mk_nat : int -> Term.constr +val mk_list : Term.constr -> Term.constr list -> Term.constr +val mk_plist : Term.types list -> Term.types +val mk_shuffle_list : Term.constr list -> Term.constr + +(** Analyzing a coq term *) + +(* The generic result shape of the analysis of a term. + One-level depth, except when a number is found *) +type parse_term = + Tplus of Term.constr * Term.constr + | Tmult of Term.constr * Term.constr + | Tminus of Term.constr * Term.constr + | Topp of Term.constr + | Tsucc of Term.constr + | Tnum of Bigint.bigint + | Tother + +(* The generic result shape of the analysis of a relation. + One-level depth. *) +type parse_rel = + Req of Term.constr * Term.constr + | Rne of Term.constr * Term.constr + | Rlt of Term.constr * Term.constr + | Rle of Term.constr * Term.constr + | Rgt of Term.constr * Term.constr + | Rge of Term.constr * Term.constr + | Rtrue + | Rfalse + | Rnot of Term.constr + | Ror of Term.constr * Term.constr + | Rand of Term.constr * Term.constr + | Rimp of Term.constr * Term.constr + | Riff of Term.constr * Term.constr + | Rother + +(* A module factorizing what we should now about the number representation *) +module type Int = + sig + (* the coq type of the numbers *) + val typ : Term.constr Lazy.t + (* the operations on the numbers *) + val plus : Term.constr Lazy.t + val mult : Term.constr Lazy.t + val opp : Term.constr Lazy.t + val minus : Term.constr Lazy.t + (* building a coq number *) + val mk : Bigint.bigint -> Term.constr + (* parsing a term (one level, except if a number is found) *) + val parse_term : Term.constr -> parse_term + (* parsing a relation expression, including = < <= >= > *) + val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel + (* Is a particular term only made of numbers and + * - ? *) + val is_scalar : Term.constr -> bool + end + +(* Currently, we only use Z numbers *) +module Z : Int diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 new file mode 100644 index 00000000..2db86e00 --- /dev/null +++ b/plugins/romega/g_romega.ml4 @@ -0,0 +1,42 @@ +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence : LGPL version 2.1 + + *************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +open Refl_omega +open Refiner + +let romega_tactic l = + let tacs = List.map + (function + | "nat" -> Tacinterp.interp <:tactic> + | "positive" -> Tacinterp.interp <:tactic> + | "N" -> Tacinterp.interp <:tactic> + | "Z" -> Tacinterp.interp <:tactic> + | s -> Util.error ("No ROmega knowledge base for type "^s)) + (Util.list_uniquize (List.sort compare l)) + in + tclTHEN + (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) + (tclTHEN + (* because of the contradiction process in (r)omega, + we'd better leave as little as possible in the conclusion, + for an easier decidability argument. *) + Tactics.intros + total_reflexive_omega_tactic) + + +TACTIC EXTEND romega +| [ "romega" ] -> [ romega_tactic [] ] +END + +TACTIC EXTEND romega' +| [ "romega" "with" ne_ident_list(l) ] -> + [ romega_tactic (List.map Names.string_of_id l) ] +| [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ] +END diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml new file mode 100644 index 00000000..570bb187 --- /dev/null +++ b/plugins/romega/refl_omega.ml @@ -0,0 +1,1299 @@ +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence : LGPL version 2.1 + + *************************************************************************) + +open Util +open Const_omega +module OmegaSolver = Omega.MakeOmegaSolver (Bigint) +open OmegaSolver + +(* \section{Useful functions and flags} *) +(* Especially useful debugging functions *) +let debug = ref false + +let show_goal gl = + if !debug then Pp.ppnl (Tacmach.pr_gls gl); Tacticals.tclIDTAC gl + +let pp i = print_int i; print_newline (); flush stdout + +(* More readable than the prefix notation *) +let (>>) = Tacticals.tclTHEN + +let mkApp = Term.mkApp + +(* \section{Types} + \subsection{How to walk in a term} + To represent how to get to a proposition. Only choice points are + kept (branch to choose in a disjunction and identifier of the disjunctive + connector) *) +type direction = Left of int | Right of int + +(* Step to find a proposition (operators are at most binary). A list is + a path *) +type occ_step = O_left | O_right | O_mono +type occ_path = occ_step list + +(* chemin identifiant une proposition sous forme du nom de l'hypothèse et + d'une liste de pas à partir de la racine de l'hypothèse *) +type occurence = {o_hyp : Names.identifier; o_path : occ_path} + +(* \subsection{refiable formulas} *) +type oformula = + (* integer *) + | Oint of Bigint.bigint + (* recognized binary and unary operations *) + | Oplus of oformula * oformula + | Omult of oformula * oformula + | Ominus of oformula * oformula + | Oopp of oformula + (* an atome in the environment *) + | Oatom of int + (* weird expression that cannot be translated *) + | Oufo of oformula + +(* Operators for comparison recognized by Omega *) +type comparaison = Eq | Leq | Geq | Gt | Lt | Neq + +(* Type des prédicats réifiés (fragment de calcul propositionnel. Les + * quantifications sont externes au langage) *) +type oproposition = + Pequa of Term.constr * oequation + | Ptrue + | Pfalse + | Pnot of oproposition + | Por of int * oproposition * oproposition + | Pand of int * oproposition * oproposition + | Pimp of int * oproposition * oproposition + | Pprop of Term.constr + +(* Les équations ou proposiitions atomiques utiles du calcul *) +and oequation = { + e_comp: comparaison; (* comparaison *) + e_left: oformula; (* formule brute gauche *) + e_right: oformula; (* formule brute droite *) + e_trace: Term.constr; (* tactique de normalisation *) + e_origin: occurence; (* l'hypothèse dont vient le terme *) + e_negated: bool; (* vrai si apparait en position nié + après normalisation *) + e_depends: direction list; (* liste des points de disjonction dont + dépend l'accès à l'équation avec la + direction (branche) pour y accéder *) + e_omega: afine (* la fonction normalisée *) + } + +(* \subsection{Proof context} + This environment codes + \begin{itemize} + \item the terms and propositions that are given as + parameters of the reified proof (and are represented as variables in the + reified goals) + \item translation functions linking the decision procedure and the Coq proof + \end{itemize} *) + +type environment = { + (* La liste des termes non reifies constituant l'environnement global *) + mutable terms : Term.constr list; + (* La meme chose pour les propositions *) + mutable props : Term.constr list; + (* Les variables introduites par omega *) + mutable om_vars : (oformula * int) list; + (* Traduction des indices utilisés ici en les indices finaux utilisés par + * la tactique Omega après dénombrement des variables utiles *) + real_indices : (int,int) Hashtbl.t; + mutable cnt_connectors : int; + equations : (int,oequation) Hashtbl.t; + constructors : (int, occurence) Hashtbl.t +} + +(* \subsection{Solution tree} + Définition d'une solution trouvée par Omega sous la forme d'un identifiant, + d'un ensemble d'équation dont dépend la solution et d'une trace *) +(* La liste des dépendances est triée et sans redondance *) +type solution = { + s_index : int; + s_equa_deps : int list; + s_trace : action list } + +(* Arbre de solution résolvant complètement un ensemble de systèmes *) +type solution_tree = + Leaf of solution + (* un noeud interne représente un point de branchement correspondant à + l'élimination d'un connecteur générant plusieurs buts + (typ. disjonction). Le premier argument + est l'identifiant du connecteur *) + | Tree of int * solution_tree * solution_tree + +(* Représentation de l'environnement extrait du but initial sous forme de + chemins pour extraire des equations ou d'hypothèses *) + +type context_content = + CCHyp of occurence + | CCEqua of int + +(* \section{Specific utility functions to handle base types} *) +(* Nom arbitraire de l'hypothèse codant la négation du but final *) +let id_concl = Names.id_of_string "__goal__" + +(* Initialisation de l'environnement de réification de la tactique *) +let new_environment () = { + terms = []; props = []; om_vars = []; cnt_connectors = 0; + real_indices = Hashtbl.create 7; + equations = Hashtbl.create 7; + constructors = Hashtbl.create 7; +} + +(* Génération d'un nom d'équation *) +let new_connector_id env = + env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors + +(* Calcul de la branche complémentaire *) +let barre = function Left x -> Right x | Right x -> Left x + +(* Identifiant associé à une branche *) +let indice = function Left x | Right x -> x + +(* Affichage de l'environnement de réification (termes et propositions) *) +let print_env_reification env = + let rec loop c i = function + [] -> Printf.printf " ===============================\n\n" + | t :: l -> + Printf.printf " (%c%02d) := " c i; + Pp.ppnl (Printer.pr_lconstr t); + Pp.flush_all (); + loop c (succ i) l in + print_newline (); + Printf.printf " ENVIRONMENT OF PROPOSITIONS :\n\n"; loop 'P' 0 env.props; + Printf.printf " ENVIRONMENT OF TERMS :\n\n"; loop 'V' 0 env.terms + + +(* \subsection{Gestion des environnements de variable pour Omega} *) +(* generation d'identifiant d'equation pour Omega *) + +let new_omega_eq, rst_omega_eq = + let cpt = ref 0 in + (function () -> incr cpt; !cpt), + (function () -> cpt:=0) + +(* generation d'identifiant de variable pour Omega *) + +let new_omega_var, rst_omega_var = + let cpt = ref 0 in + (function () -> incr cpt; !cpt), + (function () -> cpt:=0) + +(* Affichage des variables d'un système *) + +let display_omega_var i = Printf.sprintf "OV%d" i + +(* Recherche la variable codant un terme pour Omega et crée la variable dans + l'environnement si il n'existe pas. Cas ou la variable dans Omega représente + le terme d'un monome (le plus souvent un atome) *) + +let intern_omega env t = + begin try List.assoc t env.om_vars + with Not_found -> + let v = new_omega_var () in + env.om_vars <- (t,v) :: env.om_vars; v + end + +(* Ajout forcé d'un lien entre un terme et une variable Cas où la + variable est créée par Omega et où il faut la lier après coup à un atome + réifié introduit de force *) +let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars + +(* Récupère le terme associé à une variable *) +let unintern_omega env id = + let rec loop = function + [] -> failwith "unintern" + | ((t,j)::l) -> if id = j then t else loop l in + loop env.om_vars + +(* \subsection{Gestion des environnements de variable pour la réflexion} + Gestion des environnements de traduction entre termes des constructions + non réifiés et variables des termes reifies. Attention il s'agit de + l'environnement initial contenant tout. Il faudra le réduire après + calcul des variables utiles. *) + +let add_reified_atom t env = + try list_index0 t env.terms + with Not_found -> + let i = List.length env.terms in + env.terms <- env.terms @ [t]; i + +let get_reified_atom env = + try List.nth env.terms with _ -> failwith "get_reified_atom" + +(* \subsection{Gestion de l'environnement de proposition pour Omega} *) +(* ajout d'une proposition *) +let add_prop env t = + try list_index0 t env.props + with Not_found -> + let i = List.length env.props in env.props <- env.props @ [t]; i + +(* accès a une proposition *) +let get_prop v env = try List.nth v env with _ -> failwith "get_prop" + +(* \subsection{Gestion du nommage des équations} *) +(* Ajout d'une equation dans l'environnement de reification *) +let add_equation env e = + let id = e.e_omega.id in + try let _ = Hashtbl.find env.equations id in () + with Not_found -> Hashtbl.add env.equations id e + +(* accès a une equation *) +let get_equation env id = + try Hashtbl.find env.equations id + with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e + +(* Affichage des termes réifiés *) +let rec oprint ch = function + | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n) + | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2 + | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 + | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 + | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1 + | Oatom n -> Printf.fprintf ch "V%02d" n + | Oufo x -> Printf.fprintf ch "?" + +let rec pprint ch = function + Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) -> + let connector = + match comp with + Eq -> "=" | Leq -> "<=" | Geq -> ">=" + | Gt -> ">" | Lt -> "<" | Neq -> "!=" in + Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2 + | Ptrue -> Printf.fprintf ch "TT" + | Pfalse -> Printf.fprintf ch "FF" + | Pnot t -> Printf.fprintf ch "not(%a)" pprint t + | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2 + | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2 + | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 + | Pprop c -> Printf.fprintf ch "Prop" + +let rec weight env = function + | Oint _ -> -1 + | Oopp c -> weight env c + | Omult(c,_) -> weight env c + | Oplus _ -> failwith "weight" + | Ominus _ -> failwith "weight minus" + | Oufo _ -> -1 + | Oatom _ as c -> (intern_omega env c) + +(* \section{Passage entre oformules et représentation interne de Omega} *) + +(* \subsection{Oformula vers Omega} *) + +let omega_of_oformula env kind = + let rec loop accu = function + | Oplus(Omult(v,Oint n),r) -> + loop ({v=intern_omega env v; c=n} :: accu) r + | Oint n -> + let id = new_omega_eq () in + (*i tag_equation name id; i*) + {kind = kind; body = List.rev accu; + constant = n; id = id} + | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in + loop [] + +(* \subsection{Omega vers Oformula} *) + +let rec oformula_of_omega env af = + let rec loop = function + | ({v=v; c=n}::r) -> + Oplus(Omult(unintern_omega env v,Oint n),loop r) + | [] -> Oint af.constant in + loop af.body + +let app f v = mkApp(Lazy.force f,v) + +(* \subsection{Oformula vers COQ reel} *) + +let rec coq_of_formula env t = + let rec loop = function + | Oplus (t1,t2) -> app Z.plus [| loop t1; loop t2 |] + | Oopp t -> app Z.opp [| loop t |] + | Omult(t1,t2) -> app Z.mult [| loop t1; loop t2 |] + | Oint v -> Z.mk v + | Oufo t -> loop t + | Oatom var -> + (* attention ne traite pas les nouvelles variables si on ne les + * met pas dans env.term *) + get_reified_atom env var + | Ominus(t1,t2) -> app Z.minus [| loop t1; loop t2 |] in + loop t + +(* \subsection{Oformula vers COQ reifié} *) + +let reified_of_atom env i = + try Hashtbl.find env.real_indices i + with Not_found -> + Printf.printf "Atome %d non trouvé\n" i; + Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; + raise Not_found + +let rec reified_of_formula env = function + | Oplus (t1,t2) -> + app coq_t_plus [| reified_of_formula env t1; reified_of_formula env t2 |] + | Oopp t -> + app coq_t_opp [| reified_of_formula env t |] + | Omult(t1,t2) -> + app coq_t_mult [| reified_of_formula env t1; reified_of_formula env t2 |] + | Oint v -> app coq_t_int [| Z.mk v |] + | Oufo t -> reified_of_formula env t + | Oatom i -> app coq_t_var [| mk_nat (reified_of_atom env i) |] + | Ominus(t1,t2) -> + app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |] + +let reified_of_formula env f = + begin try reified_of_formula env f with e -> oprint stderr f; raise e end + +let rec reified_of_proposition env = function + Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> + app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |] + | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> + app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |] + | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> + app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |] + | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> + app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |] + | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) -> + app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |] + | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> + app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |] + | Ptrue -> Lazy.force coq_p_true + | Pfalse -> Lazy.force coq_p_false + | Pnot t -> + app coq_p_not [| reified_of_proposition env t |] + | Por (_,t1,t2) -> + app coq_p_or + [| reified_of_proposition env t1; reified_of_proposition env t2 |] + | Pand(_,t1,t2) -> + app coq_p_and + [| reified_of_proposition env t1; reified_of_proposition env t2 |] + | Pimp(_,t1,t2) -> + app coq_p_imp + [| reified_of_proposition env t1; reified_of_proposition env t2 |] + | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |] + +let reified_of_proposition env f = + begin try reified_of_proposition env f + with e -> pprint stderr f; raise e end + +(* \subsection{Omega vers COQ réifié} *) + +let reified_of_omega env body constant = + let coeff_constant = + app coq_t_int [| Z.mk constant |] in + let mk_coeff {c=c; v=v} t = + let coef = + app coq_t_mult + [| reified_of_formula env (unintern_omega env v); + app coq_t_int [| Z.mk c |] |] in + app coq_t_plus [|coef; t |] in + List.fold_right mk_coeff body coeff_constant + +let reified_of_omega env body c = + begin try + reified_of_omega env body c + with e -> + display_eq display_omega_var (body,c); raise e + end + +(* \section{Opérations sur les équations} +Ces fonctions préparent les traces utilisées par la tactique réfléchie +pour faire des opérations de normalisation sur les équations. *) + +(* \subsection{Extractions des variables d'une équation} *) +(* Extraction des variables d'une équation. *) +(* Chaque fonction retourne une liste triée sans redondance *) + +let (@@) = list_merge_uniq compare + +let rec vars_of_formula = function + | Oint _ -> [] + | Oplus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) + | Omult (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) + | Ominus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) + | Oopp e -> vars_of_formula e + | Oatom i -> [i] + | Oufo _ -> [] + +let rec vars_of_equations = function + | [] -> [] + | e::l -> + (vars_of_formula e.e_left) @@ + (vars_of_formula e.e_right) @@ + (vars_of_equations l) + +let rec vars_of_prop = function + | Pequa(_,e) -> vars_of_equations [e] + | Pnot p -> vars_of_prop p + | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) + | Pand(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) + | Pimp(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) + | Pprop _ | Ptrue | Pfalse -> [] + +(* \subsection{Multiplication par un scalaire} *) + +let rec scalar n = function + Oplus(t1,t2) -> + let tac1,t1' = scalar n t1 and + tac2,t2' = scalar n t2 in + do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], + Oplus(t1',t2') + | Oopp t -> + do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(Bigint.neg n)) + | Omult(t1,Oint x) -> + do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x)) + | Omult(t1,t2) -> + Util.error "Omega: Can't solve a goal with non-linear products" + | (Oatom _ as t) -> do_list [], Omult(t,Oint n) + | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i) + | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n)) + | Ominus _ -> failwith "scalar minus" + +(* \subsection{Propagation de l'inversion} *) + +let rec negate = function + Oplus(t1,t2) -> + let tac1,t1' = negate t1 and + tac2,t2' = negate t2 in + do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)], + Oplus(t1',t2') + | Oopp t -> + do_list [Lazy.force coq_c_opp_opp], t + | Omult(t1,Oint x) -> + do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x)) + | Omult(t1,t2) -> + Util.error "Omega: Can't solve a goal with non-linear products" + | (Oatom _ as t) -> + do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone)) + | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i) + | Oufo c -> do_list [], Oufo (Oopp c) + | Ominus _ -> failwith "negate minus" + +let rec norm l = (List.length l) + +(* \subsection{Mélange (fusion) de deux équations} *) +(* \subsubsection{Version avec coefficients} *) +let rec shuffle_path k1 e1 k2 e2 = + let rec loop = function + (({c=c1;v=v1}::l1) as l1'), + (({c=c2;v=v2}::l2) as l2') -> + if v1 = v2 then + if k1*c1 + k2 * c2 = zero then ( + Lazy.force coq_f_cancel :: loop (l1,l2)) + else ( + Lazy.force coq_f_equal :: loop (l1,l2) ) + else if v1 > v2 then ( + Lazy.force coq_f_left :: loop(l1,l2')) + else ( + Lazy.force coq_f_right :: loop(l1',l2)) + | ({c=c1;v=v1}::l1), [] -> + Lazy.force coq_f_left :: loop(l1,[]) + | [],({c=c2;v=v2}::l2) -> + Lazy.force coq_f_right :: loop([],l2) + | [],[] -> flush stdout; [] in + mk_shuffle_list (loop (e1,e2)) + +(* \subsubsection{Version sans coefficients} *) +let rec shuffle env (t1,t2) = + match t1,t2 with + Oplus(l1,r1), Oplus(l2,r2) -> + if weight env l1 > weight env l2 then + let l_action,t' = shuffle env (r1,t2) in + do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action], Oplus(l1,t') + else + let l_action,t' = shuffle env (t1,r2) in + do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') + | Oplus(l1,r1), t2 -> + if weight env l1 > weight env t2 then + let (l_action,t') = shuffle env (r1,t2) in + do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t') + else do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) + | t1,Oplus(l2,r2) -> + if weight env l2 > weight env t1 then + let (l_action,t') = shuffle env (t1,r2) in + do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') + else do_list [],Oplus(t1,t2) + | Oint t1,Oint t2 -> + do_list [Lazy.force coq_c_reduce], Oint(t1+t2) + | t1,t2 -> + if weight env t1 < weight env t2 then + do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) + else do_list [],Oplus(t1,t2) + +(* \subsection{Fusion avec réduction} *) + +let shrink_pair f1 f2 = + begin match f1,f2 with + Oatom v,Oatom _ -> + Lazy.force coq_c_red1, Omult(Oatom v,Oint two) + | Oatom v, Omult(_,c2) -> + Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint one)) + | Omult (v1,c1),Oatom v -> + Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint one)) + | Omult (Oatom v,c1),Omult (v2,c2) -> + Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2)) + | t1,t2 -> + oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); + flush Pervasives.stdout; Util.error "shrink.1" + end + +(* \subsection{Calcul d'une sous formule constante} *) + +let reduce_factor = function + Oatom v -> + let r = Omult(Oatom v,Oint one) in + [Lazy.force coq_c_red0],r + | Omult(Oatom v,Oint n) as f -> [],f + | Omult(Oatom v,c) -> + let rec compute = function + Oint n -> n + | Oplus(t1,t2) -> compute t1 + compute t2 + | _ -> Util.error "condense.1" in + [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c)) + | t -> Util.error "reduce_factor.1" + +(* \subsection{Réordonnancement} *) + +let rec condense env = function + Oplus(f1,(Oplus(f2,r) as t)) -> + if weight env f1 = weight env f2 then begin + let shrink_tac,t = shrink_pair f1 f2 in + let assoc_tac = Lazy.force coq_c_plus_assoc_l in + let tac_list,t' = condense env (Oplus(t,r)) in + assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t' + end else begin + let tac,f = reduce_factor f1 in + let tac',t' = condense env t in + [do_both (do_list tac) (do_list tac')], Oplus(f,t') + end + | Oplus(f1,Oint n) -> + let tac,f1' = reduce_factor f1 in + [do_left (do_list tac)],Oplus(f1',Oint n) + | Oplus(f1,f2) -> + if weight env f1 = weight env f2 then begin + let tac_shrink,t = shrink_pair f1 f2 in + let tac,t' = condense env t in + tac_shrink :: tac,t' + end else begin + let tac,f = reduce_factor f1 in + let tac',t' = condense env f2 in + [do_both (do_list tac) (do_list tac')],Oplus(f,t') + end + | (Oint _ as t)-> [],t + | t -> + let tac,t' = reduce_factor t in + let final = Oplus(t',Oint zero) in + tac @ [Lazy.force coq_c_red6], final + +(* \subsection{Elimination des zéros} *) + +let rec clear_zero = function + Oplus(Omult(Oatom v,Oint n),r) when n=zero -> + let tac',t = clear_zero r in + Lazy.force coq_c_red5 :: tac',t + | Oplus(f,r) -> + let tac,t = clear_zero r in + (if tac = [] then [] else [do_right (do_list tac)]),Oplus(f,t) + | t -> [],t;; + +(* \subsection{Transformation des hypothèses} *) + +let rec reduce env = function + Oplus(t1,t2) -> + let t1', trace1 = reduce env t1 in + let t2', trace2 = reduce env t2 in + let trace3,t' = shuffle env (t1',t2') in + t', do_list [do_both trace1 trace2; trace3] + | Ominus(t1,t2) -> + let t,trace = reduce env (Oplus(t1, Oopp t2)) in + t, do_list [Lazy.force coq_c_minus; trace] + | Omult(t1,t2) as t -> + let t1', trace1 = reduce env t1 in + let t2', trace2 = reduce env t2 in + begin match t1',t2' with + | (_, Oint n) -> + let tac,t' = scalar n t1' in + t', do_list [do_both trace1 trace2; tac] + | (Oint n,_) -> + let tac,t' = scalar n t2' in + t', do_list [do_both trace1 trace2; Lazy.force coq_c_mult_comm; tac] + | _ -> Oufo t, Lazy.force coq_c_nop + end + | Oopp t -> + let t',trace = reduce env t in + let trace',t'' = negate t' in + t'', do_list [do_left trace; trace'] + | (Oint _ | Oatom _ | Oufo _) as t -> t, Lazy.force coq_c_nop + +let normalize_linear_term env t = + let t1,trace1 = reduce env t in + let trace2,t2 = condense env t1 in + let trace3,t3 = clear_zero t2 in + do_list [trace1; do_list trace2; do_list trace3], t3 + +(* Cette fonction reproduit très exactement le comportement de [p_invert] *) +let negate_oper = function + Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq + +let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = + let mk_step t1 t2 f kind = + let t = f t1 t2 in + let trace, oterm = normalize_linear_term env t in + let equa = omega_of_oformula env kind oterm in + { e_comp = oper; e_left = t1; e_right = t2; + e_negated = negated; e_depends = depends; + e_origin = { o_hyp = origin; o_path = List.rev path }; + e_trace = trace; e_omega = equa } in + try match (if negated then (negate_oper oper) else oper) with + | Eq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) EQUA + | Neq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) DISE + | Leq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o2,Oopp o1)) INEQ + | Geq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) INEQ + | Lt -> + mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint negone),Oopp o1)) + INEQ + | Gt -> + mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) + INEQ + with e when Logic.catchable_exception e -> raise e + +(* \section{Compilation des hypothèses} *) + +let rec oformula_of_constr env t = + match Z.parse_term t with + | Tplus (t1,t2) -> binop env (fun x y -> Oplus(x,y)) t1 t2 + | Tminus (t1,t2) -> binop env (fun x y -> Ominus(x,y)) t1 t2 + | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 -> + binop env (fun x y -> Omult(x,y)) t1 t2 + | Topp t -> Oopp(oformula_of_constr env t) + | Tsucc t -> Oplus(oformula_of_constr env t, Oint one) + | Tnum n -> Oint n + | _ -> Oatom (add_reified_atom t env) + +and binop env c t1 t2 = + let t1' = oformula_of_constr env t1 in + let t2' = oformula_of_constr env t2 in + c t1' t2' + +and binprop env (neg2,depends,origin,path) + add_to_depends neg1 gl c t1 t2 = + let i = new_connector_id env in + let depends1 = if add_to_depends then Left i::depends else depends in + let depends2 = if add_to_depends then Right i::depends else depends in + if add_to_depends then + Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; + let t1' = + oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in + let t2' = + oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in + (* On numérote le connecteur dans l'environnement. *) + c i t1' t2' + +and mk_equation env ctxt c connector t1 t2 = + let t1' = oformula_of_constr env t1 in + let t2' = oformula_of_constr env t2 in + (* On ajoute l'equation dans l'environnement. *) + let omega = normalize_equation env ctxt (connector,t1',t2') in + add_equation env omega; + Pequa (c,omega) + +and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = + match Z.parse_rel gl c with + | Req (t1,t2) -> mk_equation env ctxt c Eq t1 t2 + | Rne (t1,t2) -> mk_equation env ctxt c Neq t1 t2 + | Rle (t1,t2) -> mk_equation env ctxt c Leq t1 t2 + | Rlt (t1,t2) -> mk_equation env ctxt c Lt t1 t2 + | Rge (t1,t2) -> mk_equation env ctxt c Geq t1 t2 + | Rgt (t1,t2) -> mk_equation env ctxt c Gt t1 t2 + | Rtrue -> Ptrue + | Rfalse -> Pfalse + | Rnot t -> + let t' = + oproposition_of_constr + env (not negated, depends, origin,(O_mono::path)) gl t in + Pnot t' + | Ror (t1,t2) -> + binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2 + | Rand (t1,t2) -> + binprop env ctxt negated negated gl + (fun i x y -> Pand(i,x,y)) t1 t2 + | Rimp (t1,t2) -> + binprop env ctxt (not negated) (not negated) gl + (fun i x y -> Pimp(i,x,y)) t1 t2 + | Riff (t1,t2) -> + binprop env ctxt negated negated gl + (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) + | _ -> Pprop c + +(* Destructuration des hypothèses et de la conclusion *) + +let reify_gl env gl = + let concl = Tacmach.pf_concl gl in + let t_concl = + Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in + if !debug then begin + Printf.printf "REIFED PROBLEM\n\n"; + Printf.printf " CONCL: "; pprint stdout t_concl; Printf.printf "\n" + end; + let rec loop = function + (i,t) :: lhyps -> + let t' = oproposition_of_constr env (false,[],i,[]) gl t in + if !debug then begin + Printf.printf " %s: " (Names.string_of_id i); + pprint stdout t'; + Printf.printf "\n" + end; + (i,t') :: loop lhyps + | [] -> + if !debug then print_env_reification env; + [] in + let t_lhyps = loop (Tacmach.pf_hyps_types gl) in + (id_concl,t_concl) :: t_lhyps + +let rec destructurate_pos_hyp orig list_equations list_depends = function + | Pequa (_,e) -> [e :: list_equations] + | Ptrue | Pfalse | Pprop _ -> [list_equations] + | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t + | Por (i,t1,t2) -> + let s1 = + destructurate_pos_hyp orig list_equations (i::list_depends) t1 in + let s2 = + destructurate_pos_hyp orig list_equations (i::list_depends) t2 in + s1 @ s2 + | Pand(i,t1,t2) -> + let list_s1 = + destructurate_pos_hyp orig list_equations (list_depends) t1 in + let rec loop = function + le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll + | [] -> [] in + loop list_s1 + | Pimp(i,t1,t2) -> + let s1 = + destructurate_neg_hyp orig list_equations (i::list_depends) t1 in + let s2 = + destructurate_pos_hyp orig list_equations (i::list_depends) t2 in + s1 @ s2 + +and destructurate_neg_hyp orig list_equations list_depends = function + | Pequa (_,e) -> [e :: list_equations] + | Ptrue | Pfalse | Pprop _ -> [list_equations] + | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t + | Pand (i,t1,t2) -> + let s1 = + destructurate_neg_hyp orig list_equations (i::list_depends) t1 in + let s2 = + destructurate_neg_hyp orig list_equations (i::list_depends) t2 in + s1 @ s2 + | Por(_,t1,t2) -> + let list_s1 = + destructurate_neg_hyp orig list_equations list_depends t1 in + let rec loop = function + le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll + | [] -> [] in + loop list_s1 + | Pimp(_,t1,t2) -> + let list_s1 = + destructurate_pos_hyp orig list_equations list_depends t1 in + let rec loop = function + le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll + | [] -> [] in + loop list_s1 + +let destructurate_hyps syst = + let rec loop = function + (i,t) :: l -> + let l_syst1 = destructurate_pos_hyp i [] [] t in + let l_syst2 = loop l in + list_cartesian (@) l_syst1 l_syst2 + | [] -> [[]] in + loop syst + +(* \subsection{Affichage d'un système d'équation} *) + +(* Affichage des dépendances de système *) +let display_depend = function + Left i -> Printf.printf " L%d" i + | Right i -> Printf.printf " R%d" i + +let display_systems syst_list = + let display_omega om_e = + Printf.printf " E%d : %a %s 0\n" + om_e.id + (fun _ -> display_eq display_omega_var) + (om_e.body, om_e.constant) + (operator_of_eq om_e.kind) in + + let display_equation oformula_eq = + pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline (); + display_omega oformula_eq.e_omega; + Printf.printf " Depends on:"; + List.iter display_depend oformula_eq.e_depends; + Printf.printf "\n Path: %s" + (String.concat "" + (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M") + oformula_eq.e_origin.o_path)); + Printf.printf "\n Origin: %s (negated : %s)\n\n" + (Names.string_of_id oformula_eq.e_origin.o_hyp) + (if oformula_eq.e_negated then "yes" else "no") in + + let display_system syst = + Printf.printf "=SYSTEM===================================\n"; + List.iter display_equation syst in + List.iter display_system syst_list + +(* Extraction des prédicats utilisées dans une trace. Permet ensuite le + calcul des hypothèses *) + +let rec hyps_used_in_trace = function + | act :: l -> + begin match act with + | HYP e -> [e.id] @@ (hyps_used_in_trace l) + | SPLIT_INEQ (_,(_,act1),(_,act2)) -> + hyps_used_in_trace act1 @@ hyps_used_in_trace act2 + | _ -> hyps_used_in_trace l + end + | [] -> [] + +(* Extraction des variables déclarées dans une équation. Permet ensuite + de les déclarer dans l'environnement de la procédure réflexive et + éviter les créations de variable au vol *) + +let rec variable_stated_in_trace = function + | act :: l -> + begin match act with + | STATE action -> + (*i nlle_equa: afine, def: afine, eq_orig: afine, i*) + (*i coef: int, var:int i*) + action :: variable_stated_in_trace l + | SPLIT_INEQ (_,(_,act1),(_,act2)) -> + variable_stated_in_trace act1 @ variable_stated_in_trace act2 + | _ -> variable_stated_in_trace l + end + | [] -> [] +;; + +let add_stated_equations env tree = + (* Il faut trier les variables par ordre d'introduction pour ne pas risquer + de définir dans le mauvais ordre *) + let stated_equations = + let cmpvar x y = Pervasives.(-) x.st_var y.st_var in + let rec loop = function + | Tree(_,t1,t2) -> List.merge cmpvar (loop t1) (loop t2) + | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) + in loop tree + in + let add_env st = + (* On retransforme la définition de v en formule reifiée *) + let v_def = oformula_of_omega env st.st_def in + (* Notez que si l'ordre de création des variables n'est pas respecté, + * ca va planter *) + let coq_v = coq_of_formula env v_def in + let v = add_reified_atom coq_v env in + (* Le terme qu'il va falloir introduire *) + let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in + (* sa représentation sous forme d'équation mais non réifié car on n'a pas + * l'environnement pour le faire correctement *) + let term_to_reify = (v_def,Oatom v) in + (* enregistre le lien entre la variable omega et la variable Coq *) + intern_omega_force env (Oatom v) st.st_var; + (v, term_to_generalize,term_to_reify,st.st_def.id) in + List.map add_env stated_equations + +(* Calcule la liste des éclatements à réaliser sur les hypothèses + nécessaires pour extraire une liste d'équations donnée *) + +(* PL: experimentally, the result order of the following function seems + _very_ crucial for efficiency. No idea why. Do not remove the List.rev + or modify the current semantics of Util.list_union (some elements of first + arg, then second arg), unless you know what you're doing. *) + +let rec get_eclatement env = function + i :: r -> + let l = try (get_equation env i).e_depends with Not_found -> [] in + list_union (List.rev l) (get_eclatement env r) + | [] -> [] + +let select_smaller l = + let comp (_,x) (_,y) = Pervasives.(-) (List.length x) (List.length y) in + try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller" + +let filter_compatible_systems required systems = + let rec select = function + (x::l) -> + if List.mem x required then select l + else if List.mem (barre x) required then failwith "Exit" + else x :: select l + | [] -> [] in + map_succeed (function (sol,splits) -> (sol,select splits)) systems + +let rec equas_of_solution_tree = function + Tree(_,t1,t2) -> (equas_of_solution_tree t1)@@(equas_of_solution_tree t2) + | Leaf s -> s.s_equa_deps + +(* [really_useful_prop] pushes useless props in a new Pprop variable *) +(* Things get shorter, but may also get wrong, since a Prop is considered + to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance + Pfalse is decidable. So should not be used on conclusion (??) *) + +let really_useful_prop l_equa c = + let rec real_of = function + Pequa(t,_) -> t + | Ptrue -> app coq_True [||] + | Pfalse -> app coq_False [||] + | Pnot t1 -> app coq_not [|real_of t1|] + | Por(_,t1,t2) -> app coq_or [|real_of t1; real_of t2|] + | Pand(_,t1,t2) -> app coq_and [|real_of t1; real_of t2|] + (* Attention : implications sur le lifting des variables à comprendre ! *) + | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2) + | Pprop t -> t in + let rec loop c = + match c with + Pequa(_,e) -> + if List.mem e.e_omega.id l_equa then Some c else None + | Ptrue -> None + | Pfalse -> None + | Pnot t1 -> + begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end + | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2 + | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2 + | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2 + | Pprop t -> None + and binop f t1 t2 = + begin match loop t1, loop t2 with + None, None -> None + | Some t1',Some t2' -> Some (f(t1',t2')) + | Some t1',None -> Some (f(t1',Pprop (real_of t2))) + | None,Some t2' -> Some (f(Pprop (real_of t1),t2')) + end in + match loop c with + None -> Pprop (real_of c) + | Some t -> t + +let rec display_solution_tree ch = function + Leaf t -> + output_string ch + (Printf.sprintf "%d[%s]" + t.s_index + (String.concat " " (List.map string_of_int t.s_equa_deps))) + | Tree(i,t1,t2) -> + Printf.fprintf ch "S%d(%a,%a)" i + display_solution_tree t1 display_solution_tree t2 + +let rec solve_with_constraints all_solutions path = + let rec build_tree sol buf = function + [] -> Leaf sol + | (Left i :: remainder) -> + Tree(i, + build_tree sol (Left i :: buf) remainder, + solve_with_constraints all_solutions (List.rev(Right i :: buf))) + | (Right i :: remainder) -> + Tree(i, + solve_with_constraints all_solutions (List.rev (Left i :: buf)), + build_tree sol (Right i :: buf) remainder) in + let weighted = filter_compatible_systems path all_solutions in + let (winner_sol,winner_deps) = + try select_smaller weighted + with e -> + Printf.printf "%d - %d\n" + (List.length weighted) (List.length all_solutions); + List.iter display_depend path; raise e in + build_tree winner_sol (List.rev path) winner_deps + +let find_path {o_hyp=id;o_path=p} env = + let rec loop_path = function + ([],l) -> Some l + | (x1::l1,x2::l2) when x1 = x2 -> loop_path (l1,l2) + | _ -> None in + let rec loop_id i = function + CCHyp{o_hyp=id';o_path=p'} :: l when id = id' -> + begin match loop_path (p',p) with + Some r -> i,r + | None -> loop_id (succ i) l + end + | _ :: l -> loop_id (succ i) l + | [] -> failwith "find_path" in + loop_id 0 env + +let mk_direction_list l = + let trans = function + O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in + mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l) + + +(* \section{Rejouer l'historique} *) + +let get_hyp env_hyp i = + try list_index0 (CCEqua i) env_hyp + with Not_found -> failwith (Printf.sprintf "get_hyp %d" i) + +let replay_history env env_hyp = + let rec loop env_hyp t = + match t with + | CONTRADICTION (e1,e2) :: l -> + let trace = mk_nat (List.length e1.body) in + mkApp (Lazy.force coq_s_contradiction, + [| trace ; mk_nat (get_hyp env_hyp e1.id); + mk_nat (get_hyp env_hyp e2.id) |]) + | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> + mkApp (Lazy.force coq_s_div_approx, + [| Z.mk k; Z.mk d; + reified_of_omega env e2.body e2.constant; + mk_nat (List.length e2.body); + loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |]) + | NOT_EXACT_DIVIDE (e1,k) :: l -> + let e2_constant = floor_div e1.constant k in + let d = e1.constant - e2_constant * k in + let e2_body = map_eq_linear (fun c -> c / k) e1.body in + mkApp (Lazy.force coq_s_not_exact_divide, + [|Z.mk k; Z.mk d; + reified_of_omega env e2_body e2_constant; + mk_nat (List.length e2_body); + mk_nat (get_hyp env_hyp e1.id)|]) + | EXACT_DIVIDE (e1,k) :: l -> + let e2_body = + map_eq_linear (fun c -> c / k) e1.body in + let e2_constant = floor_div e1.constant k in + mkApp (Lazy.force coq_s_exact_divide, + [|Z.mk k; + reified_of_omega env e2_body e2_constant; + mk_nat (List.length e2_body); + loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|]) + | (MERGE_EQ(e3,e1,e2)) :: l -> + let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2 in + mkApp (Lazy.force coq_s_merge_eq, + [| mk_nat (List.length e1.body); + mk_nat n1; mk_nat n2; + loop (CCEqua e3:: env_hyp) l |]) + | SUM(e3,(k1,e1),(k2,e2)) :: l -> + let n1 = get_hyp env_hyp e1.id + and n2 = get_hyp env_hyp e2.id in + let trace = shuffle_path k1 e1.body k2 e2.body in + mkApp (Lazy.force coq_s_sum, + [| Z.mk k1; mk_nat n1; Z.mk k2; + mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |]) + | CONSTANT_NOT_NUL(e,k) :: l -> + mkApp (Lazy.force coq_s_constant_not_nul, + [| mk_nat (get_hyp env_hyp e) |]) + | CONSTANT_NEG(e,k) :: l -> + mkApp (Lazy.force coq_s_constant_neg, + [| mk_nat (get_hyp env_hyp e) |]) + | STATE {st_new_eq=new_eq; st_def =def; + st_orig=orig; st_coef=m; + st_var=sigma } :: l -> + let n1 = get_hyp env_hyp orig.id + and n2 = get_hyp env_hyp def.id in + let v = unintern_omega env sigma in + let o_def = oformula_of_omega env def in + let o_orig = oformula_of_omega env orig in + let body = + Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in + let trace,_ = normalize_linear_term env body in + mkApp (Lazy.force coq_s_state, + [| Z.mk m; trace; mk_nat n1; mk_nat n2; + loop (CCEqua new_eq.id :: env_hyp) l |]) + | HYP _ :: l -> loop env_hyp l + | CONSTANT_NUL e :: l -> + mkApp (Lazy.force coq_s_constant_nul, + [| mk_nat (get_hyp env_hyp e) |]) + | NEGATE_CONTRADICT(e1,e2,true) :: l -> + mkApp (Lazy.force coq_s_negate_contradict, + [| mk_nat (get_hyp env_hyp e1.id); + mk_nat (get_hyp env_hyp e2.id) |]) + | NEGATE_CONTRADICT(e1,e2,false) :: l -> + mkApp (Lazy.force coq_s_negate_contradict_inv, + [| mk_nat (List.length e2.body); + mk_nat (get_hyp env_hyp e1.id); + mk_nat (get_hyp env_hyp e2.id) |]) + | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l -> + let i = get_hyp env_hyp e.id in + let r1 = loop (CCEqua e1 :: env_hyp) l1 in + let r2 = loop (CCEqua e2 :: env_hyp) l2 in + mkApp (Lazy.force coq_s_split_ineq, + [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |]) + | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> + loop env_hyp l + | (WEAKEN _ ) :: l -> failwith "not_treated" + | [] -> failwith "no contradiction" + in loop env_hyp + +let rec decompose_tree env ctxt = function + Tree(i,left,right) -> + let org = + try Hashtbl.find env.constructors i + with Not_found -> + failwith (Printf.sprintf "Cannot find constructor %d" i) in + let (index,path) = find_path org ctxt in + let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in + let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in + app coq_e_split + [| mk_nat index; + mk_direction_list path; + decompose_tree env (left_hyp::ctxt) left; + decompose_tree env (right_hyp::ctxt) right |] + | Leaf s -> + decompose_tree_hyps s.s_trace env ctxt s.s_equa_deps +and decompose_tree_hyps trace env ctxt = function + [] -> app coq_e_solve [| replay_history env ctxt trace |] + | (i::l) -> + let equation = + try Hashtbl.find env.equations i + with Not_found -> + failwith (Printf.sprintf "Cannot find equation %d" i) in + let (index,path) = find_path equation.e_origin ctxt in + let full_path = if equation.e_negated then path @ [O_mono] else path in + let cont = + decompose_tree_hyps trace env + (CCEqua equation.e_omega.id :: ctxt) l in + app coq_e_extract [|mk_nat index; + mk_direction_list full_path; + cont |] + +(* \section{La fonction principale} *) + (* Cette fonction construit la +trace pour la procédure de décision réflexive. A partir des résultats +de l'extraction des systèmes, elle lance la résolution par Omega, puis +l'extraction d'un ensemble minimal de solutions permettant la +résolution globale du système et enfin construit la trace qui permet +de faire rejouer cette solution par la tactique réflexive. *) + +let resolution env full_reified_goal systems_list = + let num = ref 0 in + let solve_system list_eq = + let index = !num in + let system = List.map (fun eq -> eq.e_omega) list_eq in + let trace = + simplify_strong + (new_omega_eq,new_omega_var,display_omega_var) + system in + (* calcule les hypotheses utilisées pour la solution *) + let vars = hyps_used_in_trace trace in + let splits = get_eclatement env vars in + if !debug then begin + Printf.printf "SYSTEME %d\n" index; + display_action display_omega_var trace; + print_string "\n Depend :"; + List.iter (fun i -> Printf.printf " %d" i) vars; + print_string "\n Split points :"; + List.iter display_depend splits; + Printf.printf "\n------------------------------------\n" + end; + incr num; + {s_index = index; s_trace = trace; s_equa_deps = vars}, splits in + if !debug then Printf.printf "\n====================================\n"; + let all_solutions = List.map solve_system systems_list in + let solution_tree = solve_with_constraints all_solutions [] in + if !debug then begin + display_solution_tree stdout solution_tree; + print_newline() + end; + (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *) + let useful_equa_id = equas_of_solution_tree solution_tree in + (* recupere explicitement ces equations *) + let equations = List.map (get_equation env) useful_equa_id in + let l_hyps' = list_uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in + let l_hyps = id_concl :: list_remove id_concl l_hyps' in + let useful_hyps = + List.map (fun id -> List.assoc id full_reified_goal) l_hyps in + let useful_vars = + let really_useful_vars = vars_of_equations equations in + let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in + really_useful_vars @@ concl_vars + in + (* variables a introduire *) + let to_introduce = add_stated_equations env solution_tree in + let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in + let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in + let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in + (* L'environnement de base se construit en deux morceaux : + - les variables des équations utiles (et de la conclusion) + - les nouvelles variables declarées durant les preuves *) + let all_vars_env = useful_vars @ stated_vars in + let basic_env = + let rec loop i = function + var :: l -> + let t = get_reified_atom env var in + Hashtbl.add env.real_indices var i; t :: loop (succ i) l + | [] -> [] in + loop 0 all_vars_env in + let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in + (* On peut maintenant généraliser le but : env est a jour *) + let l_reified_stated = + List.map (fun (_,_,(l,r),_) -> + app coq_p_eq [| reified_of_formula env l; + reified_of_formula env r |]) + to_introduce in + let reified_concl = + match useful_hyps with + (Pnot p) :: _ -> reified_of_proposition env p + | _ -> reified_of_proposition env Pfalse in + let l_reified_terms = + (List.map + (fun p -> + reified_of_proposition env (really_useful_prop useful_equa_id p)) + (List.tl useful_hyps)) in + let env_props_reified = mk_plist env.props in + let reified_goal = + mk_list (Lazy.force coq_proposition) + (l_reified_stated @ l_reified_terms) in + let reified = + app coq_interp_sequent + [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in + let normalize_equation e = + let rec loop = function + [] -> app (if e.e_negated then coq_p_invert else coq_p_step) + [| e.e_trace |] + | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |] + | (O_right :: l) -> app coq_p_right [| loop l |] in + let correct_index = + let i = list_index0 e.e_origin.o_hyp l_hyps in + (* PL: it seems that additionnally introduced hyps are in the way during + normalization, hence this index shifting... *) + if i=0 then 0 else Pervasives.(+) i (List.length to_introduce) + in + app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in + let normalization_trace = + mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in + + let initial_context = + List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in + let context = + CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in + let decompose_tactic = decompose_tree env context solution_tree in + + Tactics.generalize + (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >> + Tactics.change_in_concl None reified >> + Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >> + show_goal >> + Tactics.normalise_vm_in_concl >> + (*i Alternatives to the previous line: + - Normalisation without VM: + Tactics.normalise_in_concl + - Skip the conversion check and rely directly on the QED: + Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> + i*) + Tactics.apply (Lazy.force coq_I) + +let total_reflexive_omega_tactic gl = + Coqlib.check_required_library ["Coq";"romega";"ROmega"]; + rst_omega_eq (); + rst_omega_var (); + try + let env = new_environment () in + let full_reified_goal = reify_gl env gl in + let systems_list = destructurate_hyps full_reified_goal in + if !debug then display_systems systems_list; + resolution env full_reified_goal systems_list gl + with NO_CONTRADICTION -> Util.error "ROmega can't solve this system" + + +(*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*) + + diff --git a/plugins/romega/romega_plugin.mllib b/plugins/romega/romega_plugin.mllib new file mode 100644 index 00000000..1625009d --- /dev/null +++ b/plugins/romega/romega_plugin.mllib @@ -0,0 +1,4 @@ +Const_omega +Refl_omega +G_romega +Romega_plugin_mod diff --git a/plugins/romega/vo.itarget b/plugins/romega/vo.itarget new file mode 100644 index 00000000..f7a3c41c --- /dev/null +++ b/plugins/romega/vo.itarget @@ -0,0 +1,2 @@ +ReflOmegaCore.vo +ROmega.vo diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v new file mode 100644 index 00000000..c06f6991 --- /dev/null +++ b/plugins/rtauto/Bintree.v @@ -0,0 +1,489 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (p ?= q) cmp = Gt. +apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt)); +simpl;auto;congruence. +Qed. + +Lemma Gt_Lt_Gt : forall p q cmp, + (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt. +apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt)); +simpl;auto;congruence. +Qed. + +Lemma Gt_Psucc_Eq: forall p q, + (p ?= Psucc q) Gt = Gt -> (p ?= q) Eq = Gt. +intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence. +intro;apply Gt_Eq_Gt;auto. +apply Gt_Lt_Gt. +Qed. + +Lemma Eq_Psucc_Gt: forall p q, + (p ?= Psucc q) Eq = Eq -> (p ?= q) Eq = Gt. +intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence. +intro H;elim (Pcompare_not_Eq p (Psucc q));tauto. +intro H;apply Gt_Eq_Gt;auto. +intro H;rewrite Pcompare_Eq_eq with p q;auto. +generalize q;clear q IHq p H;induction q;simpl;auto. +intro H;elim (Pcompare_not_Eq p q);tauto. +Qed. + +Lemma Gt_Psucc_Gt : forall n p cmp cmp0, + (n?=p) cmp = Gt -> (Psucc n?=p) cmp0 = Gt. +induction n;intros [ | p | p];simpl;try congruence. +intros; apply IHn with cmp;trivial. +intros; apply IHn with Gt;trivial. +intros;apply Gt_Lt_Gt;trivial. +intros [ | | ] _ H. +apply Gt_Eq_Gt;trivial. +apply Gt_Lt_Gt;trivial. +trivial. +Qed. + +Lemma Gt_Psucc: forall p q, + (p ?= Psucc q) Eq = Gt -> (p ?= q) Eq = Gt. +intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence. +apply Gt_Psucc_Eq. +intro;apply Gt_Eq_Gt;apply IHq;auto. +apply Gt_Eq_Gt. +apply Gt_Lt_Gt. +Qed. + +Lemma Psucc_Gt : forall p, + (Psucc p ?= p) Eq = Gt. +induction p;simpl. +apply Gt_Eq_Gt;auto. +generalize p;clear p IHp. +induction p;simpl;auto. +reflexivity. +Qed. + +Fixpoint pos_eq (m n:positive) {struct m} :bool := +match m, n with + xI mm, xI nn => pos_eq mm nn +| xO mm, xO nn => pos_eq mm nn +| xH, xH => true +| _, _ => false +end. + +Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. +induction m;simpl;intro n;destruct n;congruence || +(intro e;apply f_equal with positive;auto). +Defined. + +Theorem refl_pos_eq : forall m, pos_eq m m = true. +induction m;simpl;auto. +Qed. + +Definition pos_eq_dec : forall (m n:positive), {m=n}+{m<>n} . +fix 1;intros [mm|mm|] [nn|nn|];try (right;congruence). +case (pos_eq_dec mm nn). +intro e;left;apply (f_equal xI e). +intro ne;right;congruence. +case (pos_eq_dec mm nn). +intro e;left;apply (f_equal xO e). +intro ne;right;congruence. +left;reflexivity. +Defined. + +Theorem pos_eq_dec_refl : forall m, pos_eq_dec m m = left _ (refl_equal m). +fix 1;intros [mm|mm|]. +simpl; rewrite pos_eq_dec_refl; reflexivity. +simpl; rewrite pos_eq_dec_refl; reflexivity. +reflexivity. +Qed. + +Theorem pos_eq_dec_ex : forall m n, + pos_eq m n =true -> exists h:m=n, + pos_eq_dec m n = left _ h. +fix 1;intros [mm|mm|] [nn|nn|];try (simpl;congruence). +simpl;intro e. +elim (pos_eq_dec_ex _ _ e). +intros x ex; rewrite ex. +exists (f_equal xI x). +reflexivity. +simpl;intro e. +elim (pos_eq_dec_ex _ _ e). +intros x ex; rewrite ex. +exists (f_equal xO x). +reflexivity. +simpl. +exists (refl_equal xH). +reflexivity. +Qed. + +Fixpoint nat_eq (m n:nat) {struct m}: bool:= +match m, n with +O,O => true +| S mm,S nn => nat_eq mm nn +| _,_ => false +end. + +Theorem nat_eq_refl : forall m n, nat_eq m n = true -> m = n. +induction m;simpl;intro n;destruct n;congruence || +(intro e;apply f_equal with nat;auto). +Defined. + +Theorem refl_nat_eq : forall n, nat_eq n n = true. +induction n;simpl;trivial. +Defined. + +Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A := +match l with nil => None +| x::q => +match n with O => Some x +| S m => Lget A m q +end end . + +Implicit Arguments Lget [A]. + +Lemma map_app : forall (A B:Set) (f:A -> B) l m, +List.map f (l ++ m) = List.map f l ++ List.map f m. +induction l. +reflexivity. +simpl. +intro m ; apply f_equal with (list B);apply IHl. +Qed. + +Lemma length_map : forall (A B:Set) (f:A -> B) l, +length (List.map f l) = length l. +induction l. +reflexivity. +simpl; apply f_equal with nat;apply IHl. +Qed. + +Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, +Lget i (List.map f l) = +match Lget i l with Some a => +Some (f a) | None => None end. +induction i;intros [ | x l ] ;trivial. +simpl;auto. +Qed. + +Lemma Lget_app : forall (A:Set) (a:A) l i, +Lget i (l ++ a :: nil) = if nat_eq i (length l) then Some a else Lget i l. +induction l;simpl Lget;simpl length. +intros [ | i];simpl;reflexivity. +intros [ | i];simpl. +reflexivity. +auto. +Qed. + +Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), +Lget i l = Some a -> +Lget i (l ++ delta) = Some a. +induction l;destruct i;simpl;try congruence;auto. +Qed. + +Section Store. + +Variable A:Type. + +Inductive Poption : Type:= + PSome : A -> Poption +| PNone : Poption. + +Inductive Tree : Type := + Tempty : Tree + | Branch0 : Tree -> Tree -> Tree + | Branch1 : A -> Tree -> Tree -> Tree. + +Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := + match T with + Tempty => PNone + | Branch0 T1 T2 => + match p with + xI pp => Tget pp T2 + | xO pp => Tget pp T1 + | xH => PNone + end + | Branch1 a T1 T2 => + match p with + xI pp => Tget pp T2 + | xO pp => Tget pp T1 + | xH => PSome a + end +end. + +Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := + match T with + | Tempty => + match p with + | xI pp => Branch0 Tempty (Tadd pp a Tempty) + | xO pp => Branch0 (Tadd pp a Tempty) Tempty + | xH => Branch1 a Tempty Tempty + end + | Branch0 T1 T2 => + match p with + | xI pp => Branch0 T1 (Tadd pp a T2) + | xO pp => Branch0 (Tadd pp a T1) T2 + | xH => Branch1 a T1 T2 + end + | Branch1 b T1 T2 => + match p with + | xI pp => Branch1 b T1 (Tadd pp a T2) + | xO pp => Branch1 b (Tadd pp a T1) T2 + | xH => Branch1 a T1 T2 + end + end. + +Definition mkBranch0 (T1 T2:Tree) := + match T1,T2 with + Tempty ,Tempty => Tempty + | _,_ => Branch0 T1 T2 + end. + +Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree := + match T with + | Tempty => Tempty + | Branch0 T1 T2 => + match p with + | xI pp => mkBranch0 T1 (Tremove pp T2) + | xO pp => mkBranch0 (Tremove pp T1) T2 + | xH => T + end + | Branch1 b T1 T2 => + match p with + | xI pp => Branch1 b T1 (Tremove pp T2) + | xO pp => Branch1 b (Tremove pp T1) T2 + | xH => mkBranch0 T1 T2 + end + end. + + +Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone. +destruct p;reflexivity. +Qed. + +Theorem Tget_Tadd: forall i j a T, + Tget i (Tadd j a T) = + match (i ?= j) Eq with + Eq => PSome a + | Lt => Tget i T + | Gt => Tget i T + end. +intros i j. +caseq ((i ?= j) Eq). +intro H;rewrite (Pcompare_Eq_eq _ _ H);intros a;clear i H. +induction j;destruct T;simpl;try (apply IHj);congruence. +generalize i;clear i;induction j;destruct T;simpl in H|-*; +destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. +generalize i;clear i;induction j;destruct T;simpl in H|-*; +destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. +Qed. + +Record Store : Type := +mkStore {index:positive;contents:Tree}. + +Definition empty := mkStore xH Tempty. + +Definition push a S := +mkStore (Psucc (index S)) (Tadd (index S) a (contents S)). + +Definition get i S := Tget i (contents S). + +Lemma get_empty : forall i, get i empty = PNone. +intro i; case i; unfold empty,get; simpl;reflexivity. +Qed. + +Inductive Full : Store -> Type:= + F_empty : Full empty + | F_push : forall a S, Full S -> Full (push a S). + +Theorem get_Full_Gt : forall S, Full S -> + forall i, (i ?= index S) Eq = Gt -> get i S = PNone. +intros S W;induction W. +unfold empty,index,get,contents;intros;apply Tget_Tempty. +unfold index,get,push;simpl contents. +intros i e;rewrite Tget_Tadd. +rewrite (Gt_Psucc _ _ e). +unfold get in IHW. +apply IHW;apply Gt_Psucc;assumption. +Qed. + +Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone. +intros [index0 contents0] F. +case F. +unfold empty,index,get,contents;intros;apply Tget_Tempty. +unfold index,get,push;simpl contents. +intros a S. +rewrite Tget_Tadd. +rewrite Psucc_Gt. +intro W. +change (get (Psucc (index S)) S =PNone). +apply get_Full_Gt; auto. +apply Psucc_Gt. +Qed. + +Theorem get_push_Full : + forall i a S, Full S -> + get i (push a S) = + match (i ?= index S) Eq with + Eq => PSome a + | Lt => get i S + | Gt => PNone +end. +intros i a S F. +caseq ((i ?= index S) Eq). +intro e;rewrite (Pcompare_Eq_eq _ _ e). +destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. +rewrite Pcompare_refl;reflexivity. +intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. +simpl index in H;rewrite H;reflexivity. +intro H;generalize H;clear H. +unfold get,push;simpl index;simpl contents. +rewrite Tget_Tadd;intro e;rewrite e. +change (get i S=PNone). +apply get_Full_Gt;auto. +Qed. + +Lemma Full_push_compat : forall i a S, Full S -> +forall x, get i S = PSome x -> + get i (push a S) = PSome x. +intros i a S F x H. +caseq ((i ?= index S) Eq);intro test. +rewrite (Pcompare_Eq_eq _ _ test) in H. +rewrite (get_Full_Eq _ F) in H;congruence. +rewrite <- H. +rewrite (get_push_Full i a). +rewrite test;reflexivity. +assumption. +rewrite (get_Full_Gt _ F) in H;congruence. +Qed. + +Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. +intros [ind cont] F one; inversion F. +reflexivity. +simpl index in one;assert (h:=Psucc_not_one (index S)). +congruence. +Qed. + +Lemma push_not_empty: forall a S, (push a S) <> empty. +intros a [ind cont];unfold push,empty. +simpl;intro H;injection H; intros _ ; apply Psucc_not_one. +Qed. + +Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop := +match F with +F_empty => False +| F_push a SS FF => x=a \/ In x SS FF +end. + +Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , +get i S = PSome x -> In x S F. +induction F. +intro i;rewrite get_empty; congruence. +intro i;rewrite get_push_Full;trivial. +caseq ((i ?= index S) Eq);simpl. +left;congruence. +right;eauto. +congruence. +Qed. + +End Store. + +Implicit Arguments PNone [A]. +Implicit Arguments PSome [A]. + +Implicit Arguments Tempty [A]. +Implicit Arguments Branch0 [A]. +Implicit Arguments Branch1 [A]. + +Implicit Arguments Tget [A]. +Implicit Arguments Tadd [A]. + +Implicit Arguments Tget_Tempty [A]. +Implicit Arguments Tget_Tadd [A]. + +Implicit Arguments mkStore [A]. +Implicit Arguments index [A]. +Implicit Arguments contents [A]. + +Implicit Arguments empty [A]. +Implicit Arguments get [A]. +Implicit Arguments push [A]. + +Implicit Arguments get_empty [A]. +Implicit Arguments get_push_Full [A]. + +Implicit Arguments Full [A]. +Implicit Arguments F_empty [A]. +Implicit Arguments F_push [A]. +Implicit Arguments In [A]. + +Section Map. + +Variables A B:Set. + +Variable f: A -> B. + +Fixpoint Tmap (T: Tree A) : Tree B := +match T with +Tempty => Tempty +| Branch0 t1 t2 => Branch0 (Tmap t1) (Tmap t2) +| Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2) +end. + +Lemma Tget_Tmap: forall T i, +Tget i (Tmap T)= match Tget i T with PNone => PNone +| PSome a => PSome (f a) end. +induction T;intro i;case i;simpl;auto. +Defined. + +Lemma Tmap_Tadd: forall i a T, +Tmap (Tadd i a T) = Tadd i (f a) (Tmap T). +induction i;intros a T;case T;simpl;intros;try (rewrite IHi);simpl;reflexivity. +Defined. + +Definition map (S:Store A) : Store B := +mkStore (index S) (Tmap (contents S)). + +Lemma get_map: forall i S, +get i (map S)= match get i S with PNone => PNone +| PSome a => PSome (f a) end. +destruct S;unfold get,map,contents,index;apply Tget_Tmap. +Defined. + +Lemma map_push: forall a S, +map (push a S) = push (f a) (map S). +intros a S. +case S. +unfold push,map,contents,index. +intros;rewrite Tmap_Tadd;reflexivity. +Defined. + +Theorem Full_map : forall S, Full S -> Full (map S). +intros S F. +induction F. +exact F_empty. +rewrite map_push;constructor 2;assumption. +Defined. + +End Map. + +Implicit Arguments Tmap [A B]. +Implicit Arguments map [A B]. +Implicit Arguments Full_map [A B f]. + +Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v new file mode 100644 index 00000000..0d1d09c7 --- /dev/null +++ b/plugins/rtauto/Rtauto.v @@ -0,0 +1,400 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* form +| Arrow : form -> form -> form +| Bot +| Conjunct : form -> form -> form +| Disjunct : form -> form -> form. + +Notation "[ n ]":=(Atom n). +Notation "A =>> B":= (Arrow A B) (at level 59, right associativity). +Notation "#" := Bot. +Notation "A //\\ B" := (Conjunct A B) (at level 57, left associativity). +Notation "A \\// B" := (Disjunct A B) (at level 58, left associativity). + +Definition ctx := Store form. + +Fixpoint pos_eq (m n:positive) {struct m} :bool := +match m with + xI mm => match n with xI nn => pos_eq mm nn | _ => false end +| xO mm => match n with xO nn => pos_eq mm nn | _ => false end +| xH => match n with xH => true | _ => false end +end. + +Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. +induction m;simpl;destruct n;congruence || +(intro e;apply f_equal with positive;auto). +Qed. + +Fixpoint form_eq (p q:form) {struct p} :bool := +match p with + Atom m => match q with Atom n => pos_eq m n | _ => false end +| Arrow p1 p2 => +match q with + Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 +| _ => false end +| Bot => match q with Bot => true | _ => false end +| Conjunct p1 p2 => +match q with + Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 +| _ => false +end +| Disjunct p1 p2 => +match q with + Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 +| _ => false +end +end. + +Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q. +induction p;destruct q;simpl;clean. +intro h;generalize (pos_eq_refl _ _ h);congruence. +caseq (form_eq p1 q1);clean. +intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. +caseq (form_eq p1 q1);clean. +intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. +caseq (form_eq p1 q1);clean. +intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. +Qed. + +Implicit Arguments form_eq_refl [p q]. + +Section with_env. + +Variable env:Store Prop. + +Fixpoint interp_form (f:form): Prop := +match f with +[n]=> match get n env with PNone => True | PSome P => P end +| A =>> B => (interp_form A) -> (interp_form B) +| # => False +| A //\\ B => (interp_form A) /\ (interp_form B) +| A \\// B => (interp_form A) \/ (interp_form B) +end. + +Notation "[[ A ]]" := (interp_form A). + +Fixpoint interp_ctx (hyps:ctx) (F:Full hyps) (G:Prop) {struct F} : Prop := +match F with + F_empty => G +| F_push H hyps0 F0 => interp_ctx hyps0 F0 ([[H]] -> G) +end. + +Require Export BinPos. + +Ltac wipe := intros;simpl;constructor. + +Lemma compose0 : +forall hyps F (A:Prop), + A -> + (interp_ctx hyps F A). +induction F;intros A H;simpl;auto. +Qed. + +Lemma compose1 : +forall hyps F (A B:Prop), + (A -> B) -> + (interp_ctx hyps F A) -> + (interp_ctx hyps F B). +induction F;intros A B H;simpl;auto. +apply IHF;auto. +Qed. + +Theorem compose2 : +forall hyps F (A B C:Prop), + (A -> B -> C) -> + (interp_ctx hyps F A) -> + (interp_ctx hyps F B) -> + (interp_ctx hyps F C). +induction F;intros A B C H;simpl;auto. +apply IHF;auto. +Qed. + +Theorem compose3 : +forall hyps F (A B C D:Prop), + (A -> B -> C -> D) -> + (interp_ctx hyps F A) -> + (interp_ctx hyps F B) -> + (interp_ctx hyps F C) -> + (interp_ctx hyps F D). +induction F;intros A B C D H;simpl;auto. +apply IHF;auto. +Qed. + +Lemma weaken : forall hyps F f G, + (interp_ctx hyps F G) -> + (interp_ctx (hyps\f) (F_push f hyps F) G). +induction F;simpl;intros;auto. +apply compose1 with ([[a]]-> G);auto. +Qed. + +Theorem project_In : forall hyps F g, +In g hyps F -> +interp_ctx hyps F [[g]]. +induction F;simpl. +contradiction. +intros g H;destruct H. +subst;apply compose0;simpl;trivial. +apply compose1 with [[g]];auto. +Qed. + +Theorem project : forall hyps F p g, +get p hyps = PSome g-> +interp_ctx hyps F [[g]]. +intros hyps F p g e; apply project_In. +apply get_In with p;assumption. +Qed. + +Implicit Arguments project [hyps p g]. + +Inductive proof:Set := + Ax : positive -> proof +| I_Arrow : proof -> proof +| E_Arrow : positive -> positive -> proof -> proof +| D_Arrow : positive -> proof -> proof -> proof +| E_False : positive -> proof +| I_And: proof -> proof -> proof +| E_And: positive -> proof -> proof +| D_And: positive -> proof -> proof +| I_Or_l: proof -> proof +| I_Or_r: proof -> proof +| E_Or: positive -> proof -> proof -> proof +| D_Or: positive -> proof -> proof +| Cut: form -> proof -> proof -> proof. + +Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). + +Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := + match P with + Ax i => + match get i hyps with + PSome F => form_eq F gl + | _ => false + end +| I_Arrow p => + match gl with + A =>> B => check_proof (hyps \ A) B p + | _ => false + end +| E_Arrow i j p => + match get i hyps,get j hyps with + PSome A,PSome (B =>>C) => + form_eq A B && check_proof (hyps \ C) (gl) p + | _,_ => false + end +| D_Arrow i p1 p2 => + match get i hyps with + PSome ((A =>>B)=>>C) => + (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2) + | _ => false + end +| E_False i => + match get i hyps with + PSome # => true + | _ => false + end +| I_And p1 p2 => + match gl with + A //\\ B => + check_proof hyps A p1 && check_proof hyps B p2 + | _ => false + end +| E_And i p => + match get i hyps with + PSome (A //\\ B) => check_proof (hyps \ A \ B) gl p + | _=> false + end +| D_And i p => + match get i hyps with + PSome (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p + | _=> false + end +| I_Or_l p => + match gl with + (A \\// B) => check_proof hyps A p + | _ => false + end +| I_Or_r p => + match gl with + (A \\// B) => check_proof hyps B p + | _ => false + end +| E_Or i p1 p2 => + match get i hyps with + PSome (A \\// B) => + check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2 + | _=> false + end +| D_Or i p => + match get i hyps with + PSome (A \\// B =>> C) => + (check_proof (hyps \ A=>>C \ B=>>C) gl p) + | _=> false + end +| Cut A p1 p2 => + check_proof hyps A p1 && check_proof (hyps \ A) gl p2 +end. + +Theorem interp_proof: +forall p hyps F gl, +check_proof hyps gl p = true -> interp_ctx hyps F [[gl]]. + +induction p;intros hyps F gl. + +(* cas Axiom *) +Focus 1. +simpl;caseq (get p hyps);clean. +intros f nth_f e;rewrite <- (form_eq_refl e). +apply project with p;trivial. + +(* Cas Arrow_Intro *) +Focus 1. +destruct gl;clean. +simpl;intros. +change (interp_ctx (hyps\gl1) (F_push gl1 hyps F) [[gl2]]). +apply IHp;try constructor;trivial. + +(* Cas Arrow_Elim *) +Focus 1. +simpl check_proof;caseq (get p hyps);clean. +intros f ef;caseq (get p0 hyps);clean. +intros f0 ef0;destruct f0;clean. +caseq (form_eq f f0_1);clean. +simpl;intros e check_p1. +generalize (project F ef) (project F ef0) +(IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1); +clear check_p1 IHp p p0 p1 ef ef0. +simpl. +apply compose3. +rewrite (form_eq_refl e). +auto. + +(* cas Arrow_Destruct *) +Focus 1. +simpl;caseq (get p1 hyps);clean. +intros f ef;destruct f;clean. +destruct f1;clean. +caseq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean. +intros check_p1 check_p2. +generalize (project F ef) +(IHp1 (hyps \ f1_2 =>> f2 \ f1_1) +(F_push f1_1 (hyps \ f1_2 =>> f2) + (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1) +(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2). +simpl;apply compose3;auto. + +(* Cas False_Elim *) +Focus 1. +simpl;caseq (get p hyps);clean. +intros f ef;destruct f;clean. +intros _; generalize (project F ef). +apply compose1;apply False_ind. + +(* Cas And_Intro *) +Focus 1. +simpl;destruct gl;clean. +caseq (check_proof hyps gl1 p1);clean. +intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2). +apply compose2 ;simpl;auto. + +(* cas And_Elim *) +Focus 1. +simpl;caseq (get p hyps);clean. +intros f ef;destruct f;clean. +intro check_p;generalize (project F ef) +(IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p). +simpl;apply compose2;intros [h1 h2];auto. + +(* cas And_Destruct *) +Focus 1. +simpl;caseq (get p hyps);clean. +intros f ef;destruct f;clean. +destruct f1;clean. +intro H;generalize (project F ef) +(IHp (hyps \ f1_1 =>> f1_2 =>> f2) +(F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);clear H;simpl. +apply compose2;auto. + +(* cas Or_Intro_left *) +Focus 1. +destruct gl;clean. +intro Hp;generalize (IHp hyps F gl1 Hp). +apply compose1;simpl;auto. + +(* cas Or_Intro_right *) +Focus 1. +destruct gl;clean. +intro Hp;generalize (IHp hyps F gl2 Hp). +apply compose1;simpl;auto. + +(* cas Or_elim *) +Focus 1. +simpl;caseq (get p1 hyps);clean. +intros f ef;destruct f;clean. +caseq (check_proof (hyps \ f1) gl p2);clean. +intros check_p1 check_p2;generalize (project F ef) +(IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1) +(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2); +simpl;apply compose3;simpl;intro h;destruct h;auto. + +(* cas Or_Destruct *) +Focus 1. +simpl;caseq (get p hyps);clean. +intros f ef;destruct f;clean. +destruct f1;clean. +intro check_p0;generalize (project F ef) +(IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2) +(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) + (F_push (f1_1 =>> f2) hyps F)) gl check_p0);simpl. +apply compose2;auto. + +(* cas Cut *) +Focus 1. +simpl;caseq (check_proof hyps f p1);clean. +intros check_p1 check_p2; +generalize (IHp1 hyps F f check_p1) +(IHp2 (hyps\f) (F_push f hyps F) gl check_p2); +simpl; apply compose2;auto. +Qed. + +Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True. +intros gl prf;caseq (check_proof empty gl prf);intro check_prf. +change (interp_ctx empty F_empty [[gl]]) ; +apply interp_proof with prf;assumption. +trivial. +Qed. + +End with_env. + +(* +(* A small example *) +Parameters A B C D:Prop. +Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C). +exact (Reflect (empty \ A \ B \ C) +([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3]) +(I_Arrow (E_And 1 (E_Or 3 + (I_Or_l (I_And (Ax 2) (Ax 4))) + (I_Or_r (I_And (Ax 2) (Ax 4))))))). +Qed. +Print toto. +*) diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4 new file mode 100644 index 00000000..4cbe8436 --- /dev/null +++ b/plugins/rtauto/g_rtauto.ml4 @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ Refl_tauto.rtauto_tac ] +END + diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml new file mode 100644 index 00000000..562e2e3b --- /dev/null +++ b/plugins/rtauto/proof_search.ml @@ -0,0 +1,546 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* !pruning); + optwrite=(fun b -> pruning:=b)} + +let _ = declare_bool_option opt_pruning + +type form= + Atom of int + | Arrow of form * form + | Bot + | Conjunct of form * form + | Disjunct of form * form + +type tag=int + +let decomp_form=function + Atom i -> Some (i,[]) + | Arrow (f1,f2) -> Some (-1,[f1;f2]) + | Bot -> Some (-2,[]) + | Conjunct (f1,f2) -> Some (-3,[f1;f2]) + | Disjunct (f1,f2) -> Some (-4,[f1;f2]) + +module Fmap=Map.Make(struct type t=form let compare=compare end) + +type sequent = + {rev_hyps: form Intmap.t; + norev_hyps: form Intmap.t; + size:int; + left:int Fmap.t; + right:(int*form) list Fmap.t; + cnx:(int*int*form*form) list; + abs:int option; + gl:form} + +let add_one_arrow i f1 f2 m= + try Fmap.add f1 ((i,f2)::(Fmap.find f1 m)) m with + Not_found -> + Fmap.add f1 [i,f2] m + +type proof = + Ax of int + | I_Arrow of proof + | E_Arrow of int*int*proof + | D_Arrow of int*proof*proof + | E_False of int + | I_And of proof*proof + | E_And of int*proof + | D_And of int*proof + | I_Or_l of proof + | I_Or_r of proof + | E_Or of int*proof*proof + | D_Or of int*proof + | Pop of int*proof + +type rule = + SAx of int + | SI_Arrow + | SE_Arrow of int*int + | SD_Arrow of int + | SE_False of int + | SI_And + | SE_And of int + | SD_And of int + | SI_Or_l + | SI_Or_r + | SE_Or of int + | SD_Or of int + +let add_step s sub = + match s,sub with + SAx i,[] -> Ax i + | SI_Arrow,[p] -> I_Arrow p + | SE_Arrow(i,j),[p] -> E_Arrow (i,j,p) + | SD_Arrow i,[p1;p2] -> D_Arrow (i,p1,p2) + | SE_False i,[] -> E_False i + | SI_And,[p1;p2] -> I_And(p1,p2) + | SE_And i,[p] -> E_And(i,p) + | SD_And i,[p] -> D_And(i,p) + | SI_Or_l,[p] -> I_Or_l p + | SI_Or_r,[p] -> I_Or_r p + | SE_Or i,[p1;p2] -> E_Or(i,p1,p2) + | SD_Or i,[p] -> D_Or(i,p) + | _,_ -> anomaly "add_step: wrong arity" + +type 'a with_deps = + {dep_it:'a; + dep_goal:bool; + dep_hyps:Intset.t} + +type slice= + {proofs_done:proof list; + proofs_todo:sequent with_deps list; + step:rule; + needs_goal:bool; + needs_hyps:Intset.t; + changes_goal:bool; + creates_hyps:Intset.t} + +type state = + Complete of proof + | Incomplete of sequent * slice list + +let project = function + Complete prf -> prf + | Incomplete (_,_) -> anomaly "not a successful state" + +let pop n prf = + let nprf= + match prf.dep_it with + Pop (i,p) -> Pop (i+n,p) + | p -> Pop(n,p) in + {prf with dep_it = nprf} + +let rec fill stack proof = + match stack with + [] -> Complete proof.dep_it + | slice::super -> + if + !pruning && + slice.proofs_done=[] && + not (slice.changes_goal && proof.dep_goal) && + not (Intset.exists + (fun i -> Intset.mem i proof.dep_hyps) + slice.creates_hyps) + then + begin + s_info.pruned_steps<-s_info.pruned_steps+1; + s_info.pruned_branches<- s_info.pruned_branches + + List.length slice.proofs_todo; + let created_here=Intset.cardinal slice.creates_hyps in + s_info.pruned_hyps<-s_info.pruned_hyps+ + List.fold_left + (fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps) + created_here slice.proofs_todo; + fill super (pop (Intset.cardinal slice.creates_hyps) proof) + end + else + let dep_hyps= + Intset.union slice.needs_hyps + (Intset.diff proof.dep_hyps slice.creates_hyps) in + let dep_goal= + slice.needs_goal || + ((not slice.changes_goal) && proof.dep_goal) in + let proofs_done= + proof.dep_it::slice.proofs_done in + match slice.proofs_todo with + [] -> + fill super {dep_it = + add_step slice.step (List.rev proofs_done); + dep_goal = dep_goal; + dep_hyps = dep_hyps} + | current::next -> + let nslice= + {proofs_done=proofs_done; + proofs_todo=next; + step=slice.step; + needs_goal=dep_goal; + needs_hyps=dep_hyps; + changes_goal=current.dep_goal; + creates_hyps=current.dep_hyps} in + Incomplete (current.dep_it,nslice::super) + +let append stack (step,subgoals) = + s_info.created_steps<-s_info.created_steps+1; + match subgoals with + [] -> + s_info.branch_successes<-s_info.branch_successes+1; + fill stack {dep_it=add_step step.dep_it []; + dep_goal=step.dep_goal; + dep_hyps=step.dep_hyps} + | hd :: next -> + s_info.created_branches<- + s_info.created_branches+List.length next; + let slice= + {proofs_done=[]; + proofs_todo=next; + step=step.dep_it; + needs_goal=step.dep_goal; + needs_hyps=step.dep_hyps; + changes_goal=hd.dep_goal; + creates_hyps=hd.dep_hyps} in + Incomplete(hd.dep_it,slice::stack) + +let embed seq= + {dep_it=seq; + dep_goal=false; + dep_hyps=Intset.empty} + +let change_goal seq gl= + {seq with + dep_it={seq.dep_it with gl=gl}; + dep_goal=true} + +let add_hyp seqwd f= + s_info.created_hyps<-s_info.created_hyps+1; + let seq=seqwd.dep_it in + let num = seq.size+1 in + let left = Fmap.add f num seq.left in + let cnx,right= + try + let l=Fmap.find f seq.right in + List.fold_right (fun (i,f0) l0 -> (num,i,f,f0)::l0) l seq.cnx, + Fmap.remove f seq.right + with Not_found -> seq.cnx,seq.right in + let nseq= + match f with + Bot -> + {seq with + left=left; + right=right; + size=num; + abs=Some num; + cnx=cnx} + | Atom _ -> + {seq with + size=num; + left=left; + right=right; + cnx=cnx} + | Conjunct (_,_) | Disjunct (_,_) -> + {seq with + rev_hyps=Intmap.add num f seq.rev_hyps; + size=num; + left=left; + right=right; + cnx=cnx} + | Arrow (f1,f2) -> + let ncnx,nright= + try + let i = Fmap.find f1 seq.left in + (i,num,f1,f2)::cnx,right + with Not_found -> + cnx,(add_one_arrow num f1 f2 right) in + match f1 with + Conjunct (_,_) | Disjunct (_,_) -> + {seq with + rev_hyps=Intmap.add num f seq.rev_hyps; + size=num; + left=left; + right=nright; + cnx=ncnx} + | Arrow(_,_) -> + {seq with + norev_hyps=Intmap.add num f seq.norev_hyps; + size=num; + left=left; + right=nright; + cnx=ncnx} + | _ -> + {seq with + size=num; + left=left; + right=nright; + cnx=ncnx} in + {seqwd with + dep_it=nseq; + dep_hyps=Intset.add num seqwd.dep_hyps} + +exception Here_is of (int*form) + +let choose m= + try + Intmap.iter (fun i f -> raise (Here_is (i,f))) m; + raise Not_found + with + Here_is (i,f) -> (i,f) + + +let search_or seq= + match seq.gl with + Disjunct (f1,f2) -> + [{dep_it = SI_Or_l; + dep_goal = true; + dep_hyps = Intset.empty}, + [change_goal (embed seq) f1]; + {dep_it = SI_Or_r; + dep_goal = true; + dep_hyps = Intset.empty}, + [change_goal (embed seq) f2]] + | _ -> [] + +let search_norev seq= + let goals=ref (search_or seq) in + let add_one i f= + match f with + Arrow (Arrow (f1,f2),f3) -> + let nseq = + {seq with norev_hyps=Intmap.remove i seq.norev_hyps} in + goals:= + ({dep_it=SD_Arrow(i); + dep_goal=false; + dep_hyps=Intset.singleton i}, + [add_hyp + (add_hyp + (change_goal (embed nseq) f2) + (Arrow(f2,f3))) + f1; + add_hyp (embed nseq) f3]):: !goals + | _ -> anomaly "search_no_rev: can't happen" in + Intmap.iter add_one seq.norev_hyps; + List.rev !goals + +let search_in_rev_hyps seq= + try + let i,f=choose seq.rev_hyps in + let make_step step= + {dep_it=step; + dep_goal=false; + dep_hyps=Intset.singleton i} in + let nseq={seq with rev_hyps=Intmap.remove i seq.rev_hyps} in + match f with + Conjunct (f1,f2) -> + [make_step (SE_And(i)), + [add_hyp (add_hyp (embed nseq) f1) f2]] + | Disjunct (f1,f2) -> + [make_step (SE_Or(i)), + [add_hyp (embed nseq) f1;add_hyp (embed nseq) f2]] + | Arrow (Conjunct (f1,f2),f0) -> + [make_step (SD_And(i)), + [add_hyp (embed nseq) (Arrow (f1,Arrow (f2,f0)))]] + | Arrow (Disjunct (f1,f2),f0) -> + [make_step (SD_Or(i)), + [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]] + | _ -> anomaly "search_in_rev_hyps: can't happen" + with + Not_found -> search_norev seq + +let search_rev seq= + match seq.cnx with + (i,j,f1,f2)::next -> + let nseq= + match f1 with + Conjunct (_,_) | Disjunct (_,_) -> + {seq with cnx=next; + rev_hyps=Intmap.remove j seq.rev_hyps} + | Arrow (_,_) -> + {seq with cnx=next; + norev_hyps=Intmap.remove j seq.norev_hyps} + | _ -> + {seq with cnx=next} in + [{dep_it=SE_Arrow(i,j); + dep_goal=false; + dep_hyps=Intset.add i (Intset.singleton j)}, + [add_hyp (embed nseq) f2]] + | [] -> + match seq.gl with + Arrow (f1,f2) -> + [{dep_it=SI_Arrow; + dep_goal=true; + dep_hyps=Intset.empty}, + [add_hyp (change_goal (embed seq) f2) f1]] + | Conjunct (f1,f2) -> + [{dep_it=SI_And; + dep_goal=true; + dep_hyps=Intset.empty},[change_goal (embed seq) f1; + change_goal (embed seq) f2]] + | _ -> search_in_rev_hyps seq + +let search_all seq= + match seq.abs with + Some i -> + [{dep_it=SE_False (i); + dep_goal=false; + dep_hyps=Intset.singleton i},[]] + | None -> + try + let ax = Fmap.find seq.gl seq.left in + [{dep_it=SAx (ax); + dep_goal=true; + dep_hyps=Intset.singleton ax},[]] + with Not_found -> search_rev seq + +let bare_sequent = embed + {rev_hyps=Intmap.empty; + norev_hyps=Intmap.empty; + size=0; + left=Fmap.empty; + right=Fmap.empty; + cnx=[]; + abs=None; + gl=Bot} + +let init_state hyps gl= + let init = change_goal bare_sequent gl in + let goal=List.fold_right (fun (_,f,_) seq ->add_hyp seq f) hyps init in + Incomplete (goal.dep_it,[]) + +let success= function + Complete _ -> true + | Incomplete (_,_) -> false + +let branching = function + Incomplete (seq,stack) -> + check_for_interrupt (); + let successors = search_all seq in + let _ = + match successors with + [] -> s_info.branch_failures<-s_info.branch_failures+1 + | _::next -> + s_info.nd_branching<-s_info.nd_branching+List.length next in + List.map (append stack) successors + | Complete prf -> anomaly "already succeeded" + +open Pp + +let rec pp_form = + function + Arrow(f1,f2) -> (pp_or f1) ++ (str " -> ") ++ (pp_form f2) + | f -> pp_or f +and pp_or = function + Disjunct(f1,f2) -> + (pp_or f1) ++ (str " \\/ ") ++ (pp_and f2) + | f -> pp_and f +and pp_and = function + Conjunct(f1,f2) -> + (pp_and f1) ++ (str " /\\ ") ++ (pp_atom f2) + | f -> pp_atom f +and pp_atom= function + Bot -> str "#" + | Atom n -> int n + | f -> str "(" ++ hv 2 (pp_form f) ++ str ")" + +let pr_form f = msg (pp_form f) + +let pp_intmap map = + let pp=ref (str "") in + Intmap.iter (fun i obj -> pp:= (!pp ++ + pp_form obj ++ cut ())) map; + str "{ " ++ v 0 (!pp) ++ str " }" + +let pp_list pp_obj l= +let pp=ref (str "") in + List.iter (fun o -> pp := !pp ++ (pp_obj o) ++ str ", ") l; + str "[ " ++ !pp ++ str "]" + +let pp_mapint map = + let pp=ref (str "") in + Fmap.iter (fun obj l -> pp:= (!pp ++ + pp_form obj ++ str " => " ++ + pp_list (fun (i,f) -> pp_form f) l ++ + cut ()) ) map; + str "{ " ++ vb 0 ++ (!pp) ++ str " }" ++ close () + +let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2 + +let pp_gl gl= cut () ++ + str "{ " ++ vb 0 ++ + begin + match gl.abs with + None -> str "" + | Some i -> str "ABSURD" ++ cut () + end ++ + str "rev =" ++ pp_intmap gl.rev_hyps ++ cut () ++ + str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++ + str "arrows=" ++ pp_mapint gl.right ++ cut () ++ + str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++ + str "goal =" ++ pp_form gl.gl ++ str " }" ++ close () + +let pp = + function + Incomplete(gl,ctx) -> msgnl (pp_gl gl) + | _ -> msg (str "") + +let pp_info () = + let count_info = + if !pruning then + str "Proof steps : " ++ + int s_info.created_steps ++ str " created / " ++ + int s_info.pruned_steps ++ str " pruned" ++ fnl () ++ + str "Proof branches : " ++ + int s_info.created_branches ++ str " created / " ++ + int s_info.pruned_branches ++ str " pruned" ++ fnl () ++ + str "Hypotheses : " ++ + int s_info.created_hyps ++ str " created / " ++ + int s_info.pruned_hyps ++ str " pruned" ++ fnl () + else + str "Pruning is off" ++ fnl () ++ + str "Proof steps : " ++ + int s_info.created_steps ++ str " created" ++ fnl () ++ + str "Proof branches : " ++ + int s_info.created_branches ++ str " created" ++ fnl () ++ + str "Hypotheses : " ++ + int s_info.created_hyps ++ str " created" ++ fnl () in + msgnl + ( str "Proof-search statistics :" ++ fnl () ++ + count_info ++ + str "Branch ends: " ++ + int s_info.branch_successes ++ str " successes / " ++ + int s_info.branch_failures ++ str " failures" ++ fnl () ++ + str "Non-deterministic choices : " ++ + int s_info.nd_branching ++ str " branches") + + + diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli new file mode 100644 index 00000000..e52f6bbd --- /dev/null +++ b/plugins/rtauto/proof_search.mli @@ -0,0 +1,49 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* proof + +val init_state : ('a * form * 'b) list -> form -> state + +val branching: state -> state list + +val success: state -> bool + +val pp: state -> unit + +val pr_form : form -> unit + +val reset_info : unit -> unit + +val pp_info : unit -> unit diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml new file mode 100644 index 00000000..23cb0705 --- /dev/null +++ b/plugins/rtauto/refl_tauto.ml @@ -0,0 +1,337 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Closure.whd_val infos (Closure.inject t)) + +let special_nf gl= + let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in + (fun t -> Closure.norm_val infos (Closure.inject t)) + +type atom_env= + {mutable next:int; + mutable env:(constr*int) list} + +let make_atom atom_env term= + try + let (_,i)= + List.find (fun (t,_)-> eq_constr term t) atom_env.env + in Atom i + with Not_found -> + let i=atom_env.next in + atom_env.env <- (term,i)::atom_env.env; + atom_env.next<- i + 1; + Atom i + +let rec make_form atom_env gls term = + let normalize=special_nf gls in + let cciterm=special_whd gls term in + match kind_of_term cciterm with + Prod(_,a,b) -> + if not (dependent (mkRel 1) b) && + Retyping.get_sort_family_of + (pf_env gls) (Tacmach.project gls) a = InProp + then + let fa=make_form atom_env gls a in + let fb=make_form atom_env gls b in + Arrow (fa,fb) + else + make_atom atom_env (normalize term) + | Cast(a,_,_) -> + make_form atom_env gls a + | Ind ind -> + if ind = Lazy.force li_False then + Bot + else + make_atom atom_env (normalize term) + | App(hd,argv) when Array.length argv = 2 -> + begin + try + let ind = destInd hd in + if ind = Lazy.force li_and then + let fa=make_form atom_env gls argv.(0) in + let fb=make_form atom_env gls argv.(1) in + Conjunct (fa,fb) + else if ind = Lazy.force li_or then + let fa=make_form atom_env gls argv.(0) in + let fb=make_form atom_env gls argv.(1) in + Disjunct (fa,fb) + else make_atom atom_env (normalize term) + with Invalid_argument _ -> make_atom atom_env (normalize term) + end + | _ -> make_atom atom_env (normalize term) + +let rec make_hyps atom_env gls lenv = function + [] -> [] + | (_,Some body,typ)::rest -> + make_hyps atom_env gls (typ::body::lenv) rest + | (id,None,typ)::rest -> + let hrec= + make_hyps atom_env gls (typ::lenv) rest in + if List.exists (dependent (mkVar id)) lenv || + (Retyping.get_sort_family_of + (pf_env gls) (Tacmach.project gls) typ <> InProp) + then + hrec + else + (id,make_form atom_env gls typ)::hrec + +let rec build_pos n = + if n<=1 then force node_count l_xH + else if n land 1 = 0 then + mkApp (force node_count l_xO,[|build_pos (n asr 1)|]) + else + mkApp (force node_count l_xI,[|build_pos (n asr 1)|]) + +let rec build_form = function + Atom n -> mkApp (force node_count l_Atom,[|build_pos n|]) + | Arrow (f1,f2) -> + mkApp (force node_count l_Arrow,[|build_form f1;build_form f2|]) + | Bot -> force node_count l_Bot + | Conjunct (f1,f2) -> + mkApp (force node_count l_Conjunct,[|build_form f1;build_form f2|]) + | Disjunct (f1,f2) -> + mkApp (force node_count l_Disjunct,[|build_form f1;build_form f2|]) + +let rec decal k = function + [] -> k + | (start,delta)::rest -> + if k>start then + k - delta + else + decal k rest + +let add_pop size d pops= + match pops with + [] -> [size+d,d] + | (_,sum)::_ -> (size+sum,sum+d)::pops + +let rec build_proof pops size = + function + Ax i -> + mkApp (force step_count l_Ax, + [|build_pos (decal i pops)|]) + | I_Arrow p -> + mkApp (force step_count l_I_Arrow, + [|build_proof pops (size + 1) p|]) + | E_Arrow(i,j,p) -> + mkApp (force step_count l_E_Arrow, + [|build_pos (decal i pops); + build_pos (decal j pops); + build_proof pops (size + 1) p|]) + | D_Arrow(i,p1,p2) -> + mkApp (force step_count l_D_Arrow, + [|build_pos (decal i pops); + build_proof pops (size + 2) p1; + build_proof pops (size + 1) p2|]) + | E_False i -> + mkApp (force step_count l_E_False, + [|build_pos (decal i pops)|]) + | I_And(p1,p2) -> + mkApp (force step_count l_I_And, + [|build_proof pops size p1; + build_proof pops size p2|]) + | E_And(i,p) -> + mkApp (force step_count l_E_And, + [|build_pos (decal i pops); + build_proof pops (size + 2) p|]) + | D_And(i,p) -> + mkApp (force step_count l_D_And, + [|build_pos (decal i pops); + build_proof pops (size + 1) p|]) + | I_Or_l(p) -> + mkApp (force step_count l_I_Or_l, + [|build_proof pops size p|]) + | I_Or_r(p) -> + mkApp (force step_count l_I_Or_r, + [|build_proof pops size p|]) + | E_Or(i,p1,p2) -> + mkApp (force step_count l_E_Or, + [|build_pos (decal i pops); + build_proof pops (size + 1) p1; + build_proof pops (size + 1) p2|]) + | D_Or(i,p) -> + mkApp (force step_count l_D_Or, + [|build_pos (decal i pops); + build_proof pops (size + 2) p|]) + | Pop(d,p) -> + build_proof (add_pop size d pops) size p + +let build_env gamma= + List.fold_right (fun (p,_) e -> + mkApp(force node_count l_push,[|mkProp;p;e|])) + gamma.env (mkApp (force node_count l_empty,[|mkProp|])) + +open Goptions + +let verbose = ref false + +let opt_verbose= + {optsync=true; + optname="Rtauto Verbose"; + optkey=["Rtauto";"Verbose"]; + optread=(fun () -> !verbose); + optwrite=(fun b -> verbose:=b)} + +let _ = declare_bool_option opt_verbose + +let check = ref false + +let opt_check= + {optsync=true; + optname="Rtauto Check"; + optkey=["Rtauto";"Check"]; + optread=(fun () -> !check); + optwrite=(fun b -> check:=b)} + +let _ = declare_bool_option opt_check + +open Pp + +let rtauto_tac gls= + Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"]; + let gamma={next=1;env=[]} in + let gl=gls.it.evar_concl in + let _= + if Retyping.get_sort_family_of + (pf_env gls) (Tacmach.project gls) gl <> InProp + then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in + let glf=make_form gamma gls gl in + let hyps=make_hyps gamma gls [gl] + (Environ.named_context_of_val gls.it.evar_hyps) in + let formula= + List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in + let search_fun = + if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then + Search.debug_depth_first + else + Search.depth_first in + let _ = + begin + reset_info (); + if !verbose then + msgnl (str "Starting proof-search ..."); + end in + let search_start_time = System.get_time () in + let prf = + try project (search_fun (init_state [] formula)) + with Not_found -> + errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in + let search_end_time = System.get_time () in + let _ = if !verbose then + begin + msgnl (str "Proof tree found in " ++ + System.fmt_time_difference search_start_time search_end_time); + pp_info (); + msgnl (str "Building proof term ... ") + end in + let build_start_time=System.get_time () in + let _ = step_count := 0; node_count := 0 in + let main = mkApp (force node_count l_Reflect, + [|build_env gamma; + build_form formula; + build_proof [] 0 prf|]) in + let term= + Term.applist (main,List.rev_map (fun (id,_) -> mkVar id) hyps) in + let build_end_time=System.get_time () in + let _ = if !verbose then + begin + msgnl (str "Proof term built in " ++ + System.fmt_time_difference build_start_time build_end_time ++ + fnl () ++ + str "Proof size : " ++ int !step_count ++ + str " steps" ++ fnl () ++ + str "Proof term size : " ++ int (!step_count+ !node_count) ++ + str " nodes (constants)" ++ fnl () ++ + str "Giving proof term to Coq ... ") + end in + let tac_start_time = System.get_time () in + let result= + if !check then + Tactics.exact_check term gls + else + Tactics.exact_no_check term gls in + let tac_end_time = System.get_time () in + let _ = + if !check then msgnl (str "Proof term type-checking is on"); + if !verbose then + msgnl (str "Internal tactic executed in " ++ + System.fmt_time_difference tac_start_time tac_end_time) in + result + diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli new file mode 100644 index 00000000..a6d68a22 --- /dev/null +++ b/plugins/rtauto/refl_tauto.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + Proof_type.goal Tacmach.sigma -> Term.types -> Proof_search.form + +val make_hyps : + atom_env -> + Proof_type.goal Tacmach.sigma -> + Term.types list -> + (Names.identifier * Term.types option * Term.types) list -> + (Names.identifier * Proof_search.form) list + +val rtauto_tac : Proof_type.tactic diff --git a/plugins/rtauto/rtauto_plugin.mllib b/plugins/rtauto/rtauto_plugin.mllib new file mode 100644 index 00000000..0e346044 --- /dev/null +++ b/plugins/rtauto/rtauto_plugin.mllib @@ -0,0 +1,4 @@ +Proof_search +Refl_tauto +G_rtauto +Rtauto_plugin_mod diff --git a/plugins/rtauto/vo.itarget b/plugins/rtauto/vo.itarget new file mode 100644 index 00000000..4c9364ad --- /dev/null +++ b/plugins/rtauto/vo.itarget @@ -0,0 +1,2 @@ +Bintree.vo +Rtauto.vo diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v new file mode 100644 index 00000000..e5a4c8d1 --- /dev/null +++ b/plugins/setoid_ring/ArithRing.v @@ -0,0 +1,60 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr:(N_of_nat t) + | _ => constr:InitialRing.NotConstant + end. + +Ltac Ss_to_add f acc := + match f with + | S ?f1 => Ss_to_add f1 (S acc) + | _ => constr:(acc + f)%nat + end. + +Ltac natprering := + match goal with + |- context C [S ?p] => + match p with + O => fail 1 (* avoid replacing 1 with 1+0 ! *) + | p => match isnatcst p with + | true => fail 1 + | false => let v := Ss_to_add p (S 0) in + fold v; natprering + end + end + | _ => idtac + end. + +Add Ring natr : natSRth + (morphism nat_morph_N, constants [natcst], preprocess [natprering]). + diff --git a/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v new file mode 100644 index 00000000..d403c9ef --- /dev/null +++ b/plugins/setoid_ring/BinList.v @@ -0,0 +1,93 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* tail l + | xO p => jump p (jump p l) + | xI p => jump p (jump p (tail l)) + end. + + Fixpoint nth (p:positive) (l:list A) {struct p} : A:= + match p with + | xH => hd default l + | xO p => nth p (jump p l) + | xI p => nth p (jump p (tail l)) + end. + + Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l). + Proof. + induction j;simpl;intros. + repeat rewrite IHj;trivial. + repeat rewrite IHj;trivial. + trivial. + Qed. + + Lemma jump_Psucc : forall j l, + (jump (Psucc j) l) = (jump 1 (jump j l)). + Proof. + induction j;simpl;intros. + repeat rewrite IHj;simpl;repeat rewrite jump_tl;trivial. + repeat rewrite jump_tl;trivial. + trivial. + Qed. + + Lemma jump_Pplus : forall i j l, + (jump (i + j) l) = (jump i (jump j l)). + Proof. + induction i;intros. + rewrite xI_succ_xO;rewrite Pplus_one_succ_r. + rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. + repeat rewrite IHi. + rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial. + rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. + repeat rewrite IHi;trivial. + rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial. + Qed. + + Lemma jump_Pdouble_minus_one : forall i l, + (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)). + Proof. + induction i;intros;simpl. + repeat rewrite jump_tl;trivial. + rewrite IHi. do 2 rewrite <- jump_tl;rewrite IHi;trivial. + trivial. + Qed. + + + Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l). + Proof. + induction p;simpl;intros. + rewrite <-jump_tl;rewrite IHp;trivial. + rewrite <-jump_tl;rewrite IHp;trivial. + trivial. + Qed. + + Lemma nth_Pdouble_minus_one : + forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). + Proof. + induction p;simpl;intros. + repeat rewrite jump_tl;trivial. + rewrite jump_Pdouble_minus_one. + repeat rewrite <- jump_tl;rewrite IHp;trivial. + trivial. + Qed. + +End MakeBinList. + + diff --git a/plugins/setoid_ring/Field.v b/plugins/setoid_ring/Field.v new file mode 100644 index 00000000..a944ba5f --- /dev/null +++ b/plugins/setoid_ring/Field.v @@ -0,0 +1,10 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + match t with + | (radd ?t1 ?t2) => + fun _ => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(FEadd e1 e2) + | (rmul ?t1 ?t2) => + fun _ => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(FEmul e1 e2) + | (rsub ?t1 ?t2) => + fun _ => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(FEsub e1 e2) + | (ropp ?t1) => + fun _ => let e1 := mkP t1 in constr:(FEopp e1) + | (rdiv ?t1 ?t2) => + fun _ => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(FEdiv e1 e2) + | (rinv ?t1) => + fun _ => let e1 := mkP t1 in constr:(FEinv e1) + | (rpow ?t1 ?n) => + match CstPow n with + | InitialRing.NotConstant => + fun _ => + let p := Find_at t fv in + constr:(@FEX C p) + | ?c => fun _ => let e1 := mkP t1 in constr:(FEpow e1 c) + end + | _ => + fun _ => + let p := Find_at t fv in + constr:(@FEX C p) + end + | ?c => fun _ => constr:(FEc c) + end in + f () + in mkP t. + +Ltac FFV Cst CstPow add mul sub opp div inv pow t fv := + let rec TFV t fv := + match Cst t with + | InitialRing.NotConstant => + match t with + | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) + | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) + | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) + | (opp ?t1) => TFV t1 fv + | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) + | (inv ?t1) => TFV t1 fv + | (pow ?t1 ?n) => + match CstPow n with + | InitialRing.NotConstant => + AddFvTail t fv + | _ => TFV t1 fv + end + | _ => AddFvTail t fv + end + | _ => fv + end + in TFV t fv. + +(* packaging the field structure *) + +(* TODO: inline PackField into field_lookup *) +Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post := + let FLD := + match type of L1 with + | context [req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv + ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] => + (fun proj => + proj Cst_tac Pow_tac pre post + req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok) + | _ => fail 1 "field anomaly: bad correctness lemma (parse)" + end in + F FLD. + +Ltac get_FldPre FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + pre). + +Ltac get_FldPost FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + post). + +Ltac get_L1 FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + L1). + +Ltac get_SimplifyEqLemma FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + L2). + +Ltac get_SimplifyLemma FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + L3). + +Ltac get_L4 FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + L4). + +Ltac get_CondLemma FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + cond_ok). + +Ltac get_FldEq FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + req). + +Ltac get_FldCarrier FLD := + let req := get_FldEq FLD in + relation_carrier req. + +Ltac get_RingFV FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + FV Cst_tac Pow_tac radd rmul rsub ropp rpow). + +Ltac get_FFV FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow). + +Ltac get_RingMeta FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow). + +Ltac get_Meta FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow). + +Ltac get_Hyp_tac FLD := + FLD ltac: + (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C + L1 L2 L3 L4 cond_ok => + let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in + fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH). + +Ltac get_FEeval FLD := + let L1 := get_L1 FLD in + match type of L1 with + | context + [(@FEeval + ?R ?r0 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] => + constr:(@FEeval R r0 add mul sub opp div inv C phi Cpow powphi pow) + | _ => fail 1 "field anomaly: bad correctness lemma (get_FEeval)" + end. + +(* simplifying the non-zero condition... *) + +Ltac fold_field_cond req := + let rec fold_concl t := + match t with + ?x /\ ?y => + let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy) + | req ?x ?y -> False => constr:(~ req x y) + | _ => t + end in + let ft := fold_concl Get_goal in + change ft. + +Ltac simpl_PCond FLD := + let req := get_FldEq FLD in + let lemma := get_CondLemma FLD in + try apply lemma; + protect_fv "field_cond"; + fold_field_cond req; + try exact I. + +Ltac simpl_PCond_BEURK FLD := + let req := get_FldEq FLD in + let lemma := get_CondLemma FLD in + apply lemma; + protect_fv "field_cond"; + fold_field_cond req. + +(* Rewriting (field_simplify) *) +Ltac Field_norm_gen f n FLD lH rl := + let mkFV := get_RingFV FLD in + let mkFFV := get_FFV FLD in + let mkFE := get_Meta FLD in + let fv0 := FV_hypo_tac mkFV ltac:(get_FldEq FLD) lH in + let lemma_tac fv kont := + let lemma := get_SimplifyLemma FLD in + (* reify equations of the context *) + let lpe := get_Hyp_tac FLD fv lH in + let vlpe := fresh "hyps" in + pose (vlpe := lpe); + let prh := proofHyp_tac lH in + (* compute the normal form of the reified hyps *) + let vlmp := fresh "hyps'" in + let vlmp_eq := fresh "hyps_eq" in + let mk_monpol := get_MonPol lemma in + compute_assertion vlmp_eq vlmp (mk_monpol vlpe); + (* partially instantiate the lemma *) + let lem := fresh "f_rw_lemma" in + (assert (lem := lemma n vlpe fv prh vlmp vlmp_eq) + || fail "type error when building the rewriting lemma"); + (* continuation will call main_tac for all reified terms *) + kont lem; + (* at the end, cleanup *) + (clear lem vlmp_eq vlmp vlpe||idtac"Field_norm_gen:cleanup failed") in + (* each instance of the lemma is simplified then passed to f *) + let main_tac H := protect_fv "field" in H; f H in + (* generate and use equations for each expression *) + ReflexiveRewriteTactic mkFFV mkFE lemma_tac main_tac fv0 rl; + try simpl_PCond FLD. + +Ltac Field_simplify_gen f FLD lH rl := + get_FldPre FLD (); + Field_norm_gen f ring_subst_niter FLD lH rl; + get_FldPost FLD (). + +Ltac Field_simplify := + Field_simplify_gen ltac:(fun H => rewrite H). + +Tactic Notation (at level 0) "field_simplify" constr_list(rl) := + let G := Get_goal in + field_lookup (PackField Field_simplify) [] rl G. + +Tactic Notation (at level 0) + "field_simplify" "[" constr_list(lH) "]" constr_list(rl) := + let G := Get_goal in + field_lookup (PackField Field_simplify) [lH] rl G. + +Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= + let G := Get_goal in + let t := type of H in + let g := fresh "goal" in + set (g:= G); + revert H; + field_lookup (PackField Field_simplify) [] rl t; + intro H; + unfold g;clear g. + +Tactic Notation "field_simplify" + "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):= + let G := Get_goal in + let t := type of H in + let g := fresh "goal" in + set (g:= G); + revert H; + field_lookup (PackField Field_simplify) [lH] rl t; + intro H; + unfold g;clear g. + +(* +Ltac Field_simplify_in hyp:= + Field_simplify_gen ltac:(fun H => rewrite H in hyp). + +Tactic Notation (at level 0) + "field_simplify" constr_list(rl) "in" hyp(h) := + let t := type of h in + field_lookup (Field_simplify_in h) [] rl t. + +Tactic Notation (at level 0) + "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) := + let t := type of h in + field_lookup (Field_simplify_in h) [lH] rl t. +*) + +(** Generic tactic for solving equations *) + +Ltac Field_Scheme Simpl_tac n lemma FLD lH := + let req := get_FldEq FLD in + let mkFV := get_RingFV FLD in + let mkFFV := get_FFV FLD in + let mkFE := get_Meta FLD in + let Main_eq t1 t2 := + let fv := FV_hypo_tac mkFV req lH in + let fv := mkFFV t1 fv in + let fv := mkFFV t2 fv in + let lpe := get_Hyp_tac FLD fv lH in + let prh := proofHyp_tac lH in + let vlpe := fresh "list_hyp" in + let fe1 := mkFE t1 fv in + let fe2 := mkFE t2 fv in + pose (vlpe := lpe); + let nlemma := fresh "field_lemma" in + (assert (nlemma := lemma n fv vlpe fe1 fe2 prh) + || fail "field anomaly:failed to build lemma"); + ProveLemmaHyps nlemma + ltac:(fun ilemma => + apply ilemma + || fail "field anomaly: failed in applying lemma"; + [ Simpl_tac | simpl_PCond FLD]); + clear nlemma; + subst vlpe in + OnEquation req Main_eq. + +(* solve completely a field equation, leaving non-zero conditions to be + proved (field) *) + +Ltac FIELD FLD lH rl := + let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in + let lemma := get_L1 FLD in + get_FldPre FLD (); + Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; + try exact I; + get_FldPost FLD(). + +Tactic Notation (at level 0) "field" := + let G := Get_goal in + field_lookup (PackField FIELD) [] G. + +Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" := + let G := Get_goal in + field_lookup (PackField FIELD) [lH] G. + +(* transforms a field equation to an equivalent (simplified) ring equation, + and leaves non-zero conditions to be proved (field_simplify_eq) *) +Ltac FIELD_SIMPL FLD lH rl := + let Simpl := (protect_fv "field") in + let lemma := get_SimplifyEqLemma FLD in + get_FldPre FLD (); + Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; + get_FldPost FLD (). + +Tactic Notation (at level 0) "field_simplify_eq" := + let G := Get_goal in + field_lookup (PackField FIELD_SIMPL) [] G. + +Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := + let G := Get_goal in + field_lookup (PackField FIELD_SIMPL) [lH] G. + +(* Same as FIELD_SIMPL but in hypothesis *) + +Ltac Field_simplify_eq n FLD lH := + let req := get_FldEq FLD in + let mkFV := get_RingFV FLD in + let mkFFV := get_FFV FLD in + let mkFE := get_Meta FLD in + let lemma := get_L4 FLD in + let hyp := fresh "hyp" in + intro hyp; + OnEquationHyp req hyp ltac:(fun t1 t2 => + let fv := FV_hypo_tac mkFV req lH in + let fv := mkFFV t1 fv in + let fv := mkFFV t2 fv in + let lpe := get_Hyp_tac FLD fv lH in + let prh := proofHyp_tac lH in + let fe1 := mkFE t1 fv in + let fe2 := mkFE t2 fv in + let vlpe := fresh "vlpe" in + ProveLemmaHyps (lemma n fv lpe fe1 fe2 prh) + ltac:(fun ilemma => + match type of ilemma with + | req _ _ -> _ -> ?EQ => + let tmp := fresh "tmp" in + assert (tmp : EQ); + [ apply ilemma; [ exact hyp | simpl_PCond_BEURK FLD] + | protect_fv "field" in tmp; revert tmp ]; + clear hyp + end)). + +Ltac FIELD_SIMPL_EQ FLD lH rl := + get_FldPre FLD (); + Field_simplify_eq Ring_tac.ring_subst_niter FLD lH; + get_FldPost FLD (). + +Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) := + let t := type of H in + generalize H; + field_lookup (PackField FIELD_SIMPL_EQ) [] t; + [ try exact I + | clear H;intro H]. + + +Tactic Notation (at level 0) + "field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) := + let t := type of H in + generalize H; + field_lookup (PackField FIELD_SIMPL_EQ) [lH] t; + [ try exact I + |clear H;intro H]. + +(* More generic tactics to build variants of field *) + +(* This tactic reifies c and pass to F: + - the FLD structure gathering all info in the field DB + - the atom list + - the expression (FExpr) + *) +Ltac gen_with_field F c := + let MetaExpr FLD _ rl := + let R := get_FldCarrier FLD in + let mkFFV := get_FFV FLD in + let mkFE := get_Meta FLD in + let csr := + match rl with + | List.cons ?r _ => r + | _ => fail 1 "anomaly: ill-formed list" + end in + let fv := mkFFV csr (@List.nil R) in + let expr := mkFE csr fv in + F FLD fv expr in + field_lookup (PackField MetaExpr) [] (c=c). + + +(* pushes the equation expr = ope(expr) in the goal, and + discharge it with field *) +Ltac prove_field_eqn ope FLD fv expr := + let res := ope expr in + let expr' := fresh "input_expr" in + pose (expr' := expr); + let res' := fresh "result" in + pose (res' := res); + let lemma := get_L1 FLD in + let lemma := + constr:(lemma O fv List.nil expr' res' I List.nil (refl_equal _)) in + let ty := type of lemma in + let lhs := match ty with + forall _, ?lhs=_ -> _ => lhs + end in + let rhs := match ty with + forall _, _=_ -> forall _, ?rhs=_ -> _ => rhs + end in + let lhs' := fresh "lhs" in let lhs_eq := fresh "lhs_eq" in + let rhs' := fresh "rhs" in let rhs_eq := fresh "rhs_eq" in + compute_assertion lhs_eq lhs' lhs; + compute_assertion rhs_eq rhs' rhs; + let H := fresh "fld_eqn" in + refine (_ (lemma lhs' lhs_eq rhs' rhs_eq _ _)); + (* main goal *) + [intro H;protect_fv "field" in H; revert H + (* ring-nf(lhs') = ring-nf(rhs') *) + | vm_compute; reflexivity || fail "field cannot prove this equality" + (* denominator condition *) + | simpl_PCond FLD]; + clear lhs_eq rhs_eq; subst lhs' rhs'. + +Ltac prove_with_field ope c := + gen_with_field ltac:(prove_field_eqn ope) c. + +(* Prove an equation x=ope(x) and rewrite with it *) +Ltac prove_rw ope x := + prove_with_field ope x; + [ let H := fresh "Heq_maple" in + intro H; rewrite H; clear H + |..]. + +(* Apply ope (FExpr->FExpr) on an expression *) +Ltac reduce_field_expr ope kont FLD fv expr := + let evfun := get_FEeval FLD in + let res := ope expr in + let c := (eval simpl_field_expr in (evfun fv res)) in + kont c. + +(* Hack to let a Ltac return a term in the context of a primitive tactic *) +Ltac return_term x := generalize (refl_equal x). +Ltac get_term := + match goal with + | |- ?x = _ -> _ => x + end. + +(* Turn an operation on field expressions (FExpr) into a reduction + on terms (in the field carrier). Because of field_lookup, + the tactic cannot return a term directly, so it is returned + via the conclusion of the goal (return_term). *) +Ltac reduce_field_ope ope c := + gen_with_field ltac:(reduce_field_expr ope return_term) c. + + +(* Adding a new field *) + +Ltac ring_of_field f := + match type of f with + | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f) + | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f) + | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f) + end. + +Ltac coerce_to_almost_field set ext f := + match type of f with + | almost_field_theory _ _ _ _ _ _ _ _ _ => f + | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f) + | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f) + end. + +Ltac field_elements set ext fspec pspec sspec dspec rk := + let afth := coerce_to_almost_field set ext fspec in + let rspec := ring_of_field fspec in + ring_elements set ext rspec pspec sspec dspec rk + ltac:(fun arth ext_r morph p_spec s_spec d_spec f => f afth ext_r morph p_spec s_spec d_spec). + +Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := + let get_lemma := + match pspec with None => fun x y => x | _ => fun x y => y end in + let simpl_eq_lemma := get_lemma + Field_simplify_eq_correct Field_simplify_eq_pow_correct in + let simpl_eq_in_lemma := get_lemma + Field_simplify_eq_in_correct Field_simplify_eq_pow_in_correct in + let rw_lemma := get_lemma + Field_rw_correct Field_rw_pow_correct in + field_elements set ext fspec pspec sspec dspec rk + ltac:(fun afth ext_r morph p_spec s_spec d_spec => + match morph with + | _ => + let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in + match p_spec with + | mkhypo ?pp_spec => + let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in + match s_spec with + | mkhypo ?ss_spec => + let field_ok3 := constr:(field_ok2 _ ss_spec) in + match d_spec with + | mkhypo ?dd_spec => + let field_ok := constr:(field_ok3 _ dd_spec) in + let mk_lemma lemma := + constr:(lemma _ _ _ _ _ _ _ _ _ _ + set ext_r inv_m afth + _ _ _ _ _ _ _ _ _ morph + _ _ _ pp_spec _ ss_spec _ dd_spec) in + let field_simpl_eq_ok := mk_lemma simpl_eq_lemma in + let field_simpl_ok := mk_lemma rw_lemma in + let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in + let cond1_ok := + constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in + let cond2_ok := + constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_spec) in + (fun f => + f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in + cond1_ok cond2_ok) + | _ => fail 4 "field: bad coefficiant division specification" + end + | _ => fail 3 "field: bad sign specification" + end + | _ => fail 2 "field: bad power specification" + end + | _ => fail 1 "field internal error : field_lemmas, please report" + end). diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v new file mode 100644 index 00000000..9617d409 --- /dev/null +++ b/plugins/setoid_ring/Field_theory.v @@ -0,0 +1,1946 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* R->R) (ropp : R->R). + Variable (rdiv : R -> R -> R) (rinv : R -> R). + Variable req : R -> R -> Prop. + + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "x / y" := (rdiv x y). + Notation "- x" := (ropp x). Notation "/ x" := (rinv x). + Notation "x == y" := (req x y) (at level 70, no associativity). + + (* Equality properties *) + Variable Rsth : Setoid_Theory R req. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Variable SRinv_ext : forall p q, p == q -> / p == / q. + + (* Field properties *) + Record almost_field_theory : Prop := mk_afield { + AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req; + AF_1_neq_0 : ~ 1 == 0; + AFdiv_def : forall p q, p / q == p * / q; + AFinv_l : forall p, ~ p == 0 -> / p * p == 1 + }. + +Section AlmostField. + + Variable AFth : almost_field_theory. + Let ARth := AFth.(AF_AR). + Let rI_neq_rO := AFth.(AF_1_neq_0). + Let rdiv_def := AFth.(AFdiv_def). + Let rinv_l := AFth.(AFinv_l). + + (* Coefficients *) + Variable C: Type. + Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). + Variable ceqb : C->C->bool. + Variable phi : C -> R. + + Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req + cO cI cadd cmul csub copp ceqb phi. + +Lemma ceqb_rect : forall c1 c2 (A:Type) (x y:A) (P:A->Type), + (phi c1 == phi c2 -> P x) -> P y -> P (if ceqb c1 c2 then x else y). +Proof. +intros. +generalize (fun h => X (morph_eq CRmorph c1 c2 h)). +case (ceqb c1 c2); auto. +Qed. + + + (* C notations *) + Notation "x +! y" := (cadd x y) (at level 50). + Notation "x *! y " := (cmul x y) (at level 40). + Notation "x -! y " := (csub x y) (at level 50). + Notation "-! x" := (copp x) (at level 35). + Notation " x ?=! y" := (ceqb x y) (at level 70, no associativity). + Notation "[ x ]" := (phi x) (at level 0). + + + (* Useful tactics *) + Add Setoid R req Rsth as R_set1. + Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. + Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. + Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed. + +Let eq_trans := Setoid.Seq_trans _ _ Rsth. +Let eq_sym := Setoid.Seq_sym _ _ Rsth. +Let eq_refl := Setoid.Seq_refl _ _ Rsth. + +Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) . +Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe) + (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext. +Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth) + (ARmul_1_l ARth) (ARmul_0_l ARth) + (ARmul_comm ARth) (ARmul_assoc ARth) (ARdistr_l ARth) + (ARopp_mul_l ARth) (ARopp_add ARth) + (ARsub_def ARth) . + + (* Power coefficients *) + Variable Cpow : Set. + Variable Cp_phi : N -> Cpow. + Variable rpow : R -> Cpow -> R. + Variable pow_th : power_theory rI rmul req Cp_phi rpow. + (* sign function *) + Variable get_sign : C -> option C. + Variable get_sign_spec : sign_theory copp ceqb get_sign. + + Variable cdiv:C -> C -> C*C. + Variable cdiv_th : div_theory req cadd cmul phi cdiv. + +Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow). +Notation Nnorm:= (norm_subst cO cI cadd cmul csub copp ceqb cdiv). + +Notation NPphi_dev := (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign). +Notation NPphi_pow := (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign). + +(* add abstract semi-ring to help with some proofs *) +Add Ring Rring : (ARth_SRth ARth). + + +(* additional ring properties *) + +Lemma rsub_0_l : forall r, 0 - r == - r. +intros; rewrite (ARsub_def ARth) in |- *;ring. +Qed. + +Lemma rsub_0_r : forall r, r - 0 == r. +intros; rewrite (ARsub_def ARth) in |- *. +rewrite (ARopp_zero Rsth Reqe ARth) in |- *; ring. +Qed. + +(*************************************************************************** + + Properties of division + + ***************************************************************************) + +Theorem rdiv_simpl: forall p q, ~ q == 0 -> q * (p / q) == p. +intros p q H. +rewrite rdiv_def in |- *. +transitivity (/ q * q * p); [ ring | idtac ]. +rewrite rinv_l in |- *; auto. +Qed. +Hint Resolve rdiv_simpl . + +Theorem SRdiv_ext: + forall p1 p2, p1 == p2 -> forall q1 q2, q1 == q2 -> p1 / q1 == p2 / q2. +intros p1 p2 H q1 q2 H0. +transitivity (p1 * / q1); auto. +transitivity (p2 * / q2); auto. +Qed. +Hint Resolve SRdiv_ext . + + Add Morphism rdiv : rdiv_ext. exact SRdiv_ext. Qed. + +Lemma rmul_reg_l : forall p q1 q2, + ~ p == 0 -> p * q1 == p * q2 -> q1 == q2. +intros. +rewrite <- (@rdiv_simpl q1 p) in |- *; trivial. +rewrite <- (@rdiv_simpl q2 p) in |- *; trivial. +repeat rewrite rdiv_def in |- *. +repeat rewrite (ARmul_assoc ARth) in |- *. +auto. +Qed. + +Theorem field_is_integral_domain : forall r1 r2, + ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0. +Proof. +red in |- *; intros. +apply H0. +transitivity (1 * r2); auto. +transitivity (/ r1 * r1 * r2); auto. +rewrite <- (ARmul_assoc ARth) in |- *. +rewrite H1 in |- *. +apply ARmul_0_r with (1 := Rsth) (2 := ARth). +Qed. + +Theorem ropp_neq_0 : forall r, + ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0. +intros. +setoid_replace (- r) with (- (1) * r). + apply field_is_integral_domain; trivial. + rewrite <- (ARopp_mul_l ARth) in |- *. + rewrite (ARmul_1_l ARth) in |- *. + reflexivity. +Qed. + +Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1. +intros. +rewrite (AFdiv_def AFth) in |- *. +rewrite (ARmul_comm ARth) in |- *. +apply (AFinv_l AFth). +trivial. +Qed. + +Theorem rdiv1: forall r, r == r / 1. +intros r; transitivity (1 * (r / 1)); auto. +Qed. + +Theorem rdiv2: + forall r1 r2 r3 r4, + ~ r2 == 0 -> + ~ r4 == 0 -> + r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4). +Proof. +intros r1 r2 r3 r4 H H0. +assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial). +apply rmul_reg_l with (r2 * r4); trivial. +rewrite rdiv_simpl in |- *; trivial. +rewrite (ARdistr_r Rsth Reqe ARth) in |- *. +apply (Radd_ext Reqe). + transitivity (r2 * (r1 / r2) * r4); [ ring | auto ]. + transitivity (r2 * (r4 * (r3 / r4))); auto. + transitivity (r2 * r3); auto. +Qed. + + +Theorem rdiv2b: + forall r1 r2 r3 r4 r5, + ~ (r2*r5) == 0 -> + ~ (r4*r5) == 0 -> + r1 / (r2*r5) + r3 / (r4*r5) == (r1 * r4 + r3 * r2) / (r2 * (r4 * r5)). +Proof. +intros r1 r2 r3 r4 r5 H H0. +assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring). +assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring). +assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring). +assert (HH4: ~ r2 * (r4 * r5) == 0) + by complete (repeat apply field_is_integral_domain; trivial). +apply rmul_reg_l with (r2 * (r4 * r5)); trivial. +rewrite rdiv_simpl in |- *; trivial. +rewrite (ARdistr_r Rsth Reqe ARth) in |- *. +apply (Radd_ext Reqe). + transitivity ((r2 * r5) * (r1 / (r2 * r5)) * r4); [ ring | auto ]. + transitivity ((r4 * r5) * (r3 / (r4 * r5)) * r2); [ ring | auto ]. +Qed. + +Theorem rdiv5: forall r1 r2, - (r1 / r2) == - r1 / r2. +intros r1 r2. +transitivity (- (r1 * / r2)); auto. +transitivity (- r1 * / r2); auto. +Qed. +Hint Resolve rdiv5 . + +Theorem rdiv3: + forall r1 r2 r3 r4, + ~ r2 == 0 -> + ~ r4 == 0 -> + r1 / r2 - r3 / r4 == (r1 * r4 - r3 * r2) / (r2 * r4). +intros r1 r2 r3 r4 H H0. +assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial). +transitivity (r1 / r2 + - (r3 / r4)); auto. +transitivity (r1 / r2 + - r3 / r4); auto. +transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)); auto. +apply rdiv2; auto. +apply SRdiv_ext; auto. +transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto. +Qed. + + +Theorem rdiv3b: + forall r1 r2 r3 r4 r5, + ~ (r2 * r5) == 0 -> + ~ (r4 * r5) == 0 -> + r1 / (r2*r5) - r3 / (r4*r5) == (r1 * r4 - r3 * r2) / (r2 * (r4 * r5)). +Proof. +intros r1 r2 r3 r4 r5 H H0. +transitivity (r1 / (r2 * r5) + - (r3 / (r4 * r5))); auto. +transitivity (r1 / (r2 * r5) + - r3 / (r4 * r5)); auto. +transitivity ((r1 * r4 + - r3 * r2) / (r2 * (r4 * r5))). +apply rdiv2b; auto; try ring. +apply (SRdiv_ext); auto. +transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto. +Qed. + +Theorem rdiv6: + forall r1 r2, + ~ r1 == 0 -> ~ r2 == 0 -> / (r1 / r2) == r2 / r1. +intros r1 r2 H H0. +assert (~ r1 / r2 == 0) as Hk. + intros H1; case H. + transitivity (r2 * (r1 / r2)); auto. + rewrite H1 in |- *; ring. + apply rmul_reg_l with (r1 / r2); auto. + transitivity (/ (r1 / r2) * (r1 / r2)); auto. + transitivity 1; auto. + repeat rewrite rdiv_def in |- *. + transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac | ring ]. + repeat rewrite rinv_l in |- *; auto. +Qed. +Hint Resolve rdiv6 . + + Theorem rdiv4: + forall r1 r2 r3 r4, + ~ r2 == 0 -> + ~ r4 == 0 -> + (r1 / r2) * (r3 / r4) == (r1 * r3) / (r2 * r4). +Proof. +intros r1 r2 r3 r4 H H0. +assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial). +apply rmul_reg_l with (r2 * r4); trivial. +rewrite rdiv_simpl in |- *; trivial. +transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [ ring | idtac ]. +repeat rewrite rdiv_simpl in |- *; trivial. +Qed. + + Theorem rdiv4b: + forall r1 r2 r3 r4 r5 r6, + ~ r2 * r5 == 0 -> + ~ r4 * r6 == 0 -> + ((r1 * r6) / (r2 * r5)) * ((r3 * r5) / (r4 * r6)) == (r1 * r3) / (r2 * r4). +Proof. +intros r1 r2 r3 r4 r5 r6 H H0. +rewrite rdiv4; auto. +transitivity ((r5 * r6) * (r1 * r3) / ((r5 * r6) * (r2 * r4))). +apply SRdiv_ext; ring. +assert (HH: ~ r5*r6 == 0). + apply field_is_integral_domain. + intros H1; case H; rewrite H1; ring. + intros H1; case H0; rewrite H1; ring. +rewrite <- rdiv4 ; auto. + rewrite rdiv_r_r; auto. + + apply field_is_integral_domain. + intros H1; case H; rewrite H1; ring. + intros H1; case H0; rewrite H1; ring. +Qed. + + +Theorem rdiv7: + forall r1 r2 r3 r4, + ~ r2 == 0 -> + ~ r3 == 0 -> + ~ r4 == 0 -> + (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3). +Proof. +intros. +rewrite (rdiv_def (r1 / r2)) in |- *. +rewrite rdiv6 in |- *; trivial. +apply rdiv4; trivial. +Qed. + +Theorem rdiv7b: + forall r1 r2 r3 r4 r5 r6, + ~ r2 * r6 == 0 -> + ~ r3 * r5 == 0 -> + ~ r4 * r6 == 0 -> + ((r1 * r5) / (r2 * r6)) / ((r3 * r5) / (r4 * r6)) == (r1 * r4) / (r2 * r3). +Proof. +intros. +rewrite rdiv7; auto. +transitivity ((r5 * r6) * (r1 * r4) / ((r5 * r6) * (r2 * r3))). +apply SRdiv_ext; ring. +assert (HH: ~ r5*r6 == 0). + apply field_is_integral_domain. + intros H2; case H0; rewrite H2; ring. + intros H2; case H1; rewrite H2; ring. +rewrite <- rdiv4 ; auto. +rewrite rdiv_r_r; auto. + apply field_is_integral_domain. + intros H2; case H; rewrite H2; ring. + intros H2; case H0; rewrite H2; ring. +Qed. + + +Theorem rdiv8: forall r1 r2, ~ r2 == 0 -> r1 == 0 -> r1 / r2 == 0. +intros r1 r2 H H0. +transitivity (r1 * / r2); auto. +transitivity (0 * / r2); auto. +Qed. + + +Theorem cross_product_eq : forall r1 r2 r3 r4, + ~ r2 == 0 -> ~ r4 == 0 -> r1 * r4 == r3 * r2 -> r1 / r2 == r3 / r4. +intros. +transitivity (r1 / r2 * (r4 / r4)). + rewrite rdiv_r_r in |- *; trivial. + symmetry in |- *. + apply (ARmul_1_r Rsth ARth). + rewrite rdiv4 in |- *; trivial. + rewrite H1 in |- *. + rewrite (ARmul_comm ARth r2 r4) in |- *. + rewrite <- rdiv4 in |- *; trivial. + rewrite rdiv_r_r in |- * by trivial. + apply (ARmul_1_r Rsth ARth). +Qed. + +(*************************************************************************** + + Some equality test + + ***************************************************************************) + +Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool := + match p1, p2 with + xH, xH => true + | xO p3, xO p4 => positive_eq p3 p4 + | xI p3, xI p4 => positive_eq p3 p4 + | _, _ => false + end. + +Theorem positive_eq_correct: + forall p1 p2, if positive_eq p1 p2 then p1 = p2 else p1 <> p2. +intros p1; elim p1; + (try (intros p2; case p2; simpl; auto; intros; discriminate)). +intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4. +generalize (rec p4); case (positive_eq p3 p4); auto. +intros H1; apply f_equal with ( f := xI ); auto. +intros H1 H2; case H1; injection H2; auto. +intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4. +generalize (rec p4); case (positive_eq p3 p4); auto. +intros H1; apply f_equal with ( f := xO ); auto. +intros H1 H2; case H1; injection H2; auto. +Qed. + +Definition N_eq n1 n2 := + match n1, n2 with + | N0, N0 => true + | Npos p1, Npos p2 => positive_eq p1 p2 + | _, _ => false + end. + +Lemma N_eq_correct : forall n1 n2, if N_eq n1 n2 then n1 = n2 else n1 <> n2. +Proof. + intros [ |p1] [ |p2];simpl;trivial;try(intro H;discriminate H;fail). + assert (H:=positive_eq_correct p1 p2);destruct (positive_eq p1 p2); + [rewrite H;trivial | intro H1;injection H1;subst;apply H;trivial]. +Qed. + +(* equality test *) +Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool := + match e1, e2 with + PEc c1, PEc c2 => ceqb c1 c2 + | PEX p1, PEX p2 => positive_eq p1 p2 + | PEadd e3 e5, PEadd e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false + | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false + | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false + | PEopp e3, PEopp e4 => PExpr_eq e3 e4 + | PEpow e3 n3, PEpow e4 n4 => if N_eq n3 n4 then PExpr_eq e3 e4 else false + | _, _ => false + end. + +Add Morphism (pow_pos rmul) with signature req ==> eq ==> req as pow_morph. +intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH]. +Qed. + +Add Morphism (pow_N rI rmul) with signature req ==> eq ==> req as pow_N_morph. +intros x y H [|p];simpl;auto. apply pow_morph;trivial. +Qed. +(* +Lemma rpow_morph : forall x y n, x == y ->rpow x (Cp_phi n) == rpow y (Cp_phi n). +Proof. + intros; repeat rewrite pow_th.(rpow_pow_N). + destruct n;simpl. apply eq_refl. + induction p;simpl;try rewrite IHp;try rewrite H; apply eq_refl. +Qed. +*) +Theorem PExpr_eq_semi_correct: + forall l e1 e2, PExpr_eq e1 e2 = true -> NPEeval l e1 == NPEeval l e2. +intros l e1; elim e1. +intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)). +intros c2; apply (morph_eq CRmorph). +intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)). +intros p2; generalize (positive_eq_correct p1 p2); case (positive_eq p1 p2); + (try (intros; discriminate)); intros H; rewrite H; auto. +intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). +intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); + (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); + (try (intros; discriminate)); auto. +intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). +intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); + (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); + (try (intros; discriminate)); auto. +intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). +intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); + (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); + (try (intros; discriminate)); auto. +intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))). +intros e4; generalize (rec e4); case (PExpr_eq e3 e4); + (try (intros; discriminate)); auto. +intros e3 rec n3 e2;(case e2;simpl;(try (intros;discriminate))). +intros e4 n4;generalize (N_eq_correct n3 n4);destruct (N_eq n3 n4); +intros;try discriminate. +repeat rewrite pow_th.(rpow_pow_N);rewrite H;rewrite (rec _ H0);auto. +Qed. + +(* add *) +Definition NPEadd e1 e2 := + match e1, e2 with + PEc c1, PEc c2 => PEc (cadd c1 c2) + | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2 + | _, PEc c => if ceqb c cO then e1 else PEadd e1 e2 + (* Peut t'on factoriser ici ??? *) + | _, _ => PEadd e1 e2 + end. + +Theorem NPEadd_correct: + forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2). +Proof. +intros l e1 e2. +destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect; + try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;try apply eq_refl; + try (ring [(morph0 CRmorph)]). + apply (morph_add CRmorph). +Qed. + +Definition NPEpow x n := + match n with + | N0 => PEc cI + | Npos p => + if positive_eq p xH then x else + match x with + | PEc c => + if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p) + | _ => PEpow x n + end + end. + +Theorem NPEpow_correct : forall l e n, + NPEeval l (NPEpow e n) == NPEeval l (PEpow e n). +Proof. + destruct n;simpl. + rewrite pow_th.(rpow_pow_N);simpl;auto. + generalize (positive_eq_correct p xH). + destruct (positive_eq p 1);intros. + rewrite H;rewrite pow_th.(rpow_pow_N). trivial. + clear H;destruct e;simpl;auto. + repeat apply ceqb_rect;simpl;intros;rewrite pow_th.(rpow_pow_N);simpl. + symmetry;induction p;simpl;trivial; ring [IHp H CRmorph.(morph1)]. + symmetry; induction p;simpl;trivial;ring [IHp CRmorph.(morph0)]. + induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp]. +Qed. + +(* mul *) +Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := + match x, y with + PEc c1, PEc c2 => PEc (cmul c1 c2) + | PEc c, _ => + if ceqb c cI then y else if ceqb c cO then PEc cO else PEmul x y + | _, PEc c => + if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y + | PEpow e1 n1, PEpow e2 n2 => + if N_eq n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y + | _, _ => PEmul x y + end. + +Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p. +induction p;simpl;auto;try ring [IHp]. +Qed. + +Theorem NPEmul_correct : forall l e1 e2, + NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2). +induction e1;destruct e2; simpl in |- *;try reflexivity; + repeat apply ceqb_rect; + try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; try reflexivity; + try ring [(morph0 CRmorph) (morph1 CRmorph)]. + apply (morph_mul CRmorph). +assert (H:=N_eq_correct n n0);destruct (N_eq n n0). +rewrite NPEpow_correct. simpl. +repeat rewrite pow_th.(rpow_pow_N). +rewrite IHe1;rewrite <- H;destruct n;simpl;try ring. +apply pow_pos_mul. +simpl;auto. +Qed. + +(* sub *) +Definition NPEsub e1 e2 := + match e1, e2 with + PEc c1, PEc c2 => PEc (csub c1 c2) + | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2 + | _, PEc c => if ceqb c cO then e1 else PEsub e1 e2 + (* Peut-on factoriser ici *) + | _, _ => PEsub e1 e2 + end. + +Theorem NPEsub_correct: + forall l e1 e2, NPEeval l (NPEsub e1 e2) == NPEeval l (PEsub e1 e2). +intros l e1 e2. +destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect; + try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; + try rewrite (morph0 CRmorph) in |- *; try reflexivity; + try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r). +apply (morph_sub CRmorph). +Qed. + +(* opp *) +Definition NPEopp e1 := + match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end. + +Theorem NPEopp_correct: + forall l e1, NPEeval l (NPEopp e1) == NPEeval l (PEopp e1). +intros l e1; case e1; simpl; auto. +intros; apply (morph_opp CRmorph). +Qed. + +(* simplification *) +Fixpoint PExpr_simp (e : PExpr C) : PExpr C := + match e with + PEadd e1 e2 => NPEadd (PExpr_simp e1) (PExpr_simp e2) + | PEmul e1 e2 => NPEmul (PExpr_simp e1) (PExpr_simp e2) + | PEsub e1 e2 => NPEsub (PExpr_simp e1) (PExpr_simp e2) + | PEopp e1 => NPEopp (PExpr_simp e1) + | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1 + | _ => e + end. + +Theorem PExpr_simp_correct: + forall l e, NPEeval l (PExpr_simp e) == NPEeval l e. +intros l e; elim e; simpl; auto. +intros e1 He1 e2 He2. +transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto. +apply NPEadd_correct. +simpl; auto. +intros e1 He1 e2 He2. +transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))); auto. +apply NPEsub_correct. +simpl; auto. +intros e1 He1 e2 He2. +transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto. +apply NPEmul_correct. +simpl; auto. +intros e1 He1. +transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto. +apply NPEopp_correct. +simpl; auto. +intros e1 He1 n;simpl. +rewrite NPEpow_correct;simpl. +repeat rewrite pow_th.(rpow_pow_N). +rewrite He1;auto. +Qed. + + +(**************************************************************************** + + Datastructure + + ***************************************************************************) + +(* The input: syntax of a field expression *) + +Inductive FExpr : Type := + FEc: C -> FExpr + | FEX: positive -> FExpr + | FEadd: FExpr -> FExpr -> FExpr + | FEsub: FExpr -> FExpr -> FExpr + | FEmul: FExpr -> FExpr -> FExpr + | FEopp: FExpr -> FExpr + | FEinv: FExpr -> FExpr + | FEdiv: FExpr -> FExpr -> FExpr + | FEpow: FExpr -> N -> FExpr . + +Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := + match pe with + | FEc c => phi c + | FEX x => BinList.nth 0 x l + | FEadd x y => FEeval l x + FEeval l y + | FEsub x y => FEeval l x - FEeval l y + | FEmul x y => FEeval l x * FEeval l y + | FEopp x => - FEeval l x + | FEinv x => / FEeval l x + | FEdiv x y => FEeval l x / FEeval l y + | FEpow x n => rpow (FEeval l x) (Cp_phi n) + end. + +Strategy expand [FEeval]. + +(* The result of the normalisation *) + +Record linear : Type := mk_linear { + num : PExpr C; + denum : PExpr C; + condition : list (PExpr C) }. + +(*************************************************************************** + + Semantics and properties of side condition + + ***************************************************************************) + +Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop := + match le with + | nil => True + | e1 :: nil => ~ req (NPEeval l e1) rO + | e1 :: l1 => ~ req (NPEeval l e1) rO /\ PCond l l1 + end. + +Theorem PCond_cons_inv_l : + forall l a l1, PCond l (a::l1) -> ~ NPEeval l a == 0. +intros l a l1 H. +destruct l1; simpl in H |- *; trivial. +destruct H; trivial. +Qed. + +Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) -> PCond l l1. +intros l a l1 H. +destruct l1; simpl in H |- *; trivial. +destruct H; trivial. +Qed. + +Theorem PCond_app_inv_l: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l1. +intros l l1 l2; elim l1; simpl app in |- *. + simpl in |- *; auto. + destruct l0; simpl in *. + destruct l2; firstorder. + firstorder. +Qed. + +Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l2. +intros l l1 l2; elim l1; simpl app; auto. +intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ). +Qed. + +(* An unsatisfiable condition: issued when a division by zero is detected *) +Definition absurd_PCond := cons (PEc cO) nil. + +Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond. +unfold absurd_PCond in |- *; simpl in |- *. +red in |- *; intros. +apply H. +apply (morph0 CRmorph). +Qed. + +(*************************************************************************** + + Normalisation + + ***************************************************************************) + +Fixpoint isIn (e1:PExpr C) (p1:positive) + (e2:PExpr C) (p2:positive) {struct e2}: option (N * PExpr C) := + match e2 with + | PEmul e3 e4 => + match isIn e1 p1 e3 p2 with + | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2))) + | Some (Npos p, e5) => + match isIn e1 p e4 p2 with + | Some (n, e6) => Some (n, NPEmul e5 e6) + | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2))) + end + | None => + match isIn e1 p1 e4 p2 with + | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5) + | None => None + end + end + | PEpow e3 N0 => None + | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2) + | _ => + if PExpr_eq e1 e2 then + match Zminus (Zpos p1) (Zpos p2) with + | Zpos p => Some (Npos p, PEc cI) + | Z0 => Some (N0, PEc cI) + | Zneg p => Some (N0, NPEpow e2 (Npos p)) + end + else None + end. + + Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end. + Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end. + + Notation pow_pos_plus := (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) + ARth.(ARmul_comm) ARth.(ARmul_assoc)). + + Lemma isIn_correct_aux : forall l e1 e2 p1 p2, + match + (if PExpr_eq e1 e2 then + match Zminus (Zpos p1) (Zpos p2) with + | Zpos p => Some (Npos p, PEc cI) + | Z0 => Some (N0, PEc cI) + | Zneg p => Some (N0, NPEpow e2 (Npos p)) + end + else None) + with + | Some(n, e3) => + NPEeval l (PEpow e2 (Npos p2)) == + NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ + (Zpos p1 > NtoZ n)%Z + | _ => True + end. +Proof. + intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2); + case (PExpr_eq e1 e2); simpl; auto; intros H. + case_eq ((p1 ?= p2)%positive Eq);intros;simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:refine (refl_equal _). + rewrite (Pcompare_Eq_eq _ _ H0). + rewrite H by trivial. ring [ (morph1 CRmorph)]. + fold (NPEpow e2 (Npos (p2 - p1))). + rewrite NPEpow_correct;simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. + rewrite H;trivial. split. 2:refine (refl_equal _). + rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. + repeat rewrite pow_th.(rpow_pow_N);simpl. + rewrite H;trivial. + change (ZtoN + match (p1 ?= p1 - p2)%positive Eq with + | Eq => 0 + | Lt => Zneg (p1 - p2 - p1) + | Gt => Zpos (p1 - (p1 - p2)) + end) with (ZtoN (Zpos p1 - Zpos (p1 -p2))). + replace (Zpos (p1 - p2)) with (Zpos p1 - Zpos p2)%Z. + split. + repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth). + rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl. + ring [ (morph1 CRmorph)]. + assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). + apply Zplus_gt_reg_l with (Zpos p2). + rewrite Zplus_minus. change (Zpos p2 + Zpos p1 > 0 + Zpos p1)%Z. + apply Zplus_gt_compat_r. refine (refl_equal _). + simpl;rewrite H0;trivial. +Qed. + +Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2). +induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_plus;simpl. +ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto. +Qed. + + +Theorem isIn_correct: forall l e1 p1 e2 p2, + match isIn e1 p1 e2 p2 with + | Some(n, e3) => + NPEeval l (PEpow e2 (Npos p2)) == + NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ + (Zpos p1 > NtoZ n)%Z + | _ => True + end. +Proof. +Opaque NPEpow. +intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros; + try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn. +generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3. +destruct n. + simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. + rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial]. + generalize (H0 p4 p2);clear H0;destruct (isIn e1 p4 p0 p2). destruct p5. + destruct n;simpl. + rewrite NPEmul_correct;repeat rewrite pow_th.(rpow_pow_N);simpl. + intros (H1,H2) (H3,H4). + unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. + rewrite pow_pos_mul. rewrite H1;rewrite H3. + assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * + (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == + pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) * + NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H. + rewrite <- pow_pos_plus. rewrite Pplus_minus. + split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial. + repeat rewrite pow_th.(rpow_pow_N);simpl. + intros (H1,H2) (H3,H4). + unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. + rewrite H2 in H1;simpl in H1. + assert (Zpos p1 > Zpos p6)%Z. + apply Zgt_trans with (Zpos p4). exact H4. exact H2. + unfold Zgt in H;simpl in H;rewrite H. + split. 2:exact H. + rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3. + assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * + (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) == + pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) * + NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0. + rewrite <- pow_pos_plus. + replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. + rewrite NPEmul_correct. simpl;ring. + assert + (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z. + change ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z). + rewrite <- Zplus_assoc. rewrite (Zplus_assoc (- Zpos p4)). + simpl. rewrite Pcompare_refl. simpl. reflexivity. + unfold Zminus, Zopp in H0. simpl in H0. + rewrite H2 in H0;rewrite H4 in H0;rewrite H in H0. inversion H0;trivial. + simpl. repeat rewrite pow_th.(rpow_pow_N). + intros H1 (H2,H3). unfold Zgt in H3;simpl in H3. rewrite H3 in H2;rewrite H3. + rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. + simpl in H2. rewrite pow_th.(rpow_pow_N);simpl. + rewrite pow_pos_mul. split. ring [H2]. exact H3. + generalize (H0 p1 p2);clear H0;destruct (isIn e1 p1 p0 p2). destruct p3. + destruct n;simpl. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. + intros (H1,H2);split;trivial. rewrite pow_pos_mul;ring [H1]. + rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul. + intros (H1, H2);rewrite H1;split. + unfold Zgt in H2;simpl in H2;rewrite H2;rewrite H2 in H1. + simpl in H1;ring [H1]. trivial. + trivial. + destruct n. trivial. + generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3. + destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl. + intros (H1,H2);split. rewrite pow_pos_pow_pos. trivial. trivial. + repeat rewrite pow_th.(rpow_pow_N). simpl. + intros (H1,H2);split;trivial. + rewrite pow_pos_pow_pos;trivial. + trivial. +Qed. + +Record rsplit : Type := mk_rsplit { + rsplit_left : PExpr C; + rsplit_common : PExpr C; + rsplit_right : PExpr C}. + +(* Stupid name clash *) +Notation left := rsplit_left. +Notation right := rsplit_right. +Notation common := rsplit_common. + +Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit := + match e1 with + | PEmul e3 e4 => + let r1 := split_aux e3 p e2 in + let r2 := split_aux e4 p (right r1) in + mk_rsplit (NPEmul (left r1) (left r2)) + (NPEmul (common r1) (common r2)) + (right r2) + | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2 + | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2 + | _ => + match isIn e1 p e2 xH with + | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 + | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 + | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 + end + end. + +Lemma split_aux_correct_1 : forall l e1 p e2, + let res := match isIn e1 p e2 xH with + | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 + | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 + | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 + end in + NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res)) + /\ + NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)). +Proof. + intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH). + destruct (isIn e1 p e2 1). destruct p0. + Opaque NPEpow NPEmul. + destruct n;simpl; + (repeat rewrite NPEmul_correct;simpl; + repeat rewrite NPEpow_correct;simpl; + repeat rewrite pow_th.(rpow_pow_N);simpl). + intros (H, Hgt);split;try ring [H CRmorph.(morph1)]. + intros (H, Hgt). unfold Zgt in Hgt;simpl in Hgt;rewrite Hgt in H. + simpl in H;split;try ring [H]. + rewrite <- pow_pos_plus. rewrite Pplus_minus. reflexivity. trivial. + simpl;intros. repeat rewrite NPEmul_correct;simpl. + rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)]. +Qed. + +Theorem split_aux_correct: forall l e1 p e2, + NPEeval l (PEpow e1 (Npos p)) == + NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2))) +/\ + NPEeval l e2 == NPEeval l (NPEmul (right (split_aux e1 p e2)) + (common (split_aux e1 p e2))). +Proof. +intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl. +generalize (IHe1_1 k e2); clear IHe1_1. +generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. +simpl. repeat (rewrite NPEmul_correct;simpl). +repeat rewrite pow_th.(rpow_pow_N);simpl. +intros (H1,H2) (H3,H4);split. +rewrite pow_pos_mul. rewrite H1;rewrite H3. ring. +rewrite H4;rewrite H2;ring. +destruct n;simpl. +split. repeat rewrite pow_th.(rpow_pow_N);simpl. +rewrite NPEmul_correct. simpl. + induction k;simpl;try ring [CRmorph.(morph1)]; ring [IHk CRmorph.(morph1)]. + rewrite NPEmul_correct;simpl. ring [CRmorph.(morph1)]. +generalize (IHe1 (p*k)%positive e2);clear IHe1;simpl. +repeat rewrite NPEmul_correct;simpl. +repeat rewrite pow_th.(rpow_pow_N);simpl. +rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2]. +Qed. + +Definition split e1 e2 := split_aux e1 xH e2. + +Theorem split_correct_l: forall l e1 e2, + NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2)) + (common (split e1 e2))). +Proof. +intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl. +rewrite pow_th.(rpow_pow_N);simpl;auto. +Qed. + +Theorem split_correct_r: forall l e1 e2, + NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2)) + (common (split e1 e2))). +Proof. +intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto. +Qed. + +Fixpoint Fnorm (e : FExpr) : linear := + match e with + | FEc c => mk_linear (PEc c) (PEc cI) nil + | FEX x => mk_linear (PEX C x) (PEc cI) nil + | FEadd e1 e2 => + let x := Fnorm e1 in + let y := Fnorm e2 in + let s := split (denum x) (denum y) in + mk_linear + (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s))) + (NPEmul (left s) (NPEmul (right s) (common s))) + (condition x ++ condition y) + + | FEsub e1 e2 => + let x := Fnorm e1 in + let y := Fnorm e2 in + let s := split (denum x) (denum y) in + mk_linear + (NPEsub (NPEmul (num x) (right s)) (NPEmul (num y) (left s))) + (NPEmul (left s) (NPEmul (right s) (common s))) + (condition x ++ condition y) + | FEmul e1 e2 => + let x := Fnorm e1 in + let y := Fnorm e2 in + let s1 := split (num x) (denum y) in + let s2 := split (num y) (denum x) in + mk_linear (NPEmul (left s1) (left s2)) + (NPEmul (right s2) (right s1)) + (condition x ++ condition y) + | FEopp e1 => + let x := Fnorm e1 in + mk_linear (NPEopp (num x)) (denum x) (condition x) + | FEinv e1 => + let x := Fnorm e1 in + mk_linear (denum x) (num x) (num x :: condition x) + | FEdiv e1 e2 => + let x := Fnorm e1 in + let y := Fnorm e2 in + let s1 := split (num x) (num y) in + let s2 := split (denum x) (denum y) in + mk_linear (NPEmul (left s1) (right s2)) + (NPEmul (left s2) (right s1)) + (num y :: condition x ++ condition y) + | FEpow e1 n => + let x := Fnorm e1 in + mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x) + end. + + +(* Example *) +(* +Eval compute + in (Fnorm + (FEdiv + (FEc cI) + (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))). +*) + + Lemma pow_pos_not_0 : forall x, ~x==0 -> forall p, ~pow_pos rmul x p == 0. +Proof. + induction p;simpl. + intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H). + apply IHp. + rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). + reflexivity. + rewrite H1. ring. rewrite Hp;ring. + intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). + reflexivity. rewrite Hp;ring. trivial. +Qed. + +Theorem Pcond_Fnorm: + forall l e, + PCond l (condition (Fnorm e)) -> ~ NPEeval l (denum (Fnorm e)) == 0. +intros l e; elim e. + simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO. + simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO. + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl condition in Hcond. + simpl denum in |- *. + rewrite NPEmul_correct in |- *. + simpl in |- *. + apply field_is_integral_domain. + intros HH; case Hrec1; auto. + apply PCond_app_inv_l with (1 := Hcond). + rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; case Hrec2; auto. + apply PCond_app_inv_r with (1 := Hcond). + rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl condition in Hcond. + simpl denum in |- *. + rewrite NPEmul_correct in |- *. + simpl in |- *. + apply field_is_integral_domain. + intros HH; case Hrec1; auto. + apply PCond_app_inv_l with (1 := Hcond). + rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; case Hrec2; auto. + apply PCond_app_inv_r with (1 := Hcond). + rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl condition in Hcond. + simpl denum in |- *. + rewrite NPEmul_correct in |- *. + simpl in |- *. + apply field_is_integral_domain. + intros HH; apply Hrec1. + apply PCond_app_inv_l with (1 := Hcond). + rewrite (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; apply Hrec2. + apply PCond_app_inv_r with (1 := Hcond). + rewrite (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros e1 Hrec1 Hcond. + simpl condition in Hcond. + simpl denum in |- *. + auto. + intros e1 Hrec1 Hcond. + simpl condition in Hcond. + simpl denum in |- *. + apply PCond_cons_inv_l with (1:=Hcond). + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl condition in Hcond. + simpl denum in |- *. + rewrite NPEmul_correct in |- *. + simpl in |- *. + apply field_is_integral_domain. + intros HH; apply Hrec1. + specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1. + apply PCond_app_inv_l with (1 := Hcond1). + rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; apply PCond_cons_inv_l with (1:=Hcond). + rewrite (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + simpl;intros e1 Hrec1 n Hcond. + rewrite NPEpow_correct. + simpl;rewrite pow_th.(rpow_pow_N). + destruct n;simpl;intros. + apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto. +Qed. +Hint Resolve Pcond_Fnorm. + + +(*************************************************************************** + + Main theorem + + ***************************************************************************) + +Theorem Fnorm_FEeval_PEeval: + forall l fe, + PCond l (condition (Fnorm fe)) -> + FEeval l fe == NPEeval l (num (Fnorm fe)) / NPEeval l (denum (Fnorm fe)). +Proof. +intros l fe; elim fe; simpl. +intros c H; rewrite CRmorph.(morph1); apply rdiv1. +intros p H; rewrite CRmorph.(morph1); apply rdiv1. +intros e1 He1 e2 He2 HH. +assert (HH1: PCond l (condition (Fnorm e1))). +apply PCond_app_inv_l with ( 1 := HH ). +assert (HH2: PCond l (condition (Fnorm e2))). +apply PCond_app_inv_r with ( 1 := HH ). +rewrite (He1 HH1); rewrite (He2 HH2). +rewrite NPEadd_correct; simpl. +repeat rewrite NPEmul_correct; simpl. +generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) + (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). +repeat rewrite NPEmul_correct; simpl. +intros U1 U2; rewrite U1; rewrite U2. +apply rdiv2b; auto. + rewrite <- U1; auto. + rewrite <- U2; auto. + +intros e1 He1 e2 He2 HH. +assert (HH1: PCond l (condition (Fnorm e1))). +apply PCond_app_inv_l with ( 1 := HH ). +assert (HH2: PCond l (condition (Fnorm e2))). +apply PCond_app_inv_r with ( 1 := HH ). +rewrite (He1 HH1); rewrite (He2 HH2). +rewrite NPEsub_correct; simpl. +repeat rewrite NPEmul_correct; simpl. +generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) + (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). +repeat rewrite NPEmul_correct; simpl. +intros U1 U2; rewrite U1; rewrite U2. +apply rdiv3b; auto. + rewrite <- U1; auto. + rewrite <- U2; auto. + +intros e1 He1 e2 He2 HH. +assert (HH1: PCond l (condition (Fnorm e1))). +apply PCond_app_inv_l with ( 1 := HH ). +assert (HH2: PCond l (condition (Fnorm e2))). +apply PCond_app_inv_r with ( 1 := HH ). +rewrite (He1 HH1); rewrite (He2 HH2). +repeat rewrite NPEmul_correct; simpl. +generalize (split_correct_l l (num (Fnorm e1)) (denum (Fnorm e2))) + (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))) + (split_correct_l l (num (Fnorm e2)) (denum (Fnorm e1))) + (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))). +repeat rewrite NPEmul_correct; simpl. +intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3; + rewrite U4; simpl. +apply rdiv4b; auto. + rewrite <- U4; auto. + rewrite <- U2; auto. + +intros e1 He1 HH. +rewrite NPEopp_correct; simpl; rewrite (He1 HH); apply rdiv5; auto. + +intros e1 He1 HH. +assert (HH1: PCond l (condition (Fnorm e1))). +apply PCond_cons_inv_r with ( 1 := HH ). +rewrite (He1 HH1); apply rdiv6; auto. +apply PCond_cons_inv_l with ( 1 := HH ). + +intros e1 He1 e2 He2 HH. +assert (HH1: PCond l (condition (Fnorm e1))). +apply PCond_app_inv_l with (condition (Fnorm e2)). +apply PCond_cons_inv_r with ( 1 := HH ). +assert (HH2: PCond l (condition (Fnorm e2))). +apply PCond_app_inv_r with (condition (Fnorm e1)). +apply PCond_cons_inv_r with ( 1 := HH ). +rewrite (He1 HH1); rewrite (He2 HH2). +repeat rewrite NPEmul_correct;simpl. +generalize (split_correct_l l (num (Fnorm e1)) (num (Fnorm e2))) + (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))) + (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) + (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). +repeat rewrite NPEmul_correct; simpl. +intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3; + rewrite U4; simpl. +apply rdiv7b; auto. + rewrite <- U3; auto. + rewrite <- U2; auto. +apply PCond_cons_inv_l with ( 1 := HH ). + rewrite <- U4; auto. + +intros e1 He1 n Hcond;assert (He1' := He1 Hcond);clear He1. +repeat rewrite NPEpow_correct;simpl;repeat rewrite pow_th.(rpow_pow_N). +rewrite He1';clear He1'. +destruct n;simpl. apply rdiv1. +generalize (NPEeval l (num (Fnorm e1))) (NPEeval l (denum (Fnorm e1))) + (Pcond_Fnorm _ _ Hcond). +intros r r0 Hdiff;induction p;simpl. +repeat (rewrite <- rdiv4;trivial). +rewrite IHp. reflexivity. +apply pow_pos_not_0;trivial. +apply pow_pos_not_0;trivial. +intro Hp. apply (pow_pos_not_0 Hdiff p). +rewrite (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p) 0). + reflexivity. apply pow_pos_not_0;trivial. ring [Hp]. +rewrite <- rdiv4;trivial. +rewrite IHp;reflexivity. +apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial. +reflexivity. +Qed. + +Theorem Fnorm_crossproduct: + forall l fe1 fe2, + let nfe1 := Fnorm fe1 in + let nfe2 := Fnorm fe2 in + NPEeval l (PEmul (num nfe1) (denum nfe2)) == + NPEeval l (PEmul (num nfe2) (denum nfe1)) -> + PCond l (condition nfe1 ++ condition nfe2) -> + FEeval l fe1 == FEeval l fe2. +intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2. +rewrite Fnorm_FEeval_PEeval in |- * by + apply PCond_app_inv_l with (1 := Hcond). + rewrite Fnorm_FEeval_PEeval in |- * by + apply PCond_app_inv_r with (1 := Hcond). + apply cross_product_eq; trivial. + apply Pcond_Fnorm. + apply PCond_app_inv_l with (1 := Hcond). + apply Pcond_Fnorm. + apply PCond_app_inv_r with (1 := Hcond). +Qed. + +(* Correctness lemmas of reflexive tactics *) +Notation Ninterp_PElist := (interp_PElist rO radd rmul rsub ropp req phi Cp_phi rpow). +Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv). + +Theorem Fnorm_correct: + forall n l lpe fe, + Ninterp_PElist l lpe -> + Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true -> + PCond l (condition (Fnorm fe)) -> FEeval l fe == 0. +intros n l lpe fe Hlpe H H1; + apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe H1). +apply rdiv8; auto. +transitivity (NPEeval l (PEc cO)); auto. +rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe);auto. +change (NPEeval l (PEc cO)) with (Pphi 0 radd rmul phi l (Pc cO)). +apply (Peq_ok Rsth Reqe CRmorph);auto. +simpl. apply (morph0 CRmorph); auto. +Qed. + +(* simplify a field expression into a fraction *) +(* TODO: simplify when den is constant... *) +Definition display_linear l num den := + NPphi_dev l num / NPphi_dev l den. + +Definition display_pow_linear l num den := + NPphi_pow l num / NPphi_pow l den. + +Theorem Field_rw_correct : + forall n lpe l, + Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> + forall fe nfe, Fnorm fe = nfe -> + PCond l (condition nfe) -> + FEeval l fe == display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). +Proof. + intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. + apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H). + unfold display_linear; apply SRdiv_ext; + eapply (ring_rw_correct Rsth Reqe ARth CRmorph);eauto. +Qed. + +Theorem Field_rw_pow_correct : + forall n lpe l, + Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> + forall fe nfe, Fnorm fe = nfe -> + PCond l (condition nfe) -> + FEeval l fe == display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). +Proof. + intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. + apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H). + unfold display_pow_linear; apply SRdiv_ext; + eapply (ring_rw_pow_correct Rsth Reqe ARth CRmorph);eauto. +Qed. + +Theorem Field_correct : + forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> + forall nfe1, Fnorm fe1 = nfe1 -> + forall nfe2, Fnorm fe2 = nfe2 -> + Peq ceqb (Nnorm n lmp (PEmul (num nfe1) (denum nfe2))) + (Nnorm n lmp (PEmul (num nfe2) (denum nfe1))) = true -> + PCond l (condition nfe1 ++ condition nfe2) -> + FEeval l fe1 == FEeval l fe2. +Proof. +intros n l lpe fe1 fe2 Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp. +apply Fnorm_crossproduct; trivial. +eapply (ring_correct Rsth Reqe ARth CRmorph); eauto. +Qed. + +(* simplify a field equation : generate the crossproduct and simplify + polynomials *) +Theorem Field_simplify_eq_old_correct : + forall l fe1 fe2 nfe1 nfe2, + Fnorm fe1 = nfe1 -> + Fnorm fe2 = nfe2 -> + NPphi_dev l (Nnorm O nil (PEmul (num nfe1) (denum nfe2))) == + NPphi_dev l (Nnorm O nil (PEmul (num nfe2) (denum nfe1))) -> + PCond l (condition nfe1 ++ condition nfe2) -> + FEeval l fe1 == FEeval l fe2. +Proof. +intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond; subst nfe1 nfe2. +apply Fnorm_crossproduct; trivial. +match goal with + [ |- NPEeval l ?x == NPEeval l ?y] => + rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec + O nil l I (refl_equal nil) x (refl_equal (Nnorm O nil x))); + rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec + O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y))) + end. +trivial. +Qed. + +Theorem Field_simplify_eq_correct : + forall n l lpe fe1 fe2, + Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> + forall nfe1, Fnorm fe1 = nfe1 -> + forall nfe2, Fnorm fe2 = nfe2 -> + forall den, split (denum nfe1) (denum nfe2) = den -> + NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) == + NPphi_dev l (Nnorm n lmp (PEmul (num nfe2) (left den))) -> + PCond l (condition nfe1 ++ condition nfe2) -> + FEeval l fe1 == FEeval l fe2. +Proof. +intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond; + subst nfe1 nfe2 den lmp. +apply Fnorm_crossproduct; trivial. +simpl in |- *. +rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. +rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. +rewrite NPEmul_correct in |- *. +rewrite NPEmul_correct in |- *. +simpl in |- *. +repeat rewrite (ARmul_assoc ARth) in |- *. +rewrite <-( + let x := PEmul (num (Fnorm fe1)) + (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in +ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l + Hlpe (refl_equal (Nmk_monpol_list lpe)) + x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. +rewrite <-( + let x := (PEmul (num (Fnorm fe2)) + (rsplit_left + (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in + ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l + Hlpe (refl_equal (Nmk_monpol_list lpe)) + x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. +simpl in Hcrossprod. +rewrite Hcrossprod in |- *. +reflexivity. +Qed. + +Theorem Field_simplify_eq_pow_correct : + forall n l lpe fe1 fe2, + Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> + forall nfe1, Fnorm fe1 = nfe1 -> + forall nfe2, Fnorm fe2 = nfe2 -> + forall den, split (denum nfe1) (denum nfe2) = den -> + NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) == + NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) -> + PCond l (condition nfe1 ++ condition nfe2) -> + FEeval l fe1 == FEeval l fe2. +Proof. +intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond; + subst nfe1 nfe2 den lmp. +apply Fnorm_crossproduct; trivial. +simpl in |- *. +rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. +rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. +rewrite NPEmul_correct in |- *. +rewrite NPEmul_correct in |- *. +simpl in |- *. +repeat rewrite (ARmul_assoc ARth) in |- *. +rewrite <-( + let x := PEmul (num (Fnorm fe1)) + (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in +ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l + Hlpe (refl_equal (Nmk_monpol_list lpe)) + x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. +rewrite <-( + let x := (PEmul (num (Fnorm fe2)) + (rsplit_left + (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in + ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l + Hlpe (refl_equal (Nmk_monpol_list lpe)) + x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. +simpl in Hcrossprod. +rewrite Hcrossprod in |- *. +reflexivity. +Qed. + +Theorem Field_simplify_eq_pow_in_correct : + forall n l lpe fe1 fe2, + Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> + forall nfe1, Fnorm fe1 = nfe1 -> + forall nfe2, Fnorm fe2 = nfe2 -> + forall den, split (denum nfe1) (denum nfe2) = den -> + forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 -> + forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 -> + FEeval l fe1 == FEeval l fe2 -> + PCond l (condition nfe1 ++ condition nfe2) -> + NPphi_pow l np1 == + NPphi_pow l np2. +Proof. + intros. subst nfe1 nfe2 lmp np1 np2. + repeat rewrite (Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec). + repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. + assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). + assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). + apply (@rmul_reg_l (NPEeval l (rsplit_common den))). + intro Heq;apply N1. + rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). + rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. + repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))). + repeat rewrite <- ARth.(ARmul_assoc). + change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with + (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))). + change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with + (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))). + repeat rewrite <- NPEmul_correct. rewrite <- H3. rewrite <- split_correct_l. + rewrite <- split_correct_r. + apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))). + intro Heq; apply AFth.(AF_1_neq_0). + rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial. + ring [Heq]. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). + repeat rewrite <- (ARth.(ARmul_assoc)). + rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. + apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))). + intro Heq; apply AFth.(AF_1_neq_0). + rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial. + ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe1)))). + repeat rewrite <- (ARth.(ARmul_assoc)). + repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. + rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp. + rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). + repeat rewrite <- (AFth.(AFdiv_def)). + repeat rewrite <- Fnorm_FEeval_PEeval ; trivial. + apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). +Qed. + +Theorem Field_simplify_eq_in_correct : +forall n l lpe fe1 fe2, + Ninterp_PElist l lpe -> + forall lmp, Nmk_monpol_list lpe = lmp -> + forall nfe1, Fnorm fe1 = nfe1 -> + forall nfe2, Fnorm fe2 = nfe2 -> + forall den, split (denum nfe1) (denum nfe2) = den -> + forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 -> + forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 -> + FEeval l fe1 == FEeval l fe2 -> + PCond l (condition nfe1 ++ condition nfe2) -> + NPphi_dev l np1 == + NPphi_dev l np2. +Proof. + intros. subst nfe1 nfe2 lmp np1 np2. + repeat rewrite (Pphi_dev_ok Rsth Reqe ARth CRmorph get_sign_spec). + repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. + assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). + assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). + apply (@rmul_reg_l (NPEeval l (rsplit_common den))). + intro Heq;apply N1. + rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). + rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. + repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))). + repeat rewrite <- ARth.(ARmul_assoc). + change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with + (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))). + change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with + (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))). + repeat rewrite <- NPEmul_correct;rewrite <- H3. rewrite <- split_correct_l. + rewrite <- split_correct_r. + apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))). + intro Heq; apply AFth.(AF_1_neq_0). + rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial. + ring [Heq]. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). + repeat rewrite <- (ARth.(ARmul_assoc)). + rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. + apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))). + intro Heq; apply AFth.(AF_1_neq_0). + rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial. + ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe1)))). + repeat rewrite <- (ARth.(ARmul_assoc)). + repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. + rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp. + rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). + repeat rewrite <- (AFth.(AFdiv_def)). + repeat rewrite <- Fnorm_FEeval_PEeval;trivial. + apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). +Qed. + + +Section Fcons_impl. + +Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C). + +Hypothesis PCond_fcons_inv : forall l a l1, + PCond l (Fcons a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. + +Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) := + match l with + | nil => m + | cons a l1 => Fcons a (Fapp l1 m) + end. + +Lemma fcons_correct : forall l l1, + PCond l (Fapp l1 nil) -> PCond l l1. +induction l1; simpl in |- *; intros. + trivial. + elim PCond_fcons_inv with (1 := H); intros. + destruct l1; auto. +Qed. + +End Fcons_impl. + +Section Fcons_simpl. + +(* Some general simpifications of the condition: eliminate duplicates, + split multiplications *) + +Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := + match l with + nil => cons e nil + | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1) + end. + +Theorem PFcons_fcons_inv: + forall l a l1, PCond l (Fcons a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. +intros l a l1; elim l1; simpl Fcons; auto. +simpl; auto. +intros a0 l0. +generalize (PExpr_eq_semi_correct l a a0); case (PExpr_eq a a0). +intros H H0 H1; split; auto. +rewrite H; auto. +generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. +intros H H0 H1; + assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)). +split. +generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. +apply H0. +generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto. +generalize Hp; case l0; simpl; intuition. +Qed. + +(* equality of normal forms rather than syntactic equality *) +Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := + match l with + nil => cons e nil + | cons a l1 => + if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l + else cons a (Fcons0 e l1) + end. + +Theorem PFcons0_fcons_inv: + forall l a l1, PCond l (Fcons0 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. +intros l a l1; elim l1; simpl Fcons0; auto. +simpl; auto. +intros a0 l0. +generalize (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th O l nil a a0). simpl. + case (Peq ceqb (Nnorm O nil a) (Nnorm O nil a0)). +intros H H0 H1; split; auto. +rewrite H; auto. +generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. +intros H H0 H1; + assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)). +split. +generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. +apply H0. +generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto. +clear get_sign get_sign_spec. +generalize Hp; case l0; simpl; intuition. +Qed. + +(* split factorized denominators *) +Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := + match e with + PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l) + | PEpow e1 _ => Fcons00 e1 l + | _ => Fcons0 e l + end. + +Theorem PFcons00_fcons_inv: + forall l a l1, PCond l (Fcons00 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. +intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). + intros p H p0 H0 l1 H1. + simpl in H1. + case (H _ H1); intros H2 H3. + case (H0 _ H3); intros H4 H5; split; auto. + simpl in |- *. + apply field_is_integral_domain; trivial. + simpl;intros. rewrite pow_th.(rpow_pow_N). + destruct (H _ H0);split;auto. + destruct n;simpl. apply AFth.(AF_1_neq_0). + apply pow_pos_not_0;trivial. +Qed. + +Definition Pcond_simpl_gen := + fcons_correct _ PFcons00_fcons_inv. + + +(* Specific case when the equality test of coefs is complete w.r.t. the + field equality: non-zero coefs can be eliminated, and opposite can + be simplified (if -1 <> 0) *) + +Hypothesis ceqb_complete : forall c1 c2, phi c1 == phi c2 -> ceqb c1 c2 = true. + +Lemma ceqb_rect_complete : forall c1 c2 (A:Type) (x y:A) (P:A->Type), + (phi c1 == phi c2 -> P x) -> + (~ phi c1 == phi c2 -> P y) -> + P (if ceqb c1 c2 then x else y). +Proof. +intros. +generalize (fun h => X (morph_eq CRmorph c1 c2 h)). +generalize (@ceqb_complete c1 c2). +case (c1 ?=! c2); auto; intros. +apply X0. +red in |- *; intro. +absurd (false = true); auto; discriminate. +Qed. + +Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := + match e with + PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l) + | PEpow e _ => Fcons1 e l + | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l + | PEc c => if ceqb c cO then absurd_PCond else l + | _ => Fcons0 e l + end. + +Theorem PFcons1_fcons_inv: + forall l a l1, PCond l (Fcons1 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. +intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). + simpl in |- *; intros c l1. + apply ceqb_rect_complete; intros. + elim (@absurd_PCond_bottom l H0). + split; trivial. + rewrite <- (morph0 CRmorph) in |- *; trivial. + intros p H p0 H0 l1 H1. + simpl in H1. + case (H _ H1); intros H2 H3. + case (H0 _ H3); intros H4 H5; split; auto. + simpl in |- *. + apply field_is_integral_domain; trivial. + simpl in |- *; intros p H l1. + apply ceqb_rect_complete; intros. + elim (@absurd_PCond_bottom l H1). + destruct (H _ H1). + split; trivial. + apply ropp_neq_0; trivial. + rewrite (morph_opp CRmorph) in H0. + rewrite (morph1 CRmorph) in H0. + rewrite (morph0 CRmorph) in H0. + trivial. + intros;simpl. destruct (H _ H0);split;trivial. + rewrite pow_th.(rpow_pow_N). destruct n;simpl. + apply AFth.(AF_1_neq_0). apply pow_pos_not_0;trivial. +Qed. + +Definition Fcons2 e l := Fcons1 (PExpr_simp e) l. + +Theorem PFcons2_fcons_inv: + forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. +unfold Fcons2 in |- *; intros l a l1 H; split; + case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto. +intros H1 H2 H3; case H1. +transitivity (NPEeval l a); trivial. +apply PExpr_simp_correct. +Qed. + +Definition Pcond_simpl_complete := + fcons_correct _ PFcons2_fcons_inv. + +End Fcons_simpl. + +End AlmostField. + +Section FieldAndSemiField. + + Record field_theory : Prop := mk_field { + F_R : ring_theory rO rI radd rmul rsub ropp req; + F_1_neq_0 : ~ 1 == 0; + Fdiv_def : forall p q, p / q == p * / q; + Finv_l : forall p, ~ p == 0 -> / p * p == 1 + }. + + Definition F2AF f := + mk_afield + (Rth_ARth Rsth Reqe f.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l). + + Record semi_field_theory : Prop := mk_sfield { + SF_SR : semi_ring_theory rO rI radd rmul req; + SF_1_neq_0 : ~ 1 == 0; + SFdiv_def : forall p q, p / q == p * / q; + SFinv_l : forall p, ~ p == 0 -> / p * p == 1 + }. + +End FieldAndSemiField. + +End MakeFieldPol. + + Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth + (sf:semi_field_theory rO rI radd rmul rdiv rinv req) := + mk_afield _ _ + (SRth_ARth Rsth sf.(SF_SR)) + sf.(SF_1_neq_0) + sf.(SFdiv_def) + sf.(SFinv_l). + + +Section Complete. + Variable R : Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). + Variable (rdiv : R -> R -> R) (rinv : R -> R). + Variable req : R -> R -> Prop. + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). + Notation "x / y " := (rdiv x y). Notation "/ x" := (rinv x). + Notation "x == y" := (req x y) (at level 70, no associativity). + Variable Rsth : Setoid_Theory R req. + Add Setoid R req Rsth as R_setoid3. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed. + +Section AlmostField. + + Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req. + Let ARth := AFth.(AF_AR). + Let rI_neq_rO := AFth.(AF_1_neq_0). + Let rdiv_def := AFth.(AFdiv_def). + Let rinv_l := AFth.(AFinv_l). + +Hypothesis S_inj : forall x y, 1+x==1+y -> x==y. + +Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. + +Lemma add_inj_r : forall p x y, + gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y. +intros p x y. +elim p using Pind; simpl in |- *; intros. + apply S_inj; trivial. + apply H. + apply S_inj. + repeat rewrite (ARadd_assoc ARth) in |- *. + rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth) in |- *; trivial. +Qed. + +Lemma gen_phiPOS_inj : forall x y, + gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y -> + x = y. +intros x y. +repeat rewrite <- (same_gen Rsth Reqe ARth) in |- *. +ElimPcompare x y; intro. + intros. + apply Pcompare_Eq_eq; trivial. + intro. + elim gen_phiPOS_not_0 with (y - x)%positive. + apply add_inj_r with x. + symmetry in |- *. + rewrite (ARadd_0_r Rsth ARth) in |- *. + rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. + rewrite Pplus_minus in |- *; trivial. + change Eq with (CompOpp Eq) in |- *. + rewrite <- Pcompare_antisym in |- *; trivial. + rewrite H in |- *; trivial. + intro. + elim gen_phiPOS_not_0 with (x - y)%positive. + apply add_inj_r with y. + rewrite (ARadd_0_r Rsth ARth) in |- *. + rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. + rewrite Pplus_minus in |- *; trivial. +Qed. + + +Lemma gen_phiN_inj : forall x y, + gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> + x = y. +destruct x; destruct y; simpl in |- *; intros; trivial. + elim gen_phiPOS_not_0 with p. + symmetry in |- *. + rewrite (same_gen Rsth Reqe ARth) in |- *; trivial. + elim gen_phiPOS_not_0 with p. + rewrite (same_gen Rsth Reqe ARth) in |- *; trivial. + rewrite gen_phiPOS_inj with (1 := H) in |- *; trivial. +Qed. + +Lemma gen_phiN_complete : forall x y, + gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> + Neq_bool x y = true. +intros. + replace y with x. + unfold Neq_bool in |- *. + rewrite Ncompare_refl in |- *; trivial. + apply gen_phiN_inj; trivial. +Qed. + +End AlmostField. + +Section Field. + + Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req. + Let Rth := Fth.(F_R). + Let rI_neq_rO := Fth.(F_1_neq_0). + Let rdiv_def := Fth.(Fdiv_def). + Let rinv_l := Fth.(Finv_l). + Let AFth := F2AF Rsth Reqe Fth. + Let ARth := Rth_ARth Rsth Reqe Rth. + +Lemma ring_S_inj : forall x y, 1+x==1+y -> x==y. +intros. +transitivity (x + (1 + - (1))). + rewrite (Ropp_def Rth) in |- *. + symmetry in |- *. + apply (ARadd_0_r Rsth ARth). + transitivity (y + (1 + - (1))). + repeat rewrite <- (ARplus_assoc ARth) in |- *. + repeat rewrite (ARadd_assoc ARth) in |- *. + apply (Radd_ext Reqe). + repeat rewrite <- (ARadd_comm ARth 1) in |- *. + trivial. + reflexivity. + rewrite (Ropp_def Rth) in |- *. + apply (ARadd_0_r Rsth ARth). +Qed. + + + Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. + +Let gen_phiPOS_inject := + gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0. + +Lemma gen_phiPOS_discr_sgn : forall x y, + ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y. +red in |- *; intros. +apply gen_phiPOS_not_0 with (y + x)%positive. +rewrite (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. +transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y). + apply (Radd_ext Reqe); trivial. + reflexivity. + rewrite (same_gen Rsth Reqe ARth) in |- *. + rewrite (same_gen Rsth Reqe ARth) in |- *. + trivial. + apply (Ropp_def Rth). +Qed. + +Lemma gen_phiZ_inj : forall x y, + gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> + x = y. +destruct x; destruct y; simpl in |- *; intros. + trivial. + elim gen_phiPOS_not_0 with p. + rewrite (same_gen Rsth Reqe ARth) in |- *. + symmetry in |- *; trivial. + elim gen_phiPOS_not_0 with p. + rewrite (same_gen Rsth Reqe ARth) in |- *. + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *. + rewrite <- H in |- *. + apply (ARopp_zero Rsth Reqe ARth). + elim gen_phiPOS_not_0 with p. + rewrite (same_gen Rsth Reqe ARth) in |- *. + trivial. + rewrite gen_phiPOS_inject with (1 := H) in |- *; trivial. + elim gen_phiPOS_discr_sgn with (1 := H). + elim gen_phiPOS_not_0 with p. + rewrite (same_gen Rsth Reqe ARth) in |- *. + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *. + rewrite H in |- *. + apply (ARopp_zero Rsth Reqe ARth). + elim gen_phiPOS_discr_sgn with p0 p. + symmetry in |- *; trivial. + replace p0 with p; trivial. + apply gen_phiPOS_inject. + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *. + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)) in |- *. + rewrite H in |- *; trivial. + reflexivity. +Qed. + +Lemma gen_phiZ_complete : forall x y, + gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> + Zeq_bool x y = true. +intros. + replace y with x. + unfold Zeq_bool in |- *. + rewrite Zcompare_refl in |- *; trivial. + apply gen_phiZ_inj; trivial. +Qed. + +End Field. + +End Complete. diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v new file mode 100644 index 00000000..b5384f80 --- /dev/null +++ b/plugins/setoid_ring/InitialRing.v @@ -0,0 +1,908 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* R->R) (ropp : R -> R). + Variable req : R -> R -> Prop. + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). + Notation "x == y" := (req x y). + Variable Rsth : Setoid_Theory R req. + Add Setoid R req Rsth as R_setoid3. + Ltac rrefl := gen_reflexivity Rsth. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed. + + Fixpoint gen_phiPOS1 (p:positive) : R := + match p with + | xH => 1 + | xO p => (1 + 1) * (gen_phiPOS1 p) + | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p)) + end. + + Fixpoint gen_phiPOS (p:positive) : R := + match p with + | xH => 1 + | xO xH => (1 + 1) + | xO p => (1 + 1) * (gen_phiPOS p) + | xI xH => 1 + (1 +1) + | xI p => 1 + ((1 + 1) * (gen_phiPOS p)) + end. + + Definition gen_phiZ1 z := + match z with + | Zpos p => gen_phiPOS1 p + | Z0 => 0 + | Zneg p => -(gen_phiPOS1 p) + end. + + Definition gen_phiZ z := + match z with + | Zpos p => gen_phiPOS p + | Z0 => 0 + | Zneg p => -(gen_phiPOS p) + end. + Notation "[ x ]" := (gen_phiZ x). + + Definition get_signZ z := + match z with + | Zneg p => Some (Zpos p) + | _ => None + end. + + Lemma get_signZ_th : sign_theory Zopp Zeq_bool get_signZ. + Proof. + constructor. + destruct c;intros;try discriminate. + injection H;clear H;intros H1;subst c'. + simpl. unfold Zeq_bool. rewrite Zcompare_refl. trivial. + Qed. + + + Section ALMOST_RING. + Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. + Add Morphism rsub : rsub_ext3. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac norm := gen_srewrite Rsth Reqe ARth. + Ltac add_push := gen_add_push radd Rsth Reqe ARth. + + Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. + Proof. + induction x;simpl. + rewrite IHx;destruct x;simpl;norm. + rewrite IHx;destruct x;simpl;norm. + rrefl. + Qed. + + Lemma ARgen_phiPOS_Psucc : forall x, + gen_phiPOS1 (Psucc x) == 1 + (gen_phiPOS1 x). + Proof. + induction x;simpl;norm. + rewrite IHx;norm. + add_push 1;rrefl. + Qed. + + Lemma ARgen_phiPOS_add : forall x y, + gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). + Proof. + induction x;destruct y;simpl;norm. + rewrite Pplus_carry_spec. + rewrite ARgen_phiPOS_Psucc. + rewrite IHx;norm. + add_push (gen_phiPOS1 y);add_push 1;rrefl. + rewrite IHx;norm;add_push (gen_phiPOS1 y);rrefl. + rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl. + rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;rrefl. + rewrite IHx;norm;add_push(gen_phiPOS1 y);rrefl. + add_push 1;rrefl. + rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl. + Qed. + + Lemma ARgen_phiPOS_mult : + forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y. + Proof. + induction x;intros;simpl;norm. + rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm. + rewrite IHx;rrefl. + Qed. + + End ALMOST_RING. + + Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. + Let ARth := Rth_ARth Rsth Reqe Rth. + Add Morphism rsub : rsub_ext4. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac norm := gen_srewrite Rsth Reqe ARth. + Ltac add_push := gen_add_push radd Rsth Reqe ARth. + +(*morphisms are extensionaly equal*) + Lemma same_genZ : forall x, [x] == gen_phiZ1 x. + Proof. + destruct x;simpl; try rewrite (same_gen ARth);rrefl. + Qed. + + Lemma gen_Zeqb_ok : forall x y, + Zeq_bool x y = true -> [x] == [y]. + Proof. + intros x y H. + assert (H1 := Zeq_bool_eq x y H);unfold IDphi in H1. + rewrite H1;rrefl. + Qed. + + Lemma gen_phiZ1_add_pos_neg : forall x y, + gen_phiZ1 + match (x ?= y)%positive Eq with + | Eq => Z0 + | Lt => Zneg (y - x) + | Gt => Zpos (x - y) + end + == gen_phiPOS1 x + -gen_phiPOS1 y. + Proof. + intros x y. + assert (H:= (Pcompare_Eq_eq x y)); assert (H0 := Pminus_mask_Gt x y). + generalize (Pminus_mask_Gt y x). + replace Eq with (CompOpp Eq);[intro H1;simpl|trivial]. + rewrite <- Pcompare_antisym in H1. + destruct ((x ?= y)%positive Eq). + rewrite H;trivial. rewrite (Ropp_def Rth);rrefl. + destruct H1 as [h [Heq1 [Heq2 Hor]]];trivial. + unfold Pminus; rewrite Heq1;rewrite <- Heq2. + rewrite (ARgen_phiPOS_add ARth);simpl;norm. + rewrite (Ropp_def Rth);norm. + destruct H0 as [h [Heq1 [Heq2 Hor]]];trivial. + unfold Pminus; rewrite Heq1;rewrite <- Heq2. + rewrite (ARgen_phiPOS_add ARth);simpl;norm. + add_push (gen_phiPOS1 h);rewrite (Ropp_def Rth); norm. + Qed. + + Lemma match_compOpp : forall x (B:Type) (be bl bg:B), + match CompOpp x with Eq => be | Lt => bl | Gt => bg end + = match x with Eq => be | Lt => bg | Gt => bl end. + Proof. destruct x;simpl;intros;trivial. Qed. + + Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. + Proof. + intros x y; repeat rewrite same_genZ; generalize x y;clear x y. + induction x;destruct y;simpl;norm. + apply (ARgen_phiPOS_add ARth). + apply gen_phiZ1_add_pos_neg. + replace Eq with (CompOpp Eq);trivial. + rewrite <- Pcompare_antisym;simpl. + rewrite match_compOpp. + rewrite (Radd_comm Rth). + apply gen_phiZ1_add_pos_neg. + rewrite (ARgen_phiPOS_add ARth); norm. + Qed. + + Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y]. + Proof. + intros x y;repeat rewrite same_genZ. + destruct x;destruct y;simpl;norm; + rewrite (ARgen_phiPOS_mult ARth);try (norm;fail). + rewrite (Ropp_opp Rsth Reqe Rth);rrefl. + Qed. + + Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y]. + Proof. intros;subst;rrefl. Qed. + +(*proof that [.] satisfies morphism specifications*) + Lemma gen_phiZ_morph : + ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) + Zplus Zmult Zminus Zopp Zeq_bool gen_phiZ. + Proof. + assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) + Zplus Zmult Zeq_bool gen_phiZ). + apply mkRmorph;simpl;try rrefl. + apply gen_phiZ_add. apply gen_phiZ_mul. apply gen_Zeqb_ok. + apply (Smorph_morph Rsth Reqe Rth Zth SRmorph gen_phiZ_ext). + Qed. + +End ZMORPHISM. + +(** N is a semi-ring and a setoid*) +Lemma Nsth : Setoid_Theory N (@eq N). +Proof (Eqsth N). + +Lemma Nseqe : sring_eq_ext Nplus Nmult (@eq N). +Proof (Eq_s_ext Nplus Nmult). + +Lemma Nth : semi_ring_theory N0 (Npos xH) Nplus Nmult (@eq N). +Proof. + constructor. exact Nplus_0_l. exact Nplus_comm. exact Nplus_assoc. + exact Nmult_1_l. exact Nmult_0_l. exact Nmult_comm. exact Nmult_assoc. + exact Nmult_plus_distr_r. +Qed. + +Definition Nsub := SRsub Nplus. +Definition Nopp := (@SRopp N). + +Lemma Neqe : ring_eq_ext Nplus Nmult Nopp (@eq N). +Proof (SReqe_Reqe Nseqe). + +Lemma Nath : + almost_ring_theory N0 (Npos xH) Nplus Nmult Nsub Nopp (@eq N). +Proof (SRth_ARth Nsth Nth). + +Definition Neq_bool (x y:N) := + match Ncompare x y with + | Eq => true + | _ => false + end. + +Lemma Neq_bool_ok : forall x y, Neq_bool x y = true -> x = y. + Proof. + intros x y;unfold Neq_bool. + assert (H:=Ncompare_Eq_eq x y); + destruct (Ncompare x y);intros;try discriminate. + rewrite H;trivial. + Qed. + +Lemma Neq_bool_complete : forall x y, Neq_bool x y = true -> x = y. + Proof. + intros x y;unfold Neq_bool. + assert (H:=Ncompare_Eq_eq x y); + destruct (Ncompare x y);intros;try discriminate. + rewrite H;trivial. + Qed. + +(**Same as above : definition of two,extensionaly equal, generic morphisms *) +(**from N to any semi-ring*) +Section NMORPHISM. + Variable R : Type. + Variable (rO rI : R) (radd rmul: R->R->R). + Variable req : R -> R -> Prop. + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Variable Rsth : Setoid_Theory R req. + Add Setoid R req Rsth as R_setoid4. + Ltac rrefl := gen_reflexivity Rsth. + Variable SReqe : sring_eq_ext radd rmul req. + Variable SRth : semi_ring_theory 0 1 radd rmul req. + Let ARth := SRth_ARth Rsth SRth. + Let Reqe := SReqe_Reqe SReqe. + Let ropp := (@SRopp R). + Let rsub := (@SRsub R radd). + Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). + Notation "x == y" := (req x y). + Add Morphism radd : radd_ext4. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext4. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext4. exact (Ropp_ext Reqe). Qed. + Add Morphism rsub : rsub_ext5. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac norm := gen_srewrite Rsth Reqe ARth. + + Definition gen_phiN1 x := + match x with + | N0 => 0 + | Npos x => gen_phiPOS1 1 radd rmul x + end. + + Definition gen_phiN x := + match x with + | N0 => 0 + | Npos x => gen_phiPOS 1 radd rmul x + end. + Notation "[ x ]" := (gen_phiN x). + + Lemma same_genN : forall x, [x] == gen_phiN1 x. + Proof. + destruct x;simpl. rrefl. + rewrite (same_gen Rsth Reqe ARth);rrefl. + Qed. + + Lemma gen_phiN_add : forall x y, [x + y] == [x] + [y]. + Proof. + intros x y;repeat rewrite same_genN. + destruct x;destruct y;simpl;norm. + apply (ARgen_phiPOS_add Rsth Reqe ARth). + Qed. + + Lemma gen_phiN_mult : forall x y, [x * y] == [x] * [y]. + Proof. + intros x y;repeat rewrite same_genN. + destruct x;destruct y;simpl;norm. + apply (ARgen_phiPOS_mult Rsth Reqe ARth). + Qed. + + Lemma gen_phiN_sub : forall x y, [Nsub x y] == [x] - [y]. + Proof. exact gen_phiN_add. Qed. + +(*gen_phiN satisfies morphism specifications*) + Lemma gen_phiN_morph : ring_morph 0 1 radd rmul rsub ropp req + N0 (Npos xH) Nplus Nmult Nsub Nopp Neq_bool gen_phiN. + Proof. + constructor;intros;simpl; try rrefl. + apply gen_phiN_add. apply gen_phiN_sub. apply gen_phiN_mult. + rewrite (Neq_bool_ok x y);trivial. rrefl. + Qed. + +End NMORPHISM. + +(* Words on N : initial structure for almost-rings. *) +Definition Nword := list N. +Definition NwO : Nword := nil. +Definition NwI : Nword := 1%N :: nil. + +Definition Nwcons n (w : Nword) : Nword := + match w, n with + | nil, 0%N => nil + | _, _ => n :: w + end. + +Fixpoint Nwadd (w1 w2 : Nword) {struct w1} : Nword := + match w1, w2 with + | n1::w1', n2:: w2' => (n1+n2)%N :: Nwadd w1' w2' + | nil, _ => w2 + | _, nil => w1 + end. + +Definition Nwopp (w:Nword) : Nword := Nwcons 0%N w. + +Definition Nwsub w1 w2 := Nwadd w1 (Nwopp w2). + +Fixpoint Nwscal (n : N) (w : Nword) {struct w} : Nword := + match w with + | m :: w' => (n*m)%N :: Nwscal n w' + | nil => nil + end. + +Fixpoint Nwmul (w1 w2 : Nword) {struct w1} : Nword := + match w1 with + | 0%N::w1' => Nwopp (Nwmul w1' w2) + | n1::w1' => Nwsub (Nwscal n1 w2) (Nwmul w1' w2) + | nil => nil + end. +Fixpoint Nw_is0 (w : Nword) : bool := + match w with + | nil => true + | 0%N :: w' => Nw_is0 w' + | _ => false + end. + +Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool := + match w1, w2 with + | n1::w1', n2::w2' => + if Neq_bool n1 n2 then Nweq_bool w1' w2' else false + | nil, _ => Nw_is0 w2 + | _, nil => Nw_is0 w1 + end. + +Section NWORDMORPHISM. + Variable R : Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). + Variable req : R -> R -> Prop. + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). + Notation "x == y" := (req x y). + Variable Rsth : Setoid_Theory R req. + Add Setoid R req Rsth as R_setoid5. + Ltac rrefl := gen_reflexivity Rsth. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Add Morphism radd : radd_ext5. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext5. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext5. exact (Ropp_ext Reqe). Qed. + + Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. + Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac norm := gen_srewrite Rsth Reqe ARth. + Ltac add_push := gen_add_push radd Rsth Reqe ARth. + + Fixpoint gen_phiNword (w : Nword) : R := + match w with + | nil => 0 + | n :: nil => gen_phiN rO rI radd rmul n + | N0 :: w' => - gen_phiNword w' + | n::w' => gen_phiN rO rI radd rmul n - gen_phiNword w' + end. + + Lemma gen_phiNword0_ok : forall w, Nw_is0 w = true -> gen_phiNword w == 0. +Proof. +induction w; simpl in |- *; intros; auto. + reflexivity. + + destruct a. + destruct w. + reflexivity. + + rewrite IHw in |- *; trivial. + apply (ARopp_zero Rsth Reqe ARth). + + discriminate. +Qed. + + Lemma gen_phiNword_cons : forall w n, + gen_phiNword (n::w) == gen_phiN rO rI radd rmul n - gen_phiNword w. +induction w. + destruct n; simpl in |- *; norm. + + intros. + destruct n; norm. +Qed. + + Lemma gen_phiNword_Nwcons : forall w n, + gen_phiNword (Nwcons n w) == gen_phiN rO rI radd rmul n - gen_phiNword w. +destruct w; intros. + destruct n; norm. + + unfold Nwcons in |- *. + rewrite gen_phiNword_cons in |- *. + reflexivity. +Qed. + + Lemma gen_phiNword_ok : forall w1 w2, + Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2. +induction w1; intros. + simpl in |- *. + rewrite (gen_phiNword0_ok _ H) in |- *. + reflexivity. + + rewrite gen_phiNword_cons in |- *. + destruct w2. + simpl in H. + destruct a; try discriminate. + rewrite (gen_phiNword0_ok _ H) in |- *. + norm. + + simpl in H. + rewrite gen_phiNword_cons in |- *. + case_eq (Neq_bool a n); intros. + rewrite H0 in H. + rewrite <- (Neq_bool_ok _ _ H0) in |- *. + rewrite (IHw1 _ H) in |- *. + reflexivity. + + rewrite H0 in H; discriminate H. +Qed. + + +Lemma Nwadd_ok : forall x y, + gen_phiNword (Nwadd x y) == gen_phiNword x + gen_phiNword y. +induction x; intros. + simpl in |- *. + norm. + + destruct y. + simpl Nwadd; norm. + + simpl Nwadd in |- *. + repeat rewrite gen_phiNword_cons in |- *. + rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) in |- * by + (destruct Reqe; constructor; trivial). + + rewrite IHx in |- *. + norm. + add_push (- gen_phiNword x); reflexivity. +Qed. + +Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x. +simpl in |- *. +unfold Nwopp in |- *; simpl in |- *. +intros. +rewrite gen_phiNword_Nwcons in |- *; norm. +Qed. + +Lemma Nwscal_ok : forall n x, + gen_phiNword (Nwscal n x) == gen_phiN rO rI radd rmul n * gen_phiNword x. +induction x; intros. + norm. + + simpl Nwscal in |- *. + repeat rewrite gen_phiNword_cons in |- *. + rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- * + by (destruct Reqe; constructor; trivial). + + rewrite IHx in |- *. + norm. +Qed. + +Lemma Nwmul_ok : forall x y, + gen_phiNword (Nwmul x y) == gen_phiNword x * gen_phiNword y. +induction x; intros. + norm. + + destruct a. + simpl Nwmul in |- *. + rewrite Nwopp_ok in |- *. + rewrite IHx in |- *. + rewrite gen_phiNword_cons in |- *. + norm. + + simpl Nwmul in |- *. + unfold Nwsub in |- *. + rewrite Nwadd_ok in |- *. + rewrite Nwscal_ok in |- *. + rewrite Nwopp_ok in |- *. + rewrite IHx in |- *. + rewrite gen_phiNword_cons in |- *. + norm. +Qed. + +(* Proof that [.] satisfies morphism specifications *) + Lemma gen_phiNword_morph : + ring_morph 0 1 radd rmul rsub ropp req + NwO NwI Nwadd Nwmul Nwsub Nwopp Nweq_bool gen_phiNword. +constructor. + reflexivity. + + reflexivity. + + exact Nwadd_ok. + + intros. + unfold Nwsub in |- *. + rewrite Nwadd_ok in |- *. + rewrite Nwopp_ok in |- *. + norm. + + exact Nwmul_ok. + + exact Nwopp_ok. + + exact gen_phiNword_ok. +Qed. + +End NWORDMORPHISM. + +Section GEN_DIV. + + Variables (R : Type) (rO : R) (rI : R) (radd : R -> R -> R) + (rmul : R -> R -> R) (rsub : R -> R -> R) (ropp : R -> R) + (req : R -> R -> Prop) (C : Type) (cO : C) (cI : C) + (cadd : C -> C -> C) (cmul : C -> C -> C) (csub : C -> C -> C) + (copp : C -> C) (ceqb : C -> C -> bool) (phi : C -> R). + Variable Rsth : Setoid_Theory R req. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. + Variable morph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. + + (* Useful tactics *) + Add Setoid R req Rsth as R_set1. + Ltac rrefl := gen_reflexivity Rsth. + Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. + Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac rsimpl := gen_srewrite Rsth Reqe ARth. + + Definition triv_div x y := + if ceqb x y then (cI, cO) + else (cO, x). + + Ltac Esimpl :=repeat (progress ( + match goal with + | |- context [phi cO] => rewrite (morph0 morph) + | |- context [phi cI] => rewrite (morph1 morph) + | |- context [phi (cadd ?x ?y)] => rewrite ((morph_add morph) x y) + | |- context [phi (cmul ?x ?y)] => rewrite ((morph_mul morph) x y) + | |- context [phi (csub ?x ?y)] => rewrite ((morph_sub morph) x y) + | |- context [phi (copp ?x)] => rewrite ((morph_opp morph) x) + end)). + + Lemma triv_div_th : Ring_theory.div_theory req cadd cmul phi triv_div. + Proof. + constructor. + intros a b;unfold triv_div. + assert (X:= morph.(morph_eq) a b);destruct (ceqb a b). + Esimpl. + rewrite X; trivial. + rsimpl. + Esimpl; rsimpl. +Qed. + + Variable zphi : Z -> R. + + Lemma Ztriv_div_th : div_theory req Zplus Zmult zphi ZOdiv_eucl. + Proof. + constructor. + intros; generalize (ZOdiv_eucl_correct a b); case ZOdiv_eucl; intros; subst. + rewrite Zmult_comm; rsimpl. + Qed. + + Variable nphi : N -> R. + + Lemma Ntriv_div_th : div_theory req Nplus Nmult nphi Ndiv_eucl. + constructor. + intros; generalize (Ndiv_eucl_correct a b); case Ndiv_eucl; intros; subst. + rewrite Nmult_comm; rsimpl. + Qed. + +End GEN_DIV. + + (* syntaxification of constants in an abstract ring: + the inverse of gen_phiPOS *) + Ltac inv_gen_phi_pos rI add mul t := + let rec inv_cst t := + match t with + rI => constr:1%positive + | (add rI rI) => constr:2%positive + | (add rI (add rI rI)) => constr:3%positive + | (mul (add rI rI) ?p) => (* 2p *) + match inv_cst p with + NotConstant => constr:NotConstant + | 1%positive => constr:NotConstant (* 2*1 is not convertible to 2 *) + | ?p => constr:(xO p) + end + | (add rI (mul (add rI rI) ?p)) => (* 1+2p *) + match inv_cst p with + NotConstant => constr:NotConstant + | 1%positive => constr:NotConstant + | ?p => constr:(xI p) + end + | _ => constr:NotConstant + end in + inv_cst t. + +(* The (partial) inverse of gen_phiNword *) + Ltac inv_gen_phiNword rO rI add mul opp t := + match t with + rO => constr:NwO + | _ => + match inv_gen_phi_pos rI add mul t with + NotConstant => constr:NotConstant + | ?p => constr:(Npos p::nil) + end + end. + + +(* The inverse of gen_phiN *) + Ltac inv_gen_phiN rO rI add mul t := + match t with + rO => constr:0%N + | _ => + match inv_gen_phi_pos rI add mul t with + NotConstant => constr:NotConstant + | ?p => constr:(Npos p) + end + end. + +(* The inverse of gen_phiZ *) + Ltac inv_gen_phiZ rO rI add mul opp t := + match t with + rO => constr:0%Z + | (opp ?p) => + match inv_gen_phi_pos rI add mul p with + NotConstant => constr:NotConstant + | ?p => constr:(Zneg p) + end + | _ => + match inv_gen_phi_pos rI add mul t with + NotConstant => constr:NotConstant + | ?p => constr:(Zpos p) + end + end. + +(* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above + are only optimisations that directly returns the reifid constant + instead of resorting to the constant propagation of the simplification + algorithm. *) +Ltac inv_gen_phi rO rI cO cI t := + match t with + | rO => cO + | rI => cI + end. + +(* A simple tactic recognizing no constant *) + Ltac inv_morph_nothing t := constr:NotConstant. + +Ltac coerce_to_almost_ring set ext rspec := + match type of rspec with + | ring_theory _ _ _ _ _ _ _ => constr:(Rth_ARth set ext rspec) + | semi_ring_theory _ _ _ _ _ => constr:(SRth_ARth set rspec) + | almost_ring_theory _ _ _ _ _ _ _ => rspec + | _ => fail 1 "not a valid ring theory" + end. + +Ltac coerce_to_ring_ext ext := + match type of ext with + | ring_eq_ext _ _ _ _ => ext + | sring_eq_ext _ _ _ => constr:(SReqe_Reqe ext) + | _ => fail 1 "not a valid ring_eq_ext theory" + end. + +Ltac abstract_ring_morphism set ext rspec := + match type of rspec with + | ring_theory _ _ _ _ _ _ _ => constr:(gen_phiZ_morph set ext rspec) + | semi_ring_theory _ _ _ _ _ => constr:(gen_phiN_morph set ext rspec) + | almost_ring_theory _ _ _ _ _ _ _ => + constr:(gen_phiNword_morph set ext rspec) + | _ => fail 1 "bad ring structure" + end. + +Record hypo : Type := mkhypo { + hypo_type : Type; + hypo_proof : hypo_type + }. + +Ltac gen_ring_pow set arth pspec := + match pspec with + | None => + match type of arth with + | @almost_ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req => + constr:(mkhypo (@pow_N_th R rI rmul req set)) + | _ => fail 1 "gen_ring_pow" + end + | Some ?t => constr:(t) + end. + +Ltac gen_ring_sign morph sspec := + match sspec with + | None => + match type of morph with + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + Z ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => + constr:(@mkhypo (sign_theory copp ceqb get_signZ) get_signZ_th) + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => + constr:(mkhypo (@get_sign_None_th C copp ceqb)) + | _ => fail 2 "ring anomaly : default_sign_spec" + end + | Some ?t => constr:(t) + end. + +Ltac default_div_spec set reqe arth morph := + match type of morph with + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + Z ?c0 ?c1 Zplus Zmult ?csub ?copp ?ceq_b ?phi => + constr:(mkhypo (Ztriv_div_th set phi)) + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + N ?c0 ?c1 Nplus Nmult ?csub ?copp ?ceq_b ?phi => + constr:(mkhypo (Ntriv_div_th set phi)) + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => + constr:(mkhypo (triv_div_th set reqe arth morph)) + | _ => fail 1 "ring anomaly : default_sign_spec" + end. + +Ltac gen_ring_div set reqe arth morph dspec := + match dspec with + | None => default_div_spec set reqe arth morph + | Some ?t => constr:(t) + end. + +Ltac ring_elements set ext rspec pspec sspec dspec rk := + let arth := coerce_to_almost_ring set ext rspec in + let ext_r := coerce_to_ring_ext ext in + let morph := + match rk with + | Abstract => abstract_ring_morphism set ext rspec + | @Computational ?reqb_ok => + match type of arth with + | almost_ring_theory ?rO ?rI ?add ?mul ?sub ?opp _ => + constr:(IDmorph rO rI add mul sub opp set _ reqb_ok) + | _ => fail 2 "ring anomaly" + end + | @Morphism ?m => + match type of m with + | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m + | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ => + constr:(SRmorph_Rmorph set m) + | _ => fail 2 "ring anomaly" + end + | _ => fail 1 "ill-formed ring kind" + end in + let p_spec := gen_ring_pow set arth pspec in + let s_spec := gen_ring_sign morph sspec in + let d_spec := gen_ring_div set ext_r arth morph dspec in + fun f => f arth ext_r morph p_spec s_spec d_spec. + +(* Given a ring structure and the kind of morphism, + returns 2 lemmas (one for ring, and one for ring_simplify). *) + + Ltac ring_lemmas set ext rspec pspec sspec dspec rk := + let gen_lemma2 := + match pspec with + | None => constr:(ring_rw_correct) + | Some _ => constr:(ring_rw_pow_correct) + end in + ring_elements set ext rspec pspec sspec dspec rk + ltac:(fun arth ext_r morph p_spec s_spec d_spec => + match type of morph with + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => + let gen_lemma2_0 := + constr:(gen_lemma2 R r0 rI radd rmul rsub ropp req set ext_r arth + C c0 c1 cadd cmul csub copp ceq_b phi morph) in + match p_spec with + | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec => + let gen_lemma2_1 := constr:(gen_lemma2_0 _ Cp_phi rpow pp_spec) in + match d_spec with + | @mkhypo (div_theory _ _ _ _ ?cdiv) ?dd_spec => + let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in + match s_spec with + | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec => + let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in + let lemma1 := + constr:(ring_correct set ext_r arth morph pp_spec dd_spec) in + fun f => f arth ext_r morph lemma1 lemma2 + | _ => fail 4 "ring: bad sign specification" + end + | _ => fail 3 "ring: bad coefficiant division specification" + end + | _ => fail 2 "ring: bad power specification" + end + | _ => fail 1 "ring internal error: ring_lemmas, please report" + end). + +(* Tactic for constant *) +Ltac isnatcst t := + match t with + O => constr:true + | S ?p => isnatcst p + | _ => constr:false + end. + +Ltac isPcst t := + match t with + | xI ?p => isPcst p + | xO ?p => isPcst p + | xH => constr:true + (* nat -> positive *) + | P_of_succ_nat ?n => isnatcst n + | _ => constr:false + end. + +Ltac isNcst t := + match t with + N0 => constr:true + | Npos ?p => isPcst p + | _ => constr:false + end. + +Ltac isZcst t := + match t with + Z0 => constr:true + | Zpos ?p => isPcst p + | Zneg ?p => isPcst p + (* injection nat -> Z *) + | Z_of_nat ?n => isnatcst n + (* injection N -> Z *) + | Z_of_N ?n => isNcst n + (* *) + | _ => constr:false + end. + + + + + diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v new file mode 100644 index 00000000..0ba519fd --- /dev/null +++ b/plugins/setoid_ring/NArithRing.v @@ -0,0 +1,21 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t + | _ => constr:NotConstant + end. + +Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]). diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v new file mode 100644 index 00000000..56473adb --- /dev/null +++ b/plugins/setoid_ring/RealField.v @@ -0,0 +1,134 @@ +Require Import Nnat. +Require Import ArithRing. +Require Export Ring Field. +Require Import Rdefinitions. +Require Import Rpow_def. +Require Import Raxioms. + +Open Local Scope R_scope. + +Lemma RTheory : ring_theory 0 1 Rplus Rmult Rminus Ropp (eq (A:=R)). +Proof. +constructor. + intro; apply Rplus_0_l. + exact Rplus_comm. + symmetry in |- *; apply Rplus_assoc. + intro; apply Rmult_1_l. + exact Rmult_comm. + symmetry in |- *; apply Rmult_assoc. + intros m n p. + rewrite Rmult_comm in |- *. + rewrite (Rmult_comm n p) in |- *. + rewrite (Rmult_comm m p) in |- *. + apply Rmult_plus_distr_l. + reflexivity. + exact Rplus_opp_r. +Qed. + +Lemma Rfield : field_theory 0 1 Rplus Rmult Rminus Ropp Rdiv Rinv (eq(A:=R)). +Proof. +constructor. + exact RTheory. + exact R1_neq_R0. + reflexivity. + exact Rinv_l. +Qed. + +Lemma Rlt_n_Sn : forall x, x < x + 1. +Proof. +intro. +elim archimed with x; intros. +destruct H0. + apply Rlt_trans with (IZR (up x)); trivial. + replace (IZR (up x)) with (x + (IZR (up x) - x))%R. + apply Rplus_lt_compat_l; trivial. + unfold Rminus in |- *. + rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *. + rewrite <- Rplus_assoc in |- *. + rewrite Rplus_opp_r in |- *. + apply Rplus_0_l. + elim H0. + unfold Rminus in |- *. + rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *. + rewrite <- Rplus_assoc in |- *. + rewrite Rplus_opp_r in |- *. + rewrite Rplus_0_l in |- *; trivial. +Qed. + +Notation Rset := (Eqsth R). +Notation Rext := (Eq_ext Rplus Rmult Ropp). + +Lemma Rlt_0_2 : 0 < 2. +apply Rlt_trans with (0 + 1). + apply Rlt_n_Sn. + rewrite Rplus_comm in |- *. + apply Rplus_lt_compat_l. + replace 1 with (0 + 1). + apply Rlt_n_Sn. + apply Rplus_0_l. +Qed. + +Lemma Rgen_phiPOS : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x > 0. +unfold Rgt in |- *. +induction x; simpl in |- *; intros. + apply Rlt_trans with (1 + 0). + rewrite Rplus_comm in |- *. + apply Rlt_n_Sn. + apply Rplus_lt_compat_l. + rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *. + rewrite Rmult_comm in |- *. + apply Rmult_lt_compat_l. + apply Rlt_0_2. + trivial. + rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *. + rewrite Rmult_comm in |- *. + apply Rmult_lt_compat_l. + apply Rlt_0_2. + trivial. + replace 1 with (0 + 1). + apply Rlt_n_Sn. + apply Rplus_0_l. +Qed. + + +Lemma Rgen_phiPOS_not_0 : + forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0. +red in |- *; intros. +specialize (Rgen_phiPOS x). +rewrite H in |- *; intro. +apply (Rlt_asym 0 0); trivial. +Qed. + +Lemma Zeq_bool_complete : forall x y, + InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x = + InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y -> + Zeq_bool x y = true. +Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0. + +Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x (n + m) = pow x n * pow x m. +Proof. + intros x n; elim n; simpl in |- *; auto with real. + intros n0 H' m; rewrite H'; auto with real. +Qed. + +Lemma R_power_theory : power_theory 1%R Rmult (eq (A:=R)) nat_of_N pow. +Proof. + constructor. destruct n. reflexivity. + simpl. induction p;simpl. + rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity. + unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial. + rewrite Rmult_comm;apply Rmult_1_l. +Qed. + +Ltac Rpow_tac t := + match isnatcst t with + | false => constr:(InitialRing.NotConstant) + | _ => constr:(N_of_nat t) + end. + +Add Field RField : Rfield + (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]). + + + + diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v new file mode 100644 index 00000000..d01b1625 --- /dev/null +++ b/plugins/setoid_ring/Ring.v @@ -0,0 +1,44 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* b) (eq(A:=bool)). +split; simpl in |- *. +destruct x; reflexivity. +destruct x; destruct y; reflexivity. +destruct x; destruct y; destruct z; reflexivity. +reflexivity. +destruct x; destruct y; reflexivity. +destruct x; destruct y; reflexivity. +destruct x; destruct y; destruct z; reflexivity. +reflexivity. +destruct x; reflexivity. +Qed. + +Definition bool_eq (b1 b2:bool) := + if b1 then b2 else negb b2. + +Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2. +destruct b1; destruct b2; auto. +Qed. + +Ltac bool_cst t := + let t := eval hnf in t in + match t with + true => constr:true + | false => constr:false + | _ => constr:NotConstant + end. + +Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]). diff --git a/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v new file mode 100644 index 00000000..fd9dd8d0 --- /dev/null +++ b/plugins/setoid_ring/Ring_base.v @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aopp : A -> A. +Variable Aeq : A -> A -> bool. +Variable R : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. + +Let Aminus := fun x y => Aplus x (Aopp y). + +Lemma ring_equiv1 : + ring_theory Azero Aone Aplus Amult Aminus Aopp (eq (A:=A)). +Proof. +destruct R. +split; eauto. +Qed. + +End Old2New. + +Section New2OldRing. + Variable R : Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). + Variable Rth : ring_theory rO rI radd rmul rsub ropp (eq (A:=R)). + + Variable reqb : R -> R -> bool. + Variable reqb_ok : forall x y, reqb x y = true -> x = y. + + Lemma ring_equiv2 : + Ring_Theory radd rmul rI rO ropp reqb. +Proof. +elim Rth; intros; constructor; eauto. +intros. +apply reqb_ok. +destruct (reqb x y); trivial; intros. +elim H. +Qed. + + Definition default_eqb : R -> R -> bool := fun x y => false. + Lemma default_eqb_ok : forall x y, default_eqb x y = true -> x = y. +Proof. +discriminate 1. +Qed. + +End New2OldRing. + +Section New2OldSemiRing. + Variable R : Type. + Variable (rO rI : R) (radd rmul: R->R->R). + Variable SRth : semi_ring_theory rO rI radd rmul (eq (A:=R)). + + Variable reqb : R -> R -> bool. + Variable reqb_ok : forall x y, reqb x y = true -> x = y. + + Lemma sring_equiv2 : + Semi_Ring_Theory radd rmul rI rO reqb. +Proof. +elim SRth; intros; constructor; eauto. +intros. +apply reqb_ok. +destruct (reqb x y); trivial; intros. +elim H. +Qed. + +End New2OldSemiRing. diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v new file mode 100644 index 00000000..faa83ded --- /dev/null +++ b/plugins/setoid_ring/Ring_polynom.v @@ -0,0 +1,1781 @@ +(************************************************************************) +(* V * The Coq Proof Assistant / The Coq Development Team *) +(* R->R) (ropp : R->R). + Variable req : R -> R -> Prop. + + (* Ring properties *) + Variable Rsth : Setoid_Theory R req. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. + + (* Coefficients *) + Variable C: Type. + Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). + Variable ceqb : C->C->bool. + Variable phi : C -> R. + Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req + cO cI cadd cmul csub copp ceqb phi. + + (* Power coefficients *) + Variable Cpow : Set. + Variable Cp_phi : N -> Cpow. + Variable rpow : R -> Cpow -> R. + Variable pow_th : power_theory rI rmul req Cp_phi rpow. + + (* division is ok *) + Variable cdiv: C -> C -> C * C. + Variable div_th: div_theory req cadd cmul phi cdiv. + + + (* R notations *) + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). + Notation "x == y" := (req x y). + + (* C notations *) + Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). + Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). + Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). + + (* Useful tactics *) + Add Setoid R req Rsth as R_set1. + Ltac rrefl := gen_reflexivity Rsth. + Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. + Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac rsimpl := gen_srewrite Rsth Reqe ARth. + Ltac add_push := gen_add_push radd Rsth Reqe ARth. + Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. + + (* Definition of multivariable polynomials with coefficients in C : + Type [Pol] represents [X1 ... Xn]. + The representation is Horner's where a [n] variable polynomial + (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients + are polynomials with [n-1] variables (C[X2..Xn]). + There are several optimisations to make the repr compacter: + - [Pc c] is the constant polynomial of value c + == c*X1^0*..*Xn^0 + - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. + variable indices are shifted of j in Q. + == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} + - [PX P i Q] is an optimised Horner form of P*X^i + Q + with P not the null polynomial + == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} + + In addition: + - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden + since they can be represented by the simpler form (PX P (i+j) Q) + - (Pinj i (Pinj j P)) is (Pinj (i+j) P) + - (Pinj i (Pc c)) is (Pc c) + *) + + Inductive Pol : Type := + | Pc : C -> Pol + | Pinj : positive -> Pol -> Pol + | PX : Pol -> positive -> Pol -> Pol. + + Definition P0 := Pc cO. + Definition P1 := Pc cI. + + Fixpoint Peq (P P' : Pol) {struct P'} : bool := + match P, P' with + | Pc c, Pc c' => c ?=! c' + | Pinj j Q, Pinj j' Q' => + match Pcompare j j' Eq with + | Eq => Peq Q Q' + | _ => false + end + | PX P i Q, PX P' i' Q' => + match Pcompare i i' Eq with + | Eq => if Peq P P' then Peq Q Q' else false + | _ => false + end + | _, _ => false + end. + + Notation " P ?== P' " := (Peq P P'). + + Definition mkPinj j P := + match P with + | Pc _ => P + | Pinj j' Q => Pinj ((j + j'):positive) Q + | _ => Pinj j P + end. + + Definition mkPinj_pred j P:= + match j with + | xH => P + | xO j => Pinj (Pdouble_minus_one j) P + | xI j => Pinj (xO j) P + end. + + Definition mkPX P i Q := + match P with + | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q + | Pinj _ _ => PX P i Q + | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q + end. + + Definition mkXi i := PX P1 i P0. + + Definition mkX := mkXi 1. + + (** Opposite of addition *) + + Fixpoint Popp (P:Pol) : Pol := + match P with + | Pc c => Pc (-! c) + | Pinj j Q => Pinj j (Popp Q) + | PX P i Q => PX (Popp P) i (Popp Q) + end. + + Notation "-- P" := (Popp P). + + (** Addition et subtraction *) + + Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol := + match P with + | Pc c1 => Pc (c1 +! c) + | Pinj j Q => Pinj j (PaddC Q c) + | PX P i Q => PX P i (PaddC Q c) + end. + + Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol := + match P with + | Pc c1 => Pc (c1 -! c) + | Pinj j Q => Pinj j (PsubC Q c) + | PX P i Q => PX P i (PsubC Q c) + end. + + Section PopI. + + Variable Pop : Pol -> Pol -> Pol. + Variable Q : Pol. + + Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol := + match P with + | Pc c => mkPinj j (PaddC Q c) + | Pinj j' Q' => + match ZPminus j' j with + | Zpos k => mkPinj j (Pop (Pinj k Q') Q) + | Z0 => mkPinj j (Pop Q' Q) + | Zneg k => mkPinj j' (PaddI k Q') + end + | PX P i Q' => + match j with + | xH => PX P i (Pop Q' Q) + | xO j => PX P i (PaddI (Pdouble_minus_one j) Q') + | xI j => PX P i (PaddI (xO j) Q') + end + end. + + Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol := + match P with + | Pc c => mkPinj j (PaddC (--Q) c) + | Pinj j' Q' => + match ZPminus j' j with + | Zpos k => mkPinj j (Pop (Pinj k Q') Q) + | Z0 => mkPinj j (Pop Q' Q) + | Zneg k => mkPinj j' (PsubI k Q') + end + | PX P i Q' => + match j with + | xH => PX P i (Pop Q' Q) + | xO j => PX P i (PsubI (Pdouble_minus_one j) Q') + | xI j => PX P i (PsubI (xO j) Q') + end + end. + + Variable P' : Pol. + + Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol := + match P with + | Pc c => PX P' i' P + | Pinj j Q' => + match j with + | xH => PX P' i' Q' + | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q') + | xI j => PX P' i' (Pinj (xO j) Q') + end + | PX P i Q' => + match ZPminus i i' with + | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' + | Z0 => mkPX (Pop P P') i Q' + | Zneg k => mkPX (PaddX k P) i Q' + end + end. + + Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol := + match P with + | Pc c => PX (--P') i' P + | Pinj j Q' => + match j with + | xH => PX (--P') i' Q' + | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q') + | xI j => PX (--P') i' (Pinj (xO j) Q') + end + | PX P i Q' => + match ZPminus i i' with + | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' + | Z0 => mkPX (Pop P P') i Q' + | Zneg k => mkPX (PsubX k P) i Q' + end + end. + + + End PopI. + + Fixpoint Padd (P P': Pol) {struct P'} : Pol := + match P' with + | Pc c' => PaddC P c' + | Pinj j' Q' => PaddI Padd Q' j' P + | PX P' i' Q' => + match P with + | Pc c => PX P' i' (PaddC Q' c) + | Pinj j Q => + match j with + | xH => PX P' i' (Padd Q Q') + | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q') + | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') + end + | PX P i Q => + match ZPminus i i' with + | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') + | Z0 => mkPX (Padd P P') i (Padd Q Q') + | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') + end + end + end. + Notation "P ++ P'" := (Padd P P'). + + Fixpoint Psub (P P': Pol) {struct P'} : Pol := + match P' with + | Pc c' => PsubC P c' + | Pinj j' Q' => PsubI Psub Q' j' P + | PX P' i' Q' => + match P with + | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) + | Pinj j Q => + match j with + | xH => PX (--P') i' (Psub Q Q') + | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q') + | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') + end + | PX P i Q => + match ZPminus i i' with + | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') + | Z0 => mkPX (Psub P P') i (Psub Q Q') + | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') + end + end + end. + Notation "P -- P'" := (Psub P P'). + + (** Multiplication *) + + Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := + match P with + | Pc c' => Pc (c' *! c) + | Pinj j Q => mkPinj j (PmulC_aux Q c) + | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) + end. + + Definition PmulC P c := + if c ?=! cO then P0 else + if c ?=! cI then P else PmulC_aux P c. + + Section PmulI. + Variable Pmul : Pol -> Pol -> Pol. + Variable Q : Pol. + Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol := + match P with + | Pc c => mkPinj j (PmulC Q c) + | Pinj j' Q' => + match ZPminus j' j with + | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) + | Z0 => mkPinj j (Pmul Q' Q) + | Zneg k => mkPinj j' (PmulI k Q') + end + | PX P' i' Q' => + match j with + | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) + | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q') + | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') + end + end. + + End PmulI. +(* A symmetric version of the multiplication *) + + Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := + match P'' with + | Pc c => PmulC P c + | Pinj j' Q' => PmulI Pmul Q' j' P + | PX P' i' Q' => + match P with + | Pc c => PmulC P'' c + | Pinj j Q => + let QQ' := + match j with + | xH => Pmul Q Q' + | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q' + | xI j => Pmul (Pinj (xO j) Q) Q' + end in + mkPX (Pmul P P') i' QQ' + | PX P i Q=> + let QQ' := Pmul Q Q' in + let PQ' := PmulI Pmul Q' xH P in + let QP' := Pmul (mkPinj xH Q) P' in + let PP' := Pmul P P' in + (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' + end + end. + +(* Non symmetric *) +(* + Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol := + match P' with + | Pc c' => PmulC P c' + | Pinj j' Q' => PmulI Pmul_aux Q' j' P + | PX P' i' Q' => + (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P) + end. + + Definition Pmul P P' := + match P with + | Pc c => PmulC P' c + | Pinj j Q => PmulI Pmul_aux Q j P' + | PX P i Q => + (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P') + end. +*) + Notation "P ** P'" := (Pmul P P'). + + Fixpoint Psquare (P:Pol) : Pol := + match P with + | Pc c => Pc (c *! c) + | Pinj j Q => Pinj j (Psquare Q) + | PX P i Q => + let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in + let Q2 := Psquare Q in + let P2 := Psquare P in + mkPX (mkPX P2 i P0 ++ twoPQ) i Q2 + end. + + (** Monomial **) + + Inductive Mon: Set := + mon0: Mon + | zmon: positive -> Mon -> Mon + | vmon: positive -> Mon -> Mon. + + Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R := + match M with + mon0 => rI + | zmon j M1 => Mphi (jump j l) M1 + | vmon i M1 => + let x := hd 0 l in + let xi := pow_pos rmul x i in + (Mphi (tail l) M1) * xi + end. + + Definition mkZmon j M := + match M with mon0 => mon0 | _ => zmon j M end. + + Definition zmon_pred j M := + match j with xH => M | _ => mkZmon (Ppred j) M end. + + Definition mkVmon i M := + match M with + | mon0 => vmon i mon0 + | zmon j m => vmon i (zmon_pred j m) + | vmon i' m => vmon (i+i') m + end. + + Fixpoint CFactor (P: Pol) (c: C) {struct P}: Pol * Pol := + match P with + | Pc c1 => let (q,r) := cdiv c1 c in (Pc r, Pc q) + | Pinj j1 P1 => + let (R,S) := CFactor P1 c in + (mkPinj j1 R, mkPinj j1 S) + | PX P1 i Q1 => + let (R1, S1) := CFactor P1 c in + let (R2, S2) := CFactor Q1 c in + (mkPX R1 i R2, mkPX S1 i S2) + end. + + Fixpoint MFactor (P: Pol) (c: C) (M: Mon) {struct P}: Pol * Pol := + match P, M with + _, mon0 => + if (ceqb c cI) then (Pc cO, P) else +(* if (ceqb c (copp cI)) then (Pc cO, Popp P) else Not in almost ring *) + CFactor P c + | Pc _, _ => (P, Pc cO) + | Pinj j1 P1, zmon j2 M1 => + match (j1 ?= j2) Eq with + Eq => let (R,S) := MFactor P1 c M1 in + (mkPinj j1 R, mkPinj j1 S) + | Lt => let (R,S) := MFactor P1 c (zmon (j2 - j1) M1) in + (mkPinj j1 R, mkPinj j1 S) + | Gt => (P, Pc cO) + end + | Pinj _ _, vmon _ _ => (P, Pc cO) + | PX P1 i Q1, zmon j M1 => + let M2 := zmon_pred j M1 in + let (R1, S1) := MFactor P1 c M in + let (R2, S2) := MFactor Q1 c M2 in + (mkPX R1 i R2, mkPX S1 i S2) + | PX P1 i Q1, vmon j M1 => + match (i ?= j) Eq with + Eq => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in + (mkPX R1 i Q1, S1) + | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in + (mkPX R1 i Q1, S1) + | Gt => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in + (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) + end + end. + + Definition POneSubst (P1: Pol) (cM1: C * Mon) (P2: Pol): option Pol := + let (c,M1) := cM1 in + let (Q1,R1) := MFactor P1 c M1 in + match R1 with + (Pc c) => if c ?=! cO then None + else Some (Padd Q1 (Pmul P2 R1)) + | _ => Some (Padd Q1 (Pmul P2 R1)) + end. + + Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) {struct n}: Pol := + match POneSubst P1 cM1 P2 with + Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end + | _ => P1 + end. + + Definition PNSubst (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol := + match POneSubst P1 cM1 P2 with + Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end + | _ => None + end. + + Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: + Pol := + match LM1 with + cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n + | _ => P1 + end. + + Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: option Pol := + match LM1 with + cons (M1,P2) LM2 => + match PNSubst P1 M1 P2 n with + Some P3 => Some (PSubstL1 P3 LM2 n) + | None => PSubstL P1 LM2 n + end + | _ => None + end. + + Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) {struct m}: Pol := + match PSubstL P1 LM1 n with + Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end + | _ => P1 + end. + + (** Evaluation of a polynomial towards R *) + + Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R := + match P with + | Pc c => [c] + | Pinj j Q => Pphi (jump j l) Q + | PX P i Q => + let x := hd 0 l in + let xi := pow_pos rmul x i in + (Pphi l P) * xi + (Pphi (tail l) Q) + end. + + Reserved Notation "P @ l " (at level 10, no associativity). + Notation "P @ l " := (Pphi l P). + (** Proofs *) + Lemma ZPminus_spec : forall x y, + match ZPminus x y with + | Z0 => x = y + | Zpos k => x = (y + k)%positive + | Zneg k => y = (x + k)%positive + end. + Proof. + induction x;destruct y. + replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial. + assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. + replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial. + assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial. + apply Pplus_xI_double_minus_one. + simpl;trivial. + replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial. + assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial. + apply Pplus_xI_double_minus_one. + replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial. + assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. + replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO;trivial. + replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial. + replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO;trivial. + simpl;trivial. + Qed. + + Lemma Peq_ok : forall P P', + (P ?== P') = true -> forall l, P@l == P'@ l. + Proof. + induction P;destruct P';simpl;intros;try discriminate;trivial. + apply (morph_eq CRmorph);trivial. + assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); + try discriminate H. + rewrite (IHP P' H); rewrite H1;trivial;rrefl. + assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); + try discriminate H. + rewrite H1;trivial. clear H1. + assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2); + destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H] + |discriminate H]. + rewrite (H1 H);rewrite (H2 H);rrefl. + Qed. + + Lemma Pphi0 : forall l, P0@l == 0. + Proof. + intros;simpl;apply (morph0 CRmorph). + Qed. + + Lemma Pphi1 : forall l, P1@l == 1. + Proof. + intros;simpl;apply (morph1 CRmorph). + Qed. + + Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l). + Proof. + intros j l p;destruct p;simpl;rsimpl. + rewrite <-jump_Pplus;rewrite Pplus_comm;rrefl. + Qed. + + Let pow_pos_Pplus := + pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc). + + Lemma mkPX_ok : forall l P i Q, + (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l). + Proof. + intros l P i Q;unfold mkPX. + destruct P;try (simpl;rrefl). + assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl. + rewrite (H (refl_equal true));rewrite (morph0 CRmorph). + rewrite mkPinj_ok;rsimpl;simpl;rrefl. + assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl. + rewrite (H (refl_equal true));trivial. + rewrite Pphi0. rewrite pow_pos_Pplus;rsimpl. + Qed. + + Ltac Esimpl := + repeat (progress ( + match goal with + | |- context [?P@?l] => + match P with + | P0 => rewrite (Pphi0 l) + | P1 => rewrite (Pphi1 l) + | (mkPinj ?j ?P) => rewrite (mkPinj_ok j l P) + | (mkPX ?P ?i ?Q) => rewrite (mkPX_ok l P i Q) + end + | |- context [[?c]] => + match c with + | cO => rewrite (morph0 CRmorph) + | cI => rewrite (morph1 CRmorph) + | ?x +! ?y => rewrite ((morph_add CRmorph) x y) + | ?x *! ?y => rewrite ((morph_mul CRmorph) x y) + | ?x -! ?y => rewrite ((morph_sub CRmorph) x y) + | -! ?x => rewrite ((morph_opp CRmorph) x) + end + end)); + rsimpl; simpl. + + Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c]. + Proof. + induction P;simpl;intros;Esimpl;trivial. + rewrite IHP2;rsimpl. + Qed. + + Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c]. + Proof. + induction P;simpl;intros. + Esimpl. + rewrite IHP;rsimpl. + rewrite IHP2;rsimpl. + Qed. + + Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. + Proof. + induction P;simpl;intros;Esimpl;trivial. + rewrite IHP1;rewrite IHP2;rsimpl. + mul_push ([c]);rrefl. + Qed. + + Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. + Proof. + intros c P l; unfold PmulC. + assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO). + rewrite (H (refl_equal true));Esimpl. + assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). + rewrite (H1 (refl_equal true));Esimpl. + apply PmulC_aux_ok. + Qed. + + Lemma Popp_ok : forall P l, (--P)@l == - P@l. + Proof. + induction P;simpl;intros. + Esimpl. + apply IHP. + rewrite IHP1;rewrite IHP2;rsimpl. + Qed. + + Ltac Esimpl2 := + Esimpl; + repeat (progress ( + match goal with + | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l) + | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l) + | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) + | |- context [(--?P)@?l] => rewrite (Popp_ok P l) + end)); Esimpl. + + Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l. + Proof. + induction P';simpl;intros;Esimpl2. + generalize P p l;clear P p l. + induction P;simpl;intros. + Esimpl2;apply (ARadd_comm ARth). + assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). + rewrite H;Esimpl. rewrite IHP';rrefl. + rewrite H;Esimpl. rewrite IHP';Esimpl. + rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. + rewrite H;Esimpl. rewrite IHP. + rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. + destruct p0;simpl. + rewrite IHP2;simpl;rsimpl. + rewrite IHP2;simpl. + rewrite jump_Pdouble_minus_one;rsimpl. + rewrite IHP';rsimpl. + destruct P;simpl. + Esimpl2;add_push [c];rrefl. + destruct p0;simpl;Esimpl2. + rewrite IHP'2;simpl. + rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. + rewrite IHP'2;simpl. + rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. + rewrite IHP'2;rsimpl. add_push (P @ (tail l));rrefl. + assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. + rewrite IHP'1;rewrite IHP'2;rsimpl. + add_push (P3 @ (tail l));rewrite H;rrefl. + rewrite IHP'1;rewrite IHP'2;simpl;Esimpl. + rewrite H;rewrite Pplus_comm. + rewrite pow_pos_Pplus;rsimpl. + add_push (P3 @ (tail l));rrefl. + assert (forall P k l, + (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k). + induction P;simpl;intros;try apply (ARadd_comm ARth). + destruct p2;simpl;try apply (ARadd_comm ARth). + rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth). + assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2. + rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl. + rewrite IHP'1;simpl;Esimpl. + rewrite H1;rewrite Pplus_comm. + rewrite pow_pos_Pplus;simpl;Esimpl. + add_push (P5 @ (tail l0));rrefl. + rewrite IHP1;rewrite H1;rewrite Pplus_comm. + rewrite pow_pos_Pplus;simpl;rsimpl. + add_push (P5 @ (tail l0));rrefl. + rewrite H0;rsimpl. + add_push (P3 @ (tail l)). + rewrite H;rewrite Pplus_comm. + rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl. + add_push (P3 @ (tail l));rrefl. + Qed. + + Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. + Proof. + induction P';simpl;intros;Esimpl2;trivial. + generalize P p l;clear P p l. + induction P;simpl;intros. + Esimpl2;apply (ARadd_comm ARth). + assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). + rewrite H;Esimpl. rewrite IHP';rsimpl. + rewrite H;Esimpl. rewrite IHP';Esimpl. + rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. + rewrite H;Esimpl. rewrite IHP. + rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. + destruct p0;simpl. + rewrite IHP2;simpl;rsimpl. + rewrite IHP2;simpl. + rewrite jump_Pdouble_minus_one;rsimpl. + rewrite IHP';rsimpl. + destruct P;simpl. + repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl. + destruct p0;simpl;Esimpl2. + rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial. + add_push (P @ (jump p0 (jump p0 (tail l))));rrefl. + rewrite IHP'2;simpl;rewrite jump_Pdouble_minus_one;rsimpl. + add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl. + rewrite IHP'2;rsimpl;add_push (P @ (tail l));rrefl. + assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. + rewrite IHP'1; rewrite IHP'2;rsimpl. + add_push (P3 @ (tail l));rewrite H;rrefl. + rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl. + rewrite H;rewrite Pplus_comm. + rewrite pow_pos_Pplus;rsimpl. + add_push (P3 @ (tail l));rrefl. + assert (forall P k l, + (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k). + induction P;simpl;intros. + rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial. + destruct p2;simpl;rewrite Popp_ok;rsimpl. + apply (ARadd_comm ARth);trivial. + rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth);trivial. + apply (ARadd_comm ARth);trivial. + assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl. + rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl. + rewrite IHP'1;rewrite H1;rewrite Pplus_comm. + rewrite pow_pos_Pplus;simpl;Esimpl. + add_push (P5 @ (tail l0));rrefl. + rewrite IHP1;rewrite H1;rewrite Pplus_comm. + rewrite pow_pos_Pplus;simpl;rsimpl. + add_push (P5 @ (tail l0));rrefl. + rewrite H0;rsimpl. + rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)). + rewrite H;rewrite Pplus_comm. + rewrite pow_pos_Pplus;rsimpl. + Qed. +(* Proof for the symmetriv version *) + + Lemma PmulI_ok : + forall P', + (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) -> + forall (P : Pol) (p : positive) (l : list R), + (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). + Proof. + induction P;simpl;intros. + Esimpl2;apply (ARmul_comm ARth). + assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. + rewrite H1; rewrite H;rrefl. + rewrite H1; rewrite H. + rewrite Pplus_comm. + rewrite jump_Pplus;simpl;rrefl. + rewrite H1;rewrite Pplus_comm. + rewrite jump_Pplus;rewrite IHP;rrefl. + destruct p0;Esimpl2. + rewrite IHP1;rewrite IHP2;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p);rrefl. + rewrite IHP1;rewrite IHP2;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. + rewrite IHP1;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p). + rewrite H;rrefl. + Qed. + +(* + Lemma PmulI_ok : + forall P', + (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) -> + forall (P : Pol) (p : positive) (l : list R), + (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l). + Proof. + induction P;simpl;intros. + Esimpl2;apply (ARmul_comm ARth). + assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. + rewrite H1; rewrite H;rrefl. + rewrite H1; rewrite H. + rewrite Pplus_comm. + rewrite jump_Pplus;simpl;rrefl. + rewrite H1;rewrite Pplus_comm. + rewrite jump_Pplus;rewrite IHP;rrefl. + destruct p0;Esimpl2. + rewrite IHP1;rewrite IHP2;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p);rrefl. + rewrite IHP1;rewrite IHP2;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. + rewrite IHP1;simpl;rsimpl. + mul_push (pow_pos rmul (hd 0 l) p). + rewrite H;rrefl. + Qed. + + Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l. + Proof. + induction P';simpl;intros. + Esimpl2;trivial. + apply PmulI_ok;trivial. + rewrite Padd_ok;Esimpl2. + rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl. + Qed. +*) + +(* Proof for the symmetric version *) + Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. + Proof. + intros P P';generalize P;clear P;induction P';simpl;intros. + apply PmulC_ok. apply PmulI_ok;trivial. + destruct P. + rewrite (ARmul_comm ARth);Esimpl2;Esimpl2. + Esimpl2. rewrite IHP'1;Esimpl2. + assert (match p0 with + | xI j => Pinj (xO j) P ** P'2 + | xO j => Pinj (Pdouble_minus_one j) P ** P'2 + | 1 => P ** P'2 + end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)). + destruct p0;simpl;rewrite IHP'2;Esimpl. + rewrite jump_Pdouble_minus_one;Esimpl. + rewrite H;Esimpl. + rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2. + repeat (rewrite IHP'1 || rewrite IHP'2);simpl. + rewrite PmulI_ok;trivial. + mul_push (P'1@l). simpl. mul_push (P'2 @ (tail l)). Esimpl. + Qed. + +(* +Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. + Proof. + destruct P;simpl;intros. + Esimpl2;apply (ARmul_comm ARth). + rewrite (PmulI_ok P (Pmul_aux_ok P)). + apply (ARmul_comm ARth). + rewrite Padd_ok; Esimpl2. + rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial. + rewrite Pmul_aux_ok;mul_push (P' @ l). + rewrite (ARmul_comm ARth (P' @ l));rrefl. + Qed. +*) + + Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. + Proof. + induction P;simpl;intros;Esimpl2. + apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2. + rewrite IHP1;rewrite IHP2. + mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l). + rrefl. + Qed. + + + Lemma mkZmon_ok: forall M j l, + Mphi l (mkZmon j M) == Mphi l (zmon j M). + intros M j l; case M; simpl; intros; rsimpl. + Qed. + + Lemma zmon_pred_ok : forall M j l, + Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M). + Proof. + destruct j; simpl;intros auto; rsimpl. + rewrite mkZmon_ok;rsimpl. + rewrite mkZmon_ok;simpl. rewrite jump_Pdouble_minus_one; rsimpl. + Qed. + + Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i. + Proof. + destruct M;simpl;intros;rsimpl. + rewrite zmon_pred_ok;simpl;rsimpl. + rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl. + Qed. + + Lemma Mcphi_ok: forall P c l, + let (Q,R) := CFactor P c in + P@l == Q@l + (phi c) * (R@l). + Proof. + intros P; elim P; simpl; auto; clear P. + intros c c1 l; generalize (div_th.(div_eucl_th) c c1); case cdiv. + intros q r H; rewrite H. + Esimpl. + rewrite (ARadd_comm ARth); rsimpl. + intros i P Hrec c l. + generalize (Hrec c (jump i l)); case CFactor. + intros R1 S1; Esimpl; auto. + intros Q1 Qrec i R1 Rrec c l. + generalize (Qrec c l); case CFactor; intros S1 S2 HS. + generalize (Rrec c (tail l)); case CFactor; intros S3 S4 HS1. + rewrite HS; rewrite HS1; Esimpl. + apply (Radd_ext Reqe); rsimpl. + repeat rewrite <- (ARadd_assoc ARth). + apply (Radd_ext Reqe); rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + Qed. + + Lemma Mphi_ok: forall P (cM: C * Mon) l, + let (c,M) := cM in + let (Q,R) := MFactor P c M in + P@l == Q@l + (phi c) * (Mphi l M) * (R@l). + Proof. + intros P; elim P; simpl; auto; clear P. + intros c (c1, M) l; case M; simpl; auto. + assert (H1:= morph_eq CRmorph c1 cI);destruct (c1 ?=! cI). + rewrite (H1 (refl_equal true));Esimpl. + try rewrite (morph0 CRmorph); rsimpl. + generalize (div_th.(div_eucl_th) c c1); case (cdiv c c1). + intros q r H; rewrite H; clear H H1. + Esimpl. + rewrite (ARadd_comm ARth); rsimpl. + intros p m; Esimpl. + intros p m; Esimpl. + intros i P Hrec (c,M) l; case M; simpl; clear M. + assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). + rewrite (H1 (refl_equal true));Esimpl. + Esimpl. + generalize (Mcphi_ok P c (jump i l)); case CFactor. + intros R1 Q1 HH; rewrite HH; Esimpl. + intros j M. + case_eq ((i ?= j) Eq); intros He; simpl. + rewrite (Pcompare_Eq_eq _ _ He). + generalize (Hrec (c, M) (jump j l)); case (MFactor P c M); + simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. + generalize (Hrec (c, (zmon (j -i) M)) (jump i l)); + case (MFactor P c (zmon (j -i) M)); simpl. + intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. + rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)). + rewrite Pplus_comm; rewrite jump_Pplus; auto. + rewrite (morph0 CRmorph); rsimpl. + intros P2 m; rewrite (morph0 CRmorph); rsimpl. + + intros P2 Hrec1 i Q2 Hrec2 (c, M) l; case M; simpl; auto. + assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). + rewrite (H1 (refl_equal true));Esimpl. + Esimpl. + generalize (Mcphi_ok P2 c l); case CFactor. + intros S1 S2 HS. + generalize (Mcphi_ok Q2 c (tail l)); case CFactor. + intros S3 S4 HS1; Esimpl; rewrite HS; rewrite HS1. + rsimpl. + apply (Radd_ext Reqe); rsimpl. + repeat rewrite <- (ARadd_assoc ARth). + apply (Radd_ext Reqe); rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + intros j M1. + generalize (Hrec1 (c,zmon j M1) l); + case (MFactor P2 c (zmon j M1)). + intros R1 S1 H1. + generalize (Hrec2 (c, zmon_pred j M1) (List.tail l)); + case (MFactor Q2 c (zmon_pred j M1)); simpl. + intros R2 S2 H2; rewrite H1; rewrite H2. + repeat rewrite mkPX_ok; simpl. + rsimpl. + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + rewrite zmon_pred_ok;rsimpl. + intros j M1. + case_eq ((i ?= j) Eq); intros He; simpl. + rewrite (Pcompare_Eq_eq _ _ He). + generalize (Hrec1 (c, mkZmon xH M1) l); case (MFactor P2 c (mkZmon xH M1)); + simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. + rewrite H; rewrite mkPX_ok; rsimpl. + repeat (rewrite <-(ARadd_assoc ARth)). + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + rewrite mkZmon_ok. + apply rmul_ext; rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + generalize (Hrec1 (c, vmon (j - i) M1) l); + case (MFactor P2 c (vmon (j - i) M1)); + simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. + rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto. + rewrite mkPX_ok; rsimpl. + repeat (rewrite <-(ARadd_assoc ARth)). + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + apply rmul_ext; rsimpl. + rewrite <- (ARmul_comm ARth (Mphi (tail l) M1)); rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + apply rmul_ext; rsimpl. + rewrite <- pow_pos_Pplus. + rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. + generalize (Hrec1 (c, mkZmon 1 M1) l); + case (MFactor P2 c (mkZmon 1 M1)); + simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. + rewrite H; rsimpl. + rewrite mkPX_ok; rsimpl. + repeat (rewrite <-(ARadd_assoc ARth)). + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + rewrite mkZmon_ok. + repeat (rewrite <-(ARmul_assoc ARth)). + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + rewrite mkPX_ok; simpl; rsimpl. + rewrite (morph0 CRmorph); rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + rewrite (ARmul_comm ARth (Q3@l)); rsimpl. + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + repeat (rewrite <- (ARmul_assoc ARth)). + apply rmul_ext; rsimpl. + rewrite <- pow_pos_Pplus. + rewrite (Pplus_minus _ _ He); rsimpl. + Qed. + +(* Proof for the symmetric version *) + + Lemma POneSubst_ok: forall P1 M1 P2 P3 l, + POneSubst P1 M1 P2 = Some P3 -> phi (fst M1) * Mphi l (snd M1) == P2@l -> P1@l == P3@l. + Proof. + intros P2 (cc,M1) P3 P4 l; unfold POneSubst. + generalize (Mphi_ok P2 (cc, M1) l); case (MFactor P2 cc M1); simpl; auto. + intros Q1 R1; case R1. + intros c H; rewrite H. + generalize (morph_eq CRmorph c cO); + case (c ?=! cO); simpl; auto. + intros H1 H2; rewrite H1; auto; rsimpl. + discriminate. + intros _ H1 H2; injection H1; intros; subst. + rewrite H2; rsimpl. + (* new version *) + rewrite Padd_ok; rewrite PmulC_ok; rsimpl. + intros i P5 H; rewrite H. + intros HH H1; injection HH; intros; subst; rsimpl. + rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. + intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. + assert (P4 = Q1 ++ P3 ** PX i P5 P6). + injection H2; intros; subst;trivial. + rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl. + Qed. +(* + Lemma POneSubst_ok: forall P1 M1 P2 P3 l, + POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. +Proof. + intros P2 M1 P3 P4 l; unfold POneSubst. + generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. + intros Q1 R1; case R1. + intros c H; rewrite H. + generalize (morph_eq CRmorph c cO); + case (c ?=! cO); simpl; auto. + intros H1 H2; rewrite H1; auto; rsimpl. + discriminate. + intros _ H1 H2; injection H1; intros; subst. + rewrite H2; rsimpl. + rewrite Padd_ok; rewrite Pmul_ok; rsimpl. + intros i P5 H; rewrite H. + intros HH H1; injection HH; intros; subst; rsimpl. + rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl. + intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. + injection H2; intros; subst; rsimpl. + rewrite Padd_ok. + rewrite Pmul_ok; rsimpl. + Qed. +*) + Lemma PNSubst1_ok: forall n P1 M1 P2 l, + [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. + Proof. + intros n; elim n; simpl; auto. + intros P2 M1 P3 l H. + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. + intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl. + intros n1 Hrec P2 M1 P3 l H. + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. + intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl. + Qed. + + Lemma PNSubst_ok: forall n P1 M1 P2 l P3, + PNSubst P1 M1 P2 n = Some P3 -> [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == P3@l. + Proof. + intros n P2 (cc, M1) P3 l P4; unfold PNSubst. + generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l); + case (POneSubst P2 (cc,M1) P3); [idtac | intros; discriminate]. + intros P5 H1; case n; try (intros; discriminate). + intros n1 H2; injection H2; intros; subst. + rewrite <- PNSubst1_ok; auto. + Qed. + + Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop := + match LM1 with + cons (M1,P2) LM2 => ([fst M1] * Mphi l (snd M1) == P2@l) /\ (MPcond LM2 l) + | _ => True + end. + + Lemma PSubstL1_ok: forall n LM1 P1 l, + MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. + Proof. + intros n LM1; elim LM1; simpl; auto. + intros; rsimpl. + intros (M2,P2) LM2 Hrec P3 l [H H1]. + rewrite <- Hrec; auto. + apply PNSubst1_ok; auto. + Qed. + + Lemma PSubstL_ok: forall n LM1 P1 P2 l, + PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. + Proof. + intros n LM1; elim LM1; simpl; auto. + intros; discriminate. + intros (M2,P2) LM2 Hrec P3 P4 l. + generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n). + intros P5 H0 H1 [H2 H3]; injection H1; intros; subst. + rewrite <- PSubstL1_ok; auto. + intros l1 H [H1 H2]; auto. + Qed. + + Lemma PNSubstL_ok: forall m n LM1 P1 l, + MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. + Proof. + intros m; elim m; simpl; auto. + intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); + case (PSubstL P2 LM1 n); intros; rsimpl; auto. + intros m1 Hrec n LM1 P2 l H. + generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); + case (PSubstL P2 LM1 n); intros; rsimpl; auto. + rewrite <- Hrec; auto. + Qed. + + (** Definition of polynomial expressions *) + + Inductive PExpr : Type := + | PEc : C -> PExpr + | PEX : positive -> PExpr + | PEadd : PExpr -> PExpr -> PExpr + | PEsub : PExpr -> PExpr -> PExpr + | PEmul : PExpr -> PExpr -> PExpr + | PEopp : PExpr -> PExpr + | PEpow : PExpr -> N -> PExpr. + + (** evaluation of polynomial expressions towards R *) + Definition mk_X j := mkPinj_pred j mkX. + + (** evaluation of polynomial expressions towards R *) + + Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R := + match pe with + | PEc c => phi c + | PEX j => nth 0 j l + | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) + | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) + | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) + | PEopp pe1 => - (PEeval l pe1) + | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) + end. + +Strategy expand [PEeval]. + + (** Correctness proofs *) + + Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l. + Proof. + destruct p;simpl;intros;Esimpl;trivial. + rewrite <-jump_tl;rewrite nth_jump;rrefl. + rewrite <- nth_jump. + rewrite nth_Pdouble_minus_one;rrefl. + Qed. + + Ltac Esimpl3 := + repeat match goal with + | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l) + | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l) + end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). + +(* Power using the chinise algorithm *) +(*Section POWER. + Variable subst_l : Pol -> Pol. + Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol := + match p with + | xH => P + | xO p => subst_l (Psquare (Ppow_pos P p)) + | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p))) + end. + + Definition Ppow_N P n := + match n with + | N0 => P1 + | Npos p => Ppow_pos P p + end. + + Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l. + Proof. + intros l subst_l_ok P. + induction p;simpl;intros;try rrefl;try rewrite subst_l_ok. + repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. + repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. + Qed. + + Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. + Proof. destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial. Qed. + + End POWER. *) + +Section POWER. + Variable subst_l : Pol -> Pol. + Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := + match p with + | xH => subst_l (Pmul res P) + | xO p => Ppow_pos (Ppow_pos res P p) P p + | xI p => subst_l (Pmul (Ppow_pos (Ppow_pos res P p) P p) P) + end. + + Definition Ppow_N P n := + match n with + | N0 => P1 + | Npos p => Ppow_pos P1 P p + end. + + Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. + Proof. + intros l subst_l_ok res P p. generalize res;clear res. + induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp. + rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl. + Qed. + + Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. + Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok by trivial. Esimpl. Qed. + + End POWER. + + (** Normalization and rewriting *) + + Section NORM_SUBST_REC. + Variable n : nat. + Variable lmp:list (C*Mon*Pol). + Let subst_l P := PNSubstL P lmp n n. + Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). + Let Ppow_subst := Ppow_N subst_l. + + Fixpoint norm_aux (pe:PExpr) : Pol := + match pe with + | PEc c => Pc c + | PEX j => mk_X j + | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1) + | PEadd pe1 (PEopp pe2) => + Psub (norm_aux pe1) (norm_aux pe2) + | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) + | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) + | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) + | PEopp pe1 => Popp (norm_aux pe1) + | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n + end. + + Definition norm_subst pe := subst_l (norm_aux pe). + + (* + Fixpoint norm_subst (pe:PExpr) : Pol := + match pe with + | PEc c => Pc c + | PEX j => subst_l (mk_X j) + | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1) + | PEadd pe1 (PEopp pe2) => + Psub (norm_subst pe1) (norm_subst pe2) + | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2) + | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2) + | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) + | PEopp pe1 => Popp (norm_subst pe1) + | PEpow pe1 n => Ppow_subst (norm_subst pe1) n + end. + + Lemma norm_subst_spec : + forall l pe, MPcond lmp l -> + PEeval l pe == (norm_subst pe)@l. + Proof. + intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). + unfold subst_l;intros. + rewrite <- PNSubstL_ok;trivial. rrefl. + assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l). + intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl. + induction pe;simpl;Esimpl3. + rewrite subst_l_ok;apply mkX_ok. + rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. + rewrite IHpe1;rewrite IHpe2;rrefl. + rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl. + rewrite IHpe;rrefl. + unfold Ppow_subst. rewrite Ppow_N_ok. trivial. + rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. + induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; + repeat rewrite Pmul_ok;rrefl. + Qed. +*) + Lemma norm_aux_spec : + forall l pe, MPcond lmp l -> + PEeval l pe == (norm_aux pe)@l. + Proof. + intros. + induction pe;simpl;Esimpl3. + apply mkX_ok. + rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. + rewrite IHpe1;rewrite IHpe2;rrefl. + rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl. + rewrite IHpe;rrefl. + rewrite Ppow_N_ok by (intros;rrefl). + rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. + induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; + repeat rewrite Pmul_ok;rrefl. + Qed. + + Lemma norm_subst_spec : + forall l pe, MPcond lmp l -> + PEeval l pe == (norm_subst pe)@l. + Proof. + intros;unfold norm_subst. + unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. trivial. + Qed. + + End NORM_SUBST_REC. + + Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop := + match lpe with + | nil => True + | (me,pe)::lpe => + match lpe with + | nil => PEeval l me == PEeval l pe + | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe + end + end. + + Fixpoint mon_of_pol (P:Pol) : option (C * Mon) := + match P with + | Pc c => if (c ?=! cO) then None else Some (c, mon0) + | Pinj j P => + match mon_of_pol P with + | None => None + | Some (c,m) => Some (c, mkZmon j m) + end + | PX P i Q => + if Peq Q P0 then + match mon_of_pol P with + | None => None + | Some (c,m) => Some (c, mkVmon i m) + end + else None + end. + + Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (C*Mon*Pol) := + match lpe with + | nil => nil + | (me,pe)::lpe => + match mon_of_pol (norm_subst 0 nil me) with + | None => mk_monpol_list lpe + | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe + end + end. + + Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m -> + forall l, [fst m] * Mphi l (snd m) == P@l. + Proof. + induction P;simpl;intros;Esimpl. + assert (H1 := (morph_eq CRmorph) c cO). + destruct (c ?=! cO). + discriminate. + inversion H;trivial;Esimpl. + generalize H;clear H;case_eq (mon_of_pol P). + intros (c1,P2) H0 H1; inversion H1; Esimpl. + generalize (IHP (c1, P2) H0 (jump p l)). + rewrite mkZmon_ok;simpl;auto. + intros; discriminate. + generalize H;clear H;change match P3 with + | Pc c => c ?=! cO + | Pinj _ _ => false + | PX _ _ _ => false + end with (P3 ?== P0). + assert (H := Peq_ok P3 P0). + destruct (P3 ?== P0). + case_eq (mon_of_pol P2);try intros (cc, pp); intros. + inversion H1. + simpl. + rewrite mkVmon_ok;simpl. + rewrite H;trivial;Esimpl. + generalize (IHP1 _ H0); simpl; intros HH; rewrite HH; rsimpl. + discriminate. + intros;discriminate. + Qed. + + Lemma interp_PElist_ok : forall l lpe, + interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l. + Proof. + induction lpe;simpl. trivial. + destruct a;simpl;intros. + assert (HH:=mon_of_pol_ok (norm_subst 0 nil p)); + destruct (mon_of_pol (norm_subst 0 nil p)). + split. + rewrite <- norm_subst_spec by exact I. + destruct lpe;try destruct H;rewrite <- H; + rewrite (norm_subst_spec 0 nil); try exact I;apply HH;trivial. + apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. + apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. + Qed. + + Lemma norm_subst_ok : forall n l lpe pe, + interp_PElist l lpe -> + PEeval l pe == (norm_subst n (mk_monpol_list lpe) pe)@l. + Proof. + intros;apply norm_subst_spec. apply interp_PElist_ok;trivial. + Qed. + + Lemma ring_correct : forall n l lpe pe1 pe2, + interp_PElist l lpe -> + (let lmp := mk_monpol_list lpe in + norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true -> + PEeval l pe1 == PEeval l pe2. + Proof. + simpl;intros. + do 2 (rewrite (norm_subst_ok n l lpe);trivial). + apply Peq_ok;trivial. + Qed. + + + + (** Generic evaluation of polynomial towards R avoiding parenthesis *) + Variable get_sign : C -> option C. + Variable get_sign_spec : sign_theory copp ceqb get_sign. + + + Section EVALUATION. + + (* [mkpow x p] = x^p *) + Variable mkpow : R -> positive -> R. + (* [mkpow x p] = -(x^p) *) + Variable mkopp_pow : R -> positive -> R. + (* [mkmult_pow r x p] = r * x^p *) + Variable mkmult_pow : R -> R -> positive -> R. + + Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R := + match lm with + | nil => r + | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t + end. + + Definition mkmult1 lm := + match lm with + | nil => 1 + | cons (x,p) t => mkmult_rec (mkpow x p) t + end. + + Definition mkmultm1 lm := + match lm with + | nil => ropp rI + | cons (x,p) t => mkmult_rec (mkopp_pow x p) t + end. + + Definition mkmult_c_pos c lm := + if c ?=! cI then mkmult1 (rev' lm) + else mkmult_rec [c] (rev' lm). + + Definition mkmult_c c lm := + match get_sign c with + | None => mkmult_c_pos c lm + | Some c' => + if c' ?=! cI then mkmultm1 (rev' lm) + else mkmult_rec [c] (rev' lm) + end. + + Definition mkadd_mult rP c lm := + match get_sign c with + | None => rP + mkmult_c_pos c lm + | Some c' => rP - mkmult_c_pos c' lm + end. + + Definition add_pow_list (r:R) n l := + match n with + | N0 => l + | Npos p => (r,p)::l + end. + + Fixpoint add_mult_dev + (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R := + match P with + | Pc c => + let lm := add_pow_list (hd 0 fv) n lm in + mkadd_mult rP c lm + | Pinj j Q => + add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) + | PX P i Q => + let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in + if Q ?== P0 then rP + else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 fv) n lm) + end. + + Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) + (lm:list (R*positive)) {struct P} : R := + (* P@l * (hd 0 l)^n * lm *) + match P with + | Pc c => mkmult_c c (add_pow_list (hd 0 fv) n lm) + | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) + | PX P i Q => + let rP := mult_dev P fv (Nplus (Npos i) n) lm in + if Q ?== P0 then rP + else + let lmq := add_pow_list (hd 0 fv) n lm in + add_mult_dev rP Q (tail fv) N0 lmq + end. + + Definition Pphi_avoid fv P := mult_dev P fv N0 nil. + + Fixpoint r_list_pow (l:list (R*positive)) : R := + match l with + | nil => rI + | cons (r,p) l => pow_pos rmul r p * r_list_pow l + end. + + Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p. + Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). + Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p. + + Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm. + Proof. + induction lm;intros;simpl;Esimpl. + destruct a as (x,p);Esimpl. + rewrite IHlm. rewrite mkmult_pow_spec. Esimpl. + Qed. + + Lemma mkmult1_ok : forall lm, mkmult1 lm == r_list_pow lm. + Proof. + destruct lm;simpl;Esimpl. + destruct p. rewrite mkmult_rec_ok;rewrite mkpow_spec;Esimpl. + Qed. + + Lemma mkmultm1_ok : forall lm, mkmultm1 lm == - r_list_pow lm. + Proof. + destruct lm;simpl;Esimpl. + destruct p;rewrite mkmult_rec_ok. rewrite mkopp_pow_spec;Esimpl. + Qed. + + Lemma r_list_pow_rev : forall l, r_list_pow (rev' l) == r_list_pow l. + Proof. + assert + (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l). + induction l;intros;simpl;Esimpl. + destruct a;rewrite IHl;Esimpl. + rewrite (ARmul_comm ARth (pow_pos rmul r p)). rrefl. + intros;unfold rev'. rewrite H;simpl;Esimpl. + Qed. + + Lemma mkmult_c_pos_ok : forall c lm, mkmult_c_pos c lm == [c]* r_list_pow lm. + Proof. + intros;unfold mkmult_c_pos;simpl. + assert (H := (morph_eq CRmorph) c cI). + rewrite <- r_list_pow_rev; destruct (c ?=! cI). + rewrite H;trivial;Esimpl. + apply mkmult1_ok. apply mkmult_rec_ok. + Qed. + + Lemma mkmult_c_ok : forall c lm, mkmult_c c lm == [c] * r_list_pow lm. + Proof. + intros;unfold mkmult_c;simpl. + case_eq (get_sign c);intros. + assert (H1 := (morph_eq CRmorph) c0 cI). + destruct (c0 ?=! cI). + rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H)). Esimpl. rewrite H1;trivial. + rewrite <- r_list_pow_rev;trivial;Esimpl. + apply mkmultm1_ok. + rewrite <- r_list_pow_rev; apply mkmult_rec_ok. + apply mkmult_c_pos_ok. +Qed. + + Lemma mkadd_mult_ok : forall rP c lm, mkadd_mult rP c lm == rP + [c]*r_list_pow lm. + Proof. + intros;unfold mkadd_mult. + case_eq (get_sign c);intros. + rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H));Esimpl. + rewrite mkmult_c_pos_ok;Esimpl. + rewrite mkmult_c_pos_ok;Esimpl. + Qed. + + Lemma add_pow_list_ok : + forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l. + Proof. + destruct n;simpl;intros;Esimpl. + Qed. + + Lemma add_mult_dev_ok : forall P rP fv n lm, + add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd 0 fv) n * r_list_pow lm. + Proof. + induction P;simpl;intros. + rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl. + rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl. + change (match P3 with + | Pc c => c ?=! cO + | Pinj _ _ => false + | PX _ _ _ => false + end) with (Peq P3 P0). + change match n with + | N0 => Npos p + | Npos q => Npos (p + q) + end with (Nplus (Npos p) n);trivial. + assert (H := Peq_ok P3 P0). + destruct (P3 ?== P0). + rewrite (H (refl_equal true)). + rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. + rewrite IHP2. + rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. + Qed. + + Lemma mult_dev_ok : forall P fv n lm, + mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 fv) n * r_list_pow lm. + Proof. + induction P;simpl;intros;Esimpl. + rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl. + rewrite IHP. simpl;rewrite add_pow_list_ok;Esimpl. + change (match P3 with + | Pc c => c ?=! cO + | Pinj _ _ => false + | PX _ _ _ => false + end) with (Peq P3 P0). + change match n with + | N0 => Npos p + | Npos q => Npos (p + q) + end with (Nplus (Npos p) n);trivial. + assert (H := Peq_ok P3 P0). + destruct (P3 ?== P0). + rewrite (H (refl_equal true)). + rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. + rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok. + destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. + Qed. + + Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P == P@fv. + Proof. + unfold Pphi_avoid;intros;rewrite mult_dev_ok;simpl;Esimpl. + Qed. + + End EVALUATION. + + Definition Pphi_pow := + let mkpow x p := + match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in + let mkopp_pow x p := ropp (mkpow x p) in + let mkmult_pow r x p := rmul r (mkpow x p) in + Pphi_avoid mkpow mkopp_pow mkmult_pow. + + Lemma local_mkpow_ok : + forall (r : R) (p : positive), + match p with + | xI _ => rpow r (Cp_phi (Npos p)) + | xO _ => rpow r (Cp_phi (Npos p)) + | 1 => r + end == pow_pos rmul r p. + Proof. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed. + + Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. + Proof. + unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl. + Qed. + + Lemma ring_rw_pow_correct : forall n lH l, + interp_PElist l lH -> + forall lmp, mk_monpol_list lH = lmp -> + forall pe npe, norm_subst n lmp pe = npe -> + PEeval l pe == Pphi_pow l npe. + Proof. + intros n lH l H1 lmp Heq1 pe npe Heq2. + rewrite Pphi_pow_ok. rewrite <- Heq2;rewrite <- Heq1. + apply norm_subst_ok. trivial. + Qed. + + Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := + match p with + | xH => r*x + | xO p => mkmult_pow (mkmult_pow r x p) x p + | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p + end. + + Definition mkpow x p := + match p with + | xH => x + | xO p => mkmult_pow x x (Pdouble_minus_one p) + | xI p => mkmult_pow x x (xO p) + end. + + Definition mkopp_pow x p := + match p with + | xH => -x + | xO p => mkmult_pow (-x) x (Pdouble_minus_one p) + | xI p => mkmult_pow (-x) x (xO p) + end. + + Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow. + + Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p. + Proof. + induction p;intros;simpl;Esimpl. + repeat rewrite IHp;Esimpl. + repeat rewrite IHp;Esimpl. + Qed. + + Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p. + Proof. + destruct p;simpl;intros;Esimpl. + repeat rewrite mkmult_pow_ok;Esimpl. + rewrite mkmult_pow_ok;Esimpl. + pattern x at 1;replace x with (pow_pos rmul x 1). + rewrite <- pow_pos_Pplus. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO. + simpl;Esimpl. + trivial. + Qed. + + Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p. + Proof. + destruct p;simpl;intros;Esimpl. + repeat rewrite mkmult_pow_ok;Esimpl. + rewrite mkmult_pow_ok;Esimpl. + pattern x at 1;replace x with (pow_pos rmul x 1). + rewrite <- pow_pos_Pplus. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO. + simpl;Esimpl. + trivial. + Qed. + + Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv. + Proof. + unfold Pphi_dev;intros;apply Pphi_avoid_ok. + intros;apply mkpow_ok. + intros;apply mkopp_pow_ok. + intros;apply mkmult_pow_ok. + Qed. + + Lemma ring_rw_correct : forall n lH l, + interp_PElist l lH -> + forall lmp, mk_monpol_list lH = lmp -> + forall pe npe, norm_subst n lmp pe = npe -> + PEeval l pe == Pphi_dev l npe. + Proof. + intros n lH l H1 lmp Heq1 pe npe Heq2. + rewrite Pphi_dev_ok. rewrite <- Heq2;rewrite <- Heq1. + apply norm_subst_ok. trivial. + Qed. + + +End MakeRingPol. + diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v new file mode 100644 index 00000000..d33e9a82 --- /dev/null +++ b/plugins/setoid_ring/Ring_tac.v @@ -0,0 +1,434 @@ +Set Implicit Arguments. +Require Import Setoid. +Require Import BinPos. +Require Import Ring_polynom. +Require Import BinList. +Require Import InitialRing. +Require Import Quote. +Declare ML Module "newring_plugin". + + +(* adds a definition t' on the normal form of t and an hypothesis id + stating that t = t' (tries to produces a proof as small as possible) *) +Ltac compute_assertion eqn t' t := + let nft := eval vm_compute in t in + pose (t' := nft); + assert (eqn : t = t'); + [vm_cast_no_check (refl_equal t')|idtac]. + +Ltac relation_carrier req := + let ty := type of req in + match eval hnf in ty with + ?R -> _ => R + | _ => fail 1000 "Equality has no relation type" + end. + +Ltac Get_goal := match goal with [|- ?G] => G end. + +(********************************************************************) +(* Tacticals to build reflexive tactics *) + +Ltac OnEquation req := + match goal with + | |- req ?lhs ?rhs => (fun f => f lhs rhs) + | _ => (fun _ => fail "Goal is not an equation (of expected equality)") + end. + +Ltac OnEquationHyp req h := + match type of h with + | req ?lhs ?rhs => fun f => f lhs rhs + | _ => (fun _ => fail "Hypothesis is not an equation (of expected equality)") + end. + +(* Note: auxiliary subgoals in reverse order *) +Ltac OnMainSubgoal H ty := + match ty with + | _ -> ?ty' => + let subtac := OnMainSubgoal H ty' in + fun kont => lapply H; [clear H; intro H; subtac kont | idtac] + | _ => (fun kont => kont()) + end. + +(* A generic pattern to have reflexive tactics do some computation: + lemmas of the form [forall x', x=x' -> P(x')] are understood as: + compute the normal form of x, instantiate x' with it, prove + hypothesis x=x' with vm_compute and reflexivity, and pass the + instantiated lemma to the continuation. + *) +Ltac ProveLemmaHyp lemma := + match type of lemma with + forall x', ?x = x' -> _ => + (fun kont => + let x' := fresh "res" in + let H := fresh "res_eq" in + compute_assertion H x' x; + let lemma' := constr:(lemma x' H) in + kont lemma'; + (clear H||idtac"ProveLemmaHyp: cleanup failed"); + subst x') + | _ => (fun _ => fail "ProveLemmaHyp: lemma not of the expected form") + end. + +Ltac ProveLemmaHyps lemma := + match type of lemma with + forall x', ?x = x' -> _ => + (fun kont => + let x' := fresh "res" in + let H := fresh "res_eq" in + compute_assertion H x' x; + let lemma' := constr:(lemma x' H) in + ProveLemmaHyps lemma' kont; + (clear H||idtac"ProveLemmaHyps: cleanup failed"); + subst x') + | _ => (fun kont => kont lemma) + end. + +(* +Ltac ProveLemmaHyps lemma := (* expects a continuation *) + let try_step := ProveLemmaHyp lemma in + (fun kont => + try_step ltac:(fun lemma' => ProveLemmaHyps lemma' kont) || + kont lemma). +*) +Ltac ApplyLemmaThen lemma expr kont := + let lem := constr:(lemma expr) in + ProveLemmaHyp lem ltac:(fun lem' => + let Heq := fresh "thm" in + assert (Heq:=lem'); + OnMainSubgoal Heq ltac:(type of Heq) ltac:(fun _ => kont Heq); + (clear Heq||idtac"ApplyLemmaThen: cleanup failed")). +(* +Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg := + let pe := + match type of (lemma expr) with + forall pe', ?pe = pe' -> _ => pe + | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression" + end in + let pe' := fresh "expr_nf" in + let nf_pe := fresh "pe_eq" in + compute_assertion nf_pe pe' pe; + let Heq := fresh "thm" in + (assert (Heq:=lemma pe pe' H) || fail "anomaly: failed to apply lemma"); + clear nf_pe; + OnMainSubgoal Heq ltac:(type of Heq) + ltac:(try tac Heq; clear Heq pe';CONT_tac cont_arg)). +*) +Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac := + ApplyLemmaThen lemma expr + ltac:(fun lemma' => try tac lemma'; CONT_tac()). + +(* General scheme of reflexive tactics using of correctness lemma + that involves normalisation of one expression + - [FV_tac term fv] is a tactic that adds the atomic expressions + of [term] into [fv] + - [SYN_tac term fv] reifies [term] given the list of atomic expressions + - [LEMMA_tac fv kont] computes the correctness lemma and passes it to + continuation kont + - [MAIN_tac H] process H which is the conclusion of the correctness lemma + instantiated with each reified term + - [fv] is the initial value of atomic expressions (to be completed by + the reification of the terms + - [terms] the list (a constr of type list) of terms to reify and process. + *) +Ltac ReflexiveRewriteTactic + FV_tac SYN_tac LEMMA_tac MAIN_tac fv terms := + (* extend the atom list *) + let fv := list_fold_left FV_tac fv terms in + let RW_tac lemma := + let fcons term CONT_tac := + let expr := SYN_tac term fv in + let main H := + match type of H with + | (?req _ ?rhs) => change (req term rhs) in H + end; + MAIN_tac H in + (ApplyLemmaThenAndCont lemma expr main CONT_tac) in + (* rewrite steps *) + lazy_list_fold_right fcons ltac:(fun _=>idtac) terms in + LEMMA_tac fv RW_tac. + +(********************************************************) + +Ltac FV_hypo_tac mkFV req lH := + let R := relation_carrier req in + let FV_hypo_l_tac h := + match h with @mkhypo (req ?pe _) _ => mkFV pe end in + let FV_hypo_r_tac h := + match h with @mkhypo (req _ ?pe) _ => mkFV pe end in + let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in + list_fold_right FV_hypo_r_tac fv lH. + +Ltac mkHyp_tac C req Reify lH := + let mkHyp h res := + match h with + | @mkhypo (req ?r1 ?r2) _ => + let pe1 := Reify r1 in + let pe2 := Reify r2 in + constr:(cons (pe1,pe2) res) + | _ => fail 1 "hypothesis is not a ring equality" + end in + list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH. + +Ltac proofHyp_tac lH := + let get_proof h := + match h with + | @mkhypo _ ?p => p + end in + let rec bh l := + match l with + | nil => constr:(I) + | cons ?h nil => get_proof h + | cons ?h ?tl => + let l := get_proof h in + let r := bh tl in + constr:(conj l r) + end in + bh lH. + +Ltac get_MonPol lemma := + match type of lemma with + | context [(mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _)] => + constr:(mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb) + | _ => fail 1 "ring/field anomaly: bad correctness lemma (get_MonPol)" + end. + +(********************************************************) + +(* Building the atom list of a ring expression *) +Ltac FV Cst CstPow add mul sub opp pow t fv := + let rec TFV t fv := + let f := + match Cst t with + | NotConstant => + match t with + | (add ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) + | (mul ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) + | (sub ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv) + | (opp ?t1) => fun _ => TFV t1 fv + | (pow ?t1 ?n) => + match CstPow n with + | InitialRing.NotConstant => fun _ => AddFvTail t fv + | _ => fun _ => TFV t1 fv + end + | _ => fun _ => AddFvTail t fv + end + | _ => fun _ => fv + end in + f() + in TFV t fv. + + (* syntaxification of ring expressions *) +Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := + let rec mkP t := + let f := + match Cst t with + | InitialRing.NotConstant => + match t with + | (radd ?t1 ?t2) => + fun _ => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(PEadd e1 e2) + | (rmul ?t1 ?t2) => + fun _ => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(PEmul e1 e2) + | (rsub ?t1 ?t2) => + fun _ => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(PEsub e1 e2) + | (ropp ?t1) => + fun _ => + let e1 := mkP t1 in constr:(PEopp e1) + | (rpow ?t1 ?n) => + match CstPow n with + | InitialRing.NotConstant => + fun _ => let p := Find_at t fv in constr:(PEX C p) + | ?c => fun _ => let e1 := mkP t1 in constr:(PEpow e1 c) + end + | _ => + fun _ => let p := Find_at t fv in constr:(PEX C p) + end + | ?c => fun _ => constr:(@PEc C c) + end in + f () + in mkP t. + +(* packaging the ring structure *) + +Ltac PackRing F req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post := + let RNG := + match type of lemma1 with + | context + [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] => + (fun proj => proj + cst_tac pow_tac pre post + R req add mul sub opp C Cpow powphi pow lemma1 lemma2) + | _ => fail 1 "field anomaly: bad correctness lemma (parse)" + end in + F RNG. + +Ltac get_Carrier RNG := + RNG ltac:(fun cst_tac pow_tac pre post + R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => + R). + +Ltac get_Eq RNG := + RNG ltac:(fun cst_tac pow_tac pre post + R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => + req). + +Ltac get_Pre RNG := + RNG ltac:(fun cst_tac pow_tac pre post + R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => + pre). + +Ltac get_Post RNG := + RNG ltac:(fun cst_tac pow_tac pre post + R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => + post). + +Ltac get_NormLemma RNG := + RNG ltac:(fun cst_tac pow_tac pre post + R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => + lemma1). + +Ltac get_SimplifyLemma RNG := + RNG ltac:(fun cst_tac pow_tac pre post + R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => + lemma2). + +Ltac get_RingFV RNG := + RNG ltac:(fun cst_tac pow_tac pre post + R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => + FV cst_tac pow_tac add mul sub opp pow). + +Ltac get_RingMeta RNG := + RNG ltac:(fun cst_tac pow_tac pre post + R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => + mkPolexpr C cst_tac pow_tac add mul sub opp pow). + +Ltac get_RingHypTac RNG := + RNG ltac:(fun cst_tac pow_tac pre post + R req add mul sub opp C Cpow powphi pow lemma1 lemma2 => + let mkPol := mkPolexpr C cst_tac pow_tac add mul sub opp pow in + fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH). + +(* ring tactics *) + +Definition ring_subst_niter := (10*10*10)%nat. + +Ltac Ring RNG lemma lH := + let req := get_Eq RNG in + OnEquation req ltac:(fun lhs rhs => + let mkFV := get_RingFV RNG in + let mkPol := get_RingMeta RNG in + let mkHyp := get_RingHypTac RNG in + let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in + let fv := mkFV lhs fv in + let fv := mkFV rhs fv in + check_fv fv; + let pe1 := mkPol lhs fv in + let pe2 := mkPol rhs fv in + let lpe := mkHyp fv lH in + let vlpe := fresh "hyp_list" in + let vfv := fresh "fv_list" in + pose (vlpe := lpe); + pose (vfv := fv); + (apply (lemma vfv vlpe pe1 pe2) + || fail "typing error while applying ring"); + [ ((let prh := proofHyp_tac lH in exact prh) + || idtac "can not automatically proof hypothesis :"; + idtac " maybe a left member of a hypothesis is not a monomial") + | vm_compute; + (exact (refl_equal true) || fail "not a valid ring equation")]). + +Ltac Ring_norm_gen f RNG lemma lH rl := + let mkFV := get_RingFV RNG in + let mkPol := get_RingMeta RNG in + let mkHyp := get_RingHypTac RNG in + let mk_monpol := get_MonPol lemma in + let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in + let lemma_tac fv kont := + let lpe := mkHyp fv lH in + let vlpe := fresh "list_hyp" in + let vlmp := fresh "list_hyp_norm" in + let vlmp_eq := fresh "list_hyp_norm_eq" in + let prh := proofHyp_tac lH in + pose (vlpe := lpe); + compute_assertion vlmp_eq vlmp (mk_monpol vlpe); + let H := fresh "ring_lemma" in + (assert (H := lemma vlpe fv prh vlmp vlmp_eq) + || fail "type error when build the rewriting lemma"); + clear vlmp_eq; + kont H; + (clear H||idtac"Ring_norm_gen: cleanup failed"); + subst vlpe vlmp in + let simpl_ring H := (protect_fv "ring" in H; f H) in + ReflexiveRewriteTactic mkFV mkPol lemma_tac simpl_ring fv rl. + +Ltac Ring_gen RNG lH rl := + let lemma := get_NormLemma RNG in + get_Pre RNG (); + Ring RNG (lemma ring_subst_niter) lH. + +Tactic Notation (at level 0) "ring" := + let G := Get_goal in + ring_lookup (PackRing Ring_gen) [] G. + +Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" := + let G := Get_goal in + ring_lookup (PackRing Ring_gen) [lH] G. + +(* Simplification *) + +Ltac Ring_simplify_gen f RNG lH rl := + let lemma := get_SimplifyLemma RNG in + let l := fresh "to_rewrite" in + pose (l:= rl); + generalize (refl_equal l); + unfold l at 2; + get_Pre RNG (); + let rl := + match goal with + | [|- l = ?RL -> _ ] => RL + | _ => fail 1 "ring_simplify anomaly: bad goal after pre" + end in + let Heq := fresh "Heq" in + intros Heq;clear Heq l; + Ring_norm_gen f RNG (lemma ring_subst_niter) lH rl; + get_Post RNG (). + +Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H). + +Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := + let G := Get_goal in + ring_lookup (PackRing Ring_simplify) [] rl G. + +Tactic Notation (at level 0) + "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := + let G := Get_goal in + ring_lookup (PackRing Ring_simplify) [lH] rl G. + +(* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *) + +Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= + let G := Get_goal in + let t := type of H in + let g := fresh "goal" in + set (g:= G); + generalize H;clear H; + ring_lookup (PackRing Ring_simplify) [] rl t; + intro H; + unfold g;clear g. + +Tactic Notation + "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):= + let G := Get_goal in + let t := type of H in + let g := fresh "goal" in + set (g:= G); + generalize H;clear H; + ring_lookup (PackRing Ring_simplify) [lH] rl t; + intro H; + unfold g;clear g. + diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v new file mode 100644 index 00000000..b3250a51 --- /dev/null +++ b/plugins/setoid_ring/Ring_theory.v @@ -0,0 +1,608 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* R -> R. + Variable req : R -> R -> Prop. + Variable Rsth : Setoid_Theory R req. + Notation "x * y " := (rmul x y). + Notation "x == y" := (req x y). + + Hypothesis mul_ext : + forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2. + Hypothesis mul_comm : forall x y, x * y == y * x. + Hypothesis mul_assoc : forall x y z, x * (y * z) == (x * y) * z. + Add Setoid R req Rsth as R_set_Power. + Add Morphism rmul : rmul_ext_Power. exact mul_ext. Qed. + + + Fixpoint pow_pos (x:R) (i:positive) {struct i}: R := + match i with + | xH => x + | xO i => let p := pow_pos x i in rmul p p + | xI i => let p := pow_pos x i in rmul x (rmul p p) + end. + + Lemma pow_pos_Psucc : forall x j, pow_pos x (Psucc j) == x * pow_pos x j. + Proof. + induction j;simpl. + rewrite IHj. + rewrite (mul_comm x (pow_pos x j *pow_pos x j)). + setoid_rewrite (mul_comm x (pow_pos x j)) at 2. + repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). + repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). + apply (Seq_refl _ _ Rsth). + Qed. + + Lemma pow_pos_Pplus : forall x i j, pow_pos x (i + j) == pow_pos x i * pow_pos x j. + Proof. + intro x;induction i;intros. + rewrite xI_succ_xO;rewrite Pplus_one_succ_r. + rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. + repeat rewrite IHi. + rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc. + simpl;repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). + rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. + repeat rewrite IHi;rewrite mul_assoc. apply (Seq_refl _ _ Rsth). + rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc; + simpl. apply (Seq_refl _ _ Rsth). + Qed. + + Definition pow_N (x:R) (p:N) := + match p with + | N0 => rI + | Npos p => pow_pos x p + end. + + Definition id_phi_N (x:N) : N := x. + + Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n. + Proof. + intros; apply (Seq_refl _ _ Rsth). + Qed. + +End Power. + +Section DEFINITIONS. + Variable R : Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). + Variable req : R -> R -> Prop. + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). + Notation "x == y" := (req x y). + + (** Semi Ring *) + Record semi_ring_theory : Prop := mk_srt { + SRadd_0_l : forall n, 0 + n == n; + SRadd_comm : forall n m, n + m == m + n ; + SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p; + SRmul_1_l : forall n, 1*n == n; + SRmul_0_l : forall n, 0*n == 0; + SRmul_comm : forall n m, n*m == m*n; + SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p; + SRdistr_l : forall n m p, (n + m)*p == n*p + m*p + }. + + (** Almost Ring *) +(*Almost ring are no ring : Ropp_def is missing **) + Record almost_ring_theory : Prop := mk_art { + ARadd_0_l : forall x, 0 + x == x; + ARadd_comm : forall x y, x + y == y + x; + ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z; + ARmul_1_l : forall x, 1 * x == x; + ARmul_0_l : forall x, 0 * x == 0; + ARmul_comm : forall x y, x * y == y * x; + ARmul_assoc : forall x y z, x * (y * z) == (x * y) * z; + ARdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); + ARopp_mul_l : forall x y, -(x * y) == -x * y; + ARopp_add : forall x y, -(x + y) == -x + -y; + ARsub_def : forall x y, x - y == x + -y + }. + + (** Ring *) + Record ring_theory : Prop := mk_rt { + Radd_0_l : forall x, 0 + x == x; + Radd_comm : forall x y, x + y == y + x; + Radd_assoc : forall x y z, x + (y + z) == (x + y) + z; + Rmul_1_l : forall x, 1 * x == x; + Rmul_comm : forall x y, x * y == y * x; + Rmul_assoc : forall x y z, x * (y * z) == (x * y) * z; + Rdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); + Rsub_def : forall x y, x - y == x + -y; + Ropp_def : forall x, x + (- x) == 0 + }. + + (** Equality is extensional *) + + Record sring_eq_ext : Prop := mk_seqe { + (* SRing operators are compatible with equality *) + SRadd_ext : + forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; + SRmul_ext : + forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2 + }. + + Record ring_eq_ext : Prop := mk_reqe { + (* Ring operators are compatible with equality *) + Radd_ext : + forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; + Rmul_ext : + forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2; + Ropp_ext : forall x1 x2, x1 == x2 -> -x1 == -x2 + }. + + (** Interpretation morphisms definition*) + Section MORPHISM. + Variable C:Type. + Variable (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C). + Variable ceqb : C->C->bool. + (* [phi] est un morphisme de [C] dans [R] *) + Variable phi : C -> R. + Notation "x +! y" := (cadd x y). Notation "x -! y " := (csub x y). + Notation "x *! y " := (cmul x y). Notation "-! x" := (copp x). + Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). + +(*for semi rings*) + Record semi_morph : Prop := mkRmorph { + Smorph0 : [cO] == 0; + Smorph1 : [cI] == 1; + Smorph_add : forall x y, [x +! y] == [x]+[y]; + Smorph_mul : forall x y, [x *! y] == [x]*[y]; + Smorph_eq : forall x y, x?=!y = true -> [x] == [y] + }. + +(* for rings*) + Record ring_morph : Prop := mkmorph { + morph0 : [cO] == 0; + morph1 : [cI] == 1; + morph_add : forall x y, [x +! y] == [x]+[y]; + morph_sub : forall x y, [x -! y] == [x]-[y]; + morph_mul : forall x y, [x *! y] == [x]*[y]; + morph_opp : forall x, [-!x] == -[x]; + morph_eq : forall x y, x?=!y = true -> [x] == [y] + }. + + Section SIGN. + Variable get_sign : C -> option C. + Record sign_theory : Prop := mksign_th { + sign_spec : forall c c', get_sign c = Some c' -> c ?=! -! c' = true + }. + End SIGN. + + Definition get_sign_None (c:C) := @None C. + + Lemma get_sign_None_th : sign_theory get_sign_None. + Proof. constructor;intros;discriminate. Qed. + + Section DIV. + Variable cdiv: C -> C -> C*C. + Record div_theory : Prop := mkdiv_th { + div_eucl_th : forall a b, let (q,r) := cdiv a b in [a] == [b *! q +! r] + }. + End DIV. + + End MORPHISM. + + (** Identity is a morphism *) + Variable Rsth : Setoid_Theory R req. + Add Setoid R req Rsth as R_setoid1. + Variable reqb : R->R->bool. + Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. + Definition IDphi (x:R) := x. + Lemma IDmorph : ring_morph rO rI radd rmul rsub ropp reqb IDphi. + Proof. + apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi);intros;unfold IDphi; + try apply (Seq_refl _ _ Rsth);auto. + Qed. + + (** Specification of the power function *) + Section POWER. + Variable Cpow : Set. + Variable Cp_phi : N -> Cpow. + Variable rpow : R -> Cpow -> R. + + Record power_theory : Prop := mkpow_th { + rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n) + }. + + End POWER. + + Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth). + + +End DEFINITIONS. + + + +Section ALMOST_RING. + Variable R : Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). + Variable req : R -> R -> Prop. + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). + Notation "x == y" := (req x y). + + (** Leibniz equality leads to a setoid theory and is extensional*) + Lemma Eqsth : Setoid_Theory R (@eq R). + Proof. constructor;red;intros;subst;trivial. Qed. + + Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R). + Proof. constructor;intros;subst;trivial. Qed. + + Lemma Eq_ext : ring_eq_ext radd rmul ropp (@eq R). + Proof. constructor;intros;subst;trivial. Qed. + + Variable Rsth : Setoid_Theory R req. + Add Setoid R req Rsth as R_setoid2. + Ltac sreflexivity := apply (Seq_refl _ _ Rsth). + + Section SEMI_RING. + Variable SReqe : sring_eq_ext radd rmul req. + Add Morphism radd : radd_ext1. exact (SRadd_ext SReqe). Qed. + Add Morphism rmul : rmul_ext1. exact (SRmul_ext SReqe). Qed. + Variable SRth : semi_ring_theory 0 1 radd rmul req. + + (** Every semi ring can be seen as an almost ring, by taking : + -x = x and x - y = x + y *) + Definition SRopp (x:R) := x. Notation "- x" := (SRopp x). + + Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y). + + Lemma SRopp_ext : forall x y, x == y -> -x == -y. + Proof. intros x y H;exact H. Qed. + + Lemma SReqe_Reqe : ring_eq_ext radd rmul SRopp req. + Proof. + constructor. exact (SRadd_ext SReqe). exact (SRmul_ext SReqe). + exact SRopp_ext. + Qed. + + Lemma SRopp_mul_l : forall x y, -(x * y) == -x * y. + Proof. intros;sreflexivity. Qed. + + Lemma SRopp_add : forall x y, -(x + y) == -x + -y. + Proof. intros;sreflexivity. Qed. + + + Lemma SRsub_def : forall x y, x - y == x + -y. + Proof. intros;sreflexivity. Qed. + + Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req. + Proof (mk_art 0 1 radd rmul SRsub SRopp req + (SRadd_0_l SRth) (SRadd_comm SRth) (SRadd_assoc SRth) + (SRmul_1_l SRth) (SRmul_0_l SRth) + (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth) + SRopp_mul_l SRopp_add SRsub_def). + + (** Identity morphism for semi-ring equipped with their almost-ring structure*) + Variable reqb : R->R->bool. + + Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. + + Definition SRIDmorph : ring_morph 0 1 radd rmul SRsub SRopp req + 0 1 radd rmul SRsub SRopp reqb (@IDphi R). + Proof. + apply mkmorph;intros;try sreflexivity. unfold IDphi;auto. + Qed. + + (* a semi_morph can be extended to a ring_morph for the almost_ring derived + from a semi_ring, provided the ring is a setoid (we only need + reflexivity) *) + Variable C : Type. + Variable (cO cI : C) (cadd cmul: C->C->C). + Variable (ceqb : C -> C -> bool). + Variable phi : C -> R. + Variable Smorph : semi_morph rO rI radd rmul req cO cI cadd cmul ceqb phi. + + Lemma SRmorph_Rmorph : + ring_morph rO rI radd rmul SRsub SRopp req + cO cI cadd cmul cadd (fun x => x) ceqb phi. + Proof. + case Smorph; intros; constructor; auto. + unfold SRopp in |- *; intros. + setoid_reflexivity. + Qed. + + End SEMI_RING. + + Variable Reqe : ring_eq_ext radd rmul ropp req. + Add Morphism radd : radd_ext2. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext2. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext2. exact (Ropp_ext Reqe). Qed. + + Section RING. + Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. + + (** Rings are almost rings*) + Lemma Rmul_0_l : forall x, 0 * x == 0. + Proof. + intro x; setoid_replace (0*x) with ((0+1)*x + -x). + rewrite (Radd_0_l Rth); rewrite (Rmul_1_l Rth). + rewrite (Ropp_def Rth);sreflexivity. + + rewrite (Rdistr_l Rth);rewrite (Rmul_1_l Rth). + rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth). + rewrite (Radd_comm Rth); rewrite (Radd_0_l Rth);sreflexivity. + Qed. + + Lemma Ropp_mul_l : forall x y, -(x * y) == -x * y. + Proof. + intros x y;rewrite <-(Radd_0_l Rth (- x * y)). + rewrite (Radd_comm Rth). + rewrite <-(Ropp_def Rth (x*y)). + rewrite (Radd_assoc Rth). + rewrite <- (Rdistr_l Rth). + rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth). + rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity. + Qed. + + Lemma Ropp_add : forall x y, -(x + y) == -x + -y. + Proof. + intros x y;rewrite <- ((Radd_0_l Rth) (-(x+y))). + rewrite <- ((Ropp_def Rth) x). + rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))). + rewrite <- ((Ropp_def Rth) y). + rewrite ((Radd_comm Rth) x). + rewrite ((Radd_comm Rth) y). + rewrite <- ((Radd_assoc Rth) (-y)). + rewrite <- ((Radd_assoc Rth) (- x)). + rewrite ((Radd_assoc Rth) y). + rewrite ((Radd_comm Rth) y). + rewrite <- ((Radd_assoc Rth) (- x)). + rewrite ((Radd_assoc Rth) y). + rewrite ((Radd_comm Rth) y);rewrite (Ropp_def Rth). + rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth). + apply (Radd_comm Rth). + Qed. + + Lemma Ropp_opp : forall x, - -x == x. + Proof. + intros x; rewrite <- (Radd_0_l Rth (- -x)). + rewrite <- (Ropp_def Rth x). + rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth). + rewrite ((Radd_comm Rth) x);apply (Radd_0_l Rth). + Qed. + + Lemma Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. + Proof + (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_comm Rth) (Radd_assoc Rth) + (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth) + Ropp_mul_l Ropp_add (Rsub_def Rth)). + + (** Every semi morphism between two rings is a morphism*) + Variable C : Type. + Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C). + Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool). + Variable phi : C -> R. + Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). + Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). + Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). + Variable Csth : Setoid_Theory C ceq. + Variable Ceqe : ring_eq_ext cadd cmul copp ceq. + Add Setoid C ceq Csth as C_setoid. + Add Morphism cadd : cadd_ext. exact (Radd_ext Ceqe). Qed. + Add Morphism cmul : cmul_ext. exact (Rmul_ext Ceqe). Qed. + Add Morphism copp : copp_ext. exact (Ropp_ext Ceqe). Qed. + Variable Cth : ring_theory cO cI cadd cmul csub copp ceq. + Variable Smorph : semi_morph 0 1 radd rmul req cO cI cadd cmul ceqb phi. + Variable phi_ext : forall x y, ceq x y -> [x] == [y]. + Add Morphism phi : phi_ext1. exact phi_ext. Qed. + Lemma Smorph_opp : forall x, [-!x] == -[x]. + Proof. + intros x;rewrite <- (Rth.(Radd_0_l) [-!x]). + rewrite <- ((Ropp_def Rth) [x]). + rewrite ((Radd_comm Rth) [x]). + rewrite <- (Radd_assoc Rth). + rewrite <- (Smorph_add Smorph). + rewrite (Ropp_def Cth). + rewrite (Smorph0 Smorph). + rewrite (Radd_comm Rth (-[x])). + apply (Radd_0_l Rth);sreflexivity. + Qed. + + Lemma Smorph_sub : forall x y, [x -! y] == [x] - [y]. + Proof. + intros x y; rewrite (Rsub_def Cth);rewrite (Rsub_def Rth). + rewrite (Smorph_add Smorph);rewrite Smorph_opp;sreflexivity. + Qed. + + Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req + cO cI cadd cmul csub copp ceqb phi. + Proof + (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi + (Smorph0 Smorph) (Smorph1 Smorph) + (Smorph_add Smorph) Smorph_sub (Smorph_mul Smorph) Smorph_opp + (Smorph_eq Smorph)). + + End RING. + + (** Useful lemmas on almost ring *) + Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. + + Lemma ARth_SRth : semi_ring_theory 0 1 radd rmul req. +Proof. +elim ARth; intros. +constructor; trivial. +Qed. + + Lemma ARsub_ext : + forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2. + Proof. + intros. + setoid_replace (x1 - y1) with (x1 + -y1). + setoid_replace (x2 - y2) with (x2 + -y2). + rewrite H;rewrite H0;sreflexivity. + apply (ARsub_def ARth). + apply (ARsub_def ARth). + Qed. + Add Morphism rsub : rsub_ext. exact ARsub_ext. Qed. + + Ltac mrewrite := + repeat first + [ rewrite (ARadd_0_l ARth) + | rewrite <- ((ARadd_comm ARth) 0) + | rewrite (ARmul_1_l ARth) + | rewrite <- ((ARmul_comm ARth) 1) + | rewrite (ARmul_0_l ARth) + | rewrite <- ((ARmul_comm ARth) 0) + | rewrite (ARdistr_l ARth) + | sreflexivity + | match goal with + | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y)) + end]. + + Lemma ARadd_0_r : forall x, (x + 0) == x. + Proof. intros; mrewrite. Qed. + + Lemma ARmul_1_r : forall x, x * 1 == x. + Proof. intros;mrewrite. Qed. + + Lemma ARmul_0_r : forall x, x * 0 == 0. + Proof. intros;mrewrite. Qed. + + Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y. + Proof. + intros;mrewrite. + repeat rewrite (ARth.(ARmul_comm) z);sreflexivity. + Qed. + + Lemma ARadd_assoc1 : forall x y z, (x + y) + z == (y + z) + x. + Proof. + intros;rewrite <-(ARth.(ARadd_assoc) x). + rewrite (ARth.(ARadd_comm) x);sreflexivity. + Qed. + + Lemma ARadd_assoc2 : forall x y z, (y + x) + z == (y + z) + x. + Proof. + intros; repeat rewrite <- (ARadd_assoc ARth); + rewrite ((ARadd_comm ARth) x); sreflexivity. + Qed. + + Lemma ARmul_assoc1 : forall x y z, (x * y) * z == (y * z) * x. + Proof. + intros;rewrite <-((ARmul_assoc ARth) x). + rewrite ((ARmul_comm ARth) x);sreflexivity. + Qed. + + Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x. + Proof. + intros; repeat rewrite <- (ARmul_assoc ARth); + rewrite ((ARmul_comm ARth) x); sreflexivity. + Qed. + + Lemma ARopp_mul_r : forall x y, - (x * y) == x * -y. + Proof. + intros;rewrite ((ARmul_comm ARth) x y); + rewrite (ARopp_mul_l ARth); apply (ARmul_comm ARth). + Qed. + + Lemma ARopp_zero : -0 == 0. + Proof. + rewrite <- (ARmul_0_r 0); rewrite (ARopp_mul_l ARth). + repeat rewrite ARmul_0_r; sreflexivity. + Qed. + + + +End ALMOST_RING. + + +Section AddRing. + +(* Variable R : Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). + Variable req : R -> R -> Prop. *) + +Inductive ring_kind : Type := +| Abstract +| Computational + (R:Type) + (req : R -> R -> Prop) + (reqb : R -> R -> bool) + (_ : forall x y, (reqb x y) = true -> req x y) +| Morphism + (R : Type) + (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R) + (req : R -> R -> Prop) + (C : Type) + (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C) + (ceqb : C->C->bool) + phi + (_ : ring_morph rO rI radd rmul rsub ropp req + cO cI cadd cmul csub copp ceqb phi). + + +End AddRing. + + +(** Some simplification tactics*) +Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth). + +Ltac gen_srewrite Rsth Reqe ARth := + repeat first + [ gen_reflexivity Rsth + | progress rewrite (ARopp_zero Rsth Reqe ARth) + | rewrite (ARadd_0_l ARth) + | rewrite (ARadd_0_r Rsth ARth) + | rewrite (ARmul_1_l ARth) + | rewrite (ARmul_1_r Rsth ARth) + | rewrite (ARmul_0_l ARth) + | rewrite (ARmul_0_r Rsth ARth) + | rewrite (ARdistr_l ARth) + | rewrite (ARdistr_r Rsth Reqe ARth) + | rewrite (ARadd_assoc ARth) + | rewrite (ARmul_assoc ARth) + | progress rewrite (ARopp_add ARth) + | progress rewrite (ARsub_def ARth) + | progress rewrite <- (ARopp_mul_l ARth) + | progress rewrite <- (ARopp_mul_r Rsth Reqe ARth) ]. + +Ltac gen_add_push add Rsth Reqe ARth x := + repeat (match goal with + | |- context [add (add ?y x) ?z] => + progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z) + | |- context [add (add x ?y) ?z] => + progress rewrite (ARadd_assoc1 Rsth ARth x y z) + end). + +Ltac gen_mul_push mul Rsth Reqe ARth x := + repeat (match goal with + | |- context [mul (mul ?y x) ?z] => + progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z) + | |- context [mul (mul x ?y) ?z] => + progress rewrite (ARmul_assoc1 Rsth ARth x y z) + end). + diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v new file mode 100644 index 00000000..4cb5a05a --- /dev/null +++ b/plugins/setoid_ring/ZArithRing.v @@ -0,0 +1,60 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t + | _ => constr:NotConstant + end. + +Ltac isZpow_coef t := + match t with + | Zpos ?p => isPcst p + | Z0 => constr:true + | _ => constr:false + end. + +Definition N_of_Z x := + match x with + | Zpos p => Npos p + | _ => N0 + end. + +Ltac Zpow_tac t := + match isZpow_coef t with + | true => constr:(N_of_Z t) + | _ => constr:NotConstant + end. + +Ltac Zpower_neg := + repeat match goal with + | [|- ?G] => + match G with + | context c [Zpower _ (Zneg _)] => + let t := context c [Z0] in + change t + end + end. + +Add Ring Zr : Zth + (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc], + power_tac Zpower_theory [Zpow_tac], + (* The two following option are not needed, it is the default chose when the set of + coefficiant is usual ring Z *) + div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)), + sign get_signZ_th). + + diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 new file mode 100644 index 00000000..535dbdbd --- /dev/null +++ b/plugins/setoid_ring/newring.ml4 @@ -0,0 +1,1164 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* f i c + | _ -> assert false + +type protect_flag = Eval|Prot|Rec + +let tag_arg tag_rec map subs i c = + match map i with + Eval -> mk_clos subs c + | Prot -> mk_atom c + | Rec -> if i = -1 then mk_clos subs c else tag_rec c + +let rec mk_clos_but f_map subs t = + match f_map t with + | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t + | None -> + (match kind_of_term t with + App(f,args) -> mk_clos_app_but f_map subs f args 0 + | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t + | _ -> mk_atom t) + +and mk_clos_app_but f_map subs f args n = + if n >= Array.length args then mk_atom(mkApp(f, args)) + else + let fargs, args' = array_chop n args in + let f' = mkApp(f,fargs) in + match f_map f' with + Some map -> + mk_clos_deep + (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s')) + subs + (mkApp (mark_arg (-1) f', Array.mapi mark_arg args')) + | None -> mk_clos_app_but f_map subs f args (n+1) + + +let interp_map l c = + try + let (im,am) = List.assoc c l in + Some(fun i -> + if List.mem i im then Eval + else if List.mem i am then Prot + else if i = -1 then Eval + else Rec) + with Not_found -> None + +let interp_map l t = + try Some(List.assoc t l) with Not_found -> None + +let protect_maps = ref Stringmap.empty +let add_map s m = protect_maps := Stringmap.add s m !protect_maps +let lookup_map map = + try Stringmap.find map !protect_maps + with Not_found -> + errorlabstrm"lookup_map"(str"map "++qs map++str"not found") + +let protect_red map env sigma c = + kl (create_clos_infos betadeltaiota env) + (mk_clos_but (lookup_map map c) (Esubst.ESID 0) c);; + +let protect_tac map = + Tactics.reduct_option (protect_red map,DEFAULTcast) None ;; + +let protect_tac_in map id = + Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id,InHyp));; + + +TACTIC EXTEND protect_fv + [ "protect_fv" string(map) "in" ident(id) ] -> + [ protect_tac_in map id ] +| [ "protect_fv" string(map) ] -> + [ protect_tac map ] +END;; + +(****************************************************************************) + +let closed_term t l = + let l = List.map constr_of_global l in + let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in + if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt()) +;; + +TACTIC EXTEND closed_term + [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] -> + [ closed_term t l ] +END +;; + +TACTIC EXTEND echo +| [ "echo" constr(t) ] -> + [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ] +END;; + +(* +let closed_term_ast l = + TacFun([Some(id_of_string"t")], + TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term", + [Genarg.in_gen Genarg.wit_constr (mkVar(id_of_string"t")); + Genarg.in_gen (Genarg.wit_list1 Genarg.wit_ref) l]))) +*) +let closed_term_ast l = + let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in + TacFun([Some(id_of_string"t")], + TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term", + [Genarg.in_gen Genarg.globwit_constr (RVar(dummy_loc,id_of_string"t"),None); + Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l]))) +(* +let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term" +*) + +(****************************************************************************) + +let ic c = + let env = Global.env() and sigma = Evd.empty in + Constrintern.interp_constr sigma env c + +let ty c = Typing.type_of (Global.env()) Evd.empty c + +let decl_constant na c = + mkConst(declare_constant (id_of_string na) (DefinitionEntry + { const_entry_body = c; + const_entry_type = None; + const_entry_opaque = true; + const_entry_boxed = true}, + IsProof Lemma)) + +(* Calling a global tactic *) +let ltac_call tac (args:glob_tactic_arg list) = + TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args)) + +(* Calling a locally bound tactic *) +let ltac_lcall tac args = + TacArg(TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args)) + +let ltac_letin (x, e1) e2 = + TacLetIn(false,[(dummy_loc,id_of_string x),e1],e2) + +let ltac_apply (f:glob_tactic_expr) (args:glob_tactic_arg list) = + Tacinterp.eval_tactic + (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args)) + +let ltac_record flds = + TacFun([Some(id_of_string"proj")], ltac_lcall "proj" flds) + + +let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) + +let dummy_goal env = + {Evd.it = Evd.make_evar (named_context_val env) mkProp; + Evd.sigma = Evd.empty} + +let exec_tactic env n f args = + let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in + let res = ref [||] in + let get_res ist = + let l = List.map (fun id -> List.assoc id ist.lfun) lid in + res := Array.of_list l; + TacId[] in + let getter = + Tacexp(TacFun(List.map(fun id -> Some id) lid, + glob_tactic(tacticIn get_res))) in + let _ = + Tacinterp.eval_tactic(ltac_call f (args@[getter])) (dummy_goal env) in + !res + +let constr_of = function + | VConstr ([],c) -> c + | _ -> failwith "Ring.exec_tactic: anomaly" + +let stdlib_modules = + [["Coq";"Setoids";"Setoid"]; + ["Coq";"Lists";"List"]; + ["Coq";"Init";"Datatypes"]; + ["Coq";"Init";"Logic"]; + ] + +let coq_constant c = + lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) + +let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" +let coq_cons = coq_constant "cons" +let coq_nil = coq_constant "nil" +let coq_None = coq_constant "None" +let coq_Some = coq_constant "Some" +let coq_eq = coq_constant "eq" + +let lapp f args = mkApp(Lazy.force f,args) + +let dest_rel0 t = + match kind_of_term t with + | App(f,args) when Array.length args >= 2 -> + let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in + if closed0 rel then + (rel,args.(Array.length args - 2),args.(Array.length args - 1)) + else error "ring: cannot find relation (not closed)" + | _ -> error "ring: cannot find relation" + +let rec dest_rel t = + match kind_of_term t with + | Prod(_,_,c) -> dest_rel c + | _ -> dest_rel0 t + +(****************************************************************************) +(* Library linking *) + +let plugin_dir = "setoid_ring" + +let cdir = ["Coq";plugin_dir] +let plugin_modules = + List.map (fun d -> cdir@d) + [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"]; + ["Field_tac"]; ["Field_theory"] + ] + +let my_constant c = + lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c) + +let new_ring_path = + make_dirpath (List.map id_of_string ["Ring_tac";plugin_dir;"Coq"]) +let ltac s = + lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s)) +let znew_ring_path = + make_dirpath (List.map id_of_string ["InitialRing";plugin_dir;"Coq"]) +let zltac s = + lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s)) + +let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);; +let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;; + +(* Ring theory *) + +(* almost_ring defs *) +let coq_almost_ring_theory = my_constant "almost_ring_theory" + +(* setoid and morphism utilities *) +let coq_eq_setoid = my_constant "Eqsth" +let coq_eq_morph = my_constant "Eq_ext" +let coq_eq_smorph = my_constant "Eq_s_ext" + +(* ring -> almost_ring utilities *) +let coq_ring_theory = my_constant "ring_theory" +let coq_mk_reqe = my_constant "mk_reqe" + +(* semi_ring -> almost_ring utilities *) +let coq_semi_ring_theory = my_constant "semi_ring_theory" +let coq_mk_seqe = my_constant "mk_seqe" + +let ltac_inv_morph_gen = zltac"inv_gen_phi" +let ltac_inv_morphZ = zltac"inv_gen_phiZ" +let ltac_inv_morphN = zltac"inv_gen_phiN" +let ltac_inv_morphNword = zltac"inv_gen_phiNword" +let coq_abstract = my_constant"Abstract" +let coq_comp = my_constant"Computational" +let coq_morph = my_constant"Morphism" + +(* morphism *) +let coq_ring_morph = my_constant "ring_morph" +let coq_semi_morph = my_constant "semi_morph" + +(* power function *) +let ltac_inv_morph_nothing = zltac"inv_morph_nothing" +let coq_pow_N_pow_N = my_constant "pow_N_pow_N" + +(* hypothesis *) +let coq_mkhypo = my_constant "mkhypo" +let coq_hypo = my_constant "hypo" + +(* Equality: do not evaluate but make recursive call on both sides *) +let map_with_eq arg_map c = + let (req,_,_) = dest_rel c in + interp_map + ((req,(function -1->Prot|_->Rec)):: + List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) + +let _ = add_map "ring" + (map_with_eq + [coq_cons,(function -1->Eval|2->Rec|_->Prot); + coq_nil, (function -1->Eval|_ -> Prot); + (* Pphi_dev: evaluate polynomial and coef operations, protect + ring operations and make recursive call on the var map *) + pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); + pol_cst "Pphi_pow", + (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); + (* PEeval: evaluate morphism and polynomial, protect ring + operations and make recursive call on the var map *) + pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)]) + +(****************************************************************************) +(* Ring database *) + +type ring_info = + { ring_carrier : types; + ring_req : constr; + ring_setoid : constr; + ring_ext : constr; + ring_morph : constr; + ring_th : constr; + ring_cst_tac : glob_tactic_expr; + ring_pow_tac : glob_tactic_expr; + ring_lemma1 : constr; + ring_lemma2 : constr; + ring_pre_tac : glob_tactic_expr; + ring_post_tac : glob_tactic_expr } + +module Cmap = Map.Make(struct type t = constr let compare = compare end) + +let from_carrier = ref Cmap.empty +let from_relation = ref Cmap.empty +let from_name = ref Spmap.empty + +let ring_for_carrier r = Cmap.find r !from_carrier +let ring_for_relation rel = Cmap.find rel !from_relation + + +let find_ring_structure env sigma l = + match l with + | t::cl' -> + let ty = Retyping.get_type_of env sigma t in + let check c = + let ty' = Retyping.get_type_of env sigma c in + if not (Reductionops.is_conv env sigma ty ty') then + errorlabstrm "ring" + (str"arguments of ring_simplify do not have all the same type") + in + List.iter check cl'; + (try ring_for_carrier ty + with Not_found -> + errorlabstrm "ring" + (str"cannot find a declared ring structure over"++ + spc()++str"\""++pr_constr ty++str"\"")) + | [] -> assert false +(* + let (req,_,_) = dest_rel cl in + (try ring_for_relation req + with Not_found -> + errorlabstrm "ring" + (str"cannot find a declared ring structure for equality"++ + spc()++str"\""++pr_constr req++str"\"")) *) + +let _ = + Summary.declare_summary "tactic-new-ring-table" + { Summary.freeze_function = + (fun () -> !from_carrier,!from_relation,!from_name); + Summary.unfreeze_function = + (fun (ct,rt,nt) -> + from_carrier := ct; from_relation := rt; from_name := nt); + Summary.init_function = + (fun () -> + from_carrier := Cmap.empty; from_relation := Cmap.empty; + from_name := Spmap.empty) } + +let add_entry (sp,_kn) e = +(* let _ = ty e.ring_lemma1 in + let _ = ty e.ring_lemma2 in +*) + from_carrier := Cmap.add e.ring_carrier e !from_carrier; + from_relation := Cmap.add e.ring_req e !from_relation; + from_name := Spmap.add sp e !from_name + + +let subst_th (subst,th) = + let c' = subst_mps subst th.ring_carrier in + let eq' = subst_mps subst th.ring_req in + let set' = subst_mps subst th.ring_setoid in + let ext' = subst_mps subst th.ring_ext in + let morph' = subst_mps subst th.ring_morph in + let th' = subst_mps subst th.ring_th in + let thm1' = subst_mps subst th.ring_lemma1 in + let thm2' = subst_mps subst th.ring_lemma2 in + let tac'= subst_tactic subst th.ring_cst_tac in + let pow_tac'= subst_tactic subst th.ring_pow_tac in + let pretac'= subst_tactic subst th.ring_pre_tac in + let posttac'= subst_tactic subst th.ring_post_tac in + if c' == th.ring_carrier && + eq' == th.ring_req && + set' = th.ring_setoid && + ext' == th.ring_ext && + morph' == th.ring_morph && + th' == th.ring_th && + thm1' == th.ring_lemma1 && + thm2' == th.ring_lemma2 && + tac' == th.ring_cst_tac && + pow_tac' == th.ring_pow_tac && + pretac' == th.ring_pre_tac && + posttac' == th.ring_post_tac then th + else + { ring_carrier = c'; + ring_req = eq'; + ring_setoid = set'; + ring_ext = ext'; + ring_morph = morph'; + ring_th = th'; + ring_cst_tac = tac'; + ring_pow_tac = pow_tac'; + ring_lemma1 = thm1'; + ring_lemma2 = thm2'; + ring_pre_tac = pretac'; + ring_post_tac = posttac' } + + +let (theory_to_obj, obj_to_theory) = + let cache_th (name,th) = add_entry name th in + declare_object + {(default_object "tactic-new-ring-theory") with + open_function = (fun i o -> if i=1 then cache_th o); + cache_function = cache_th; + subst_function = subst_th; + classify_function = (fun x -> Substitute x)} + + +let setoid_of_relation env a r = + let evm = Evd.empty in + try + lapp coq_mk_Setoid + [|a ; r ; + Rewrite.get_reflexive_proof env evm a r ; + Rewrite.get_symmetric_proof env evm a r ; + Rewrite.get_transitive_proof env evm a r |] + with Not_found -> + error "cannot find setoid relation" + +let op_morph r add mul opp req m1 m2 m3 = + lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |] + +let op_smorph r add mul req m1 m2 = + lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |] + +(* let default_ring_equality (r,add,mul,opp,req) = *) +(* let is_setoid = function *) +(* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *) +(* eq_constr req rel (\* Qu: use conversion ? *\) *) +(* | _ -> false in *) +(* match default_relation_for_carrier ~filter:is_setoid r with *) +(* Leibniz _ -> *) +(* let setoid = lapp coq_eq_setoid [|r|] in *) +(* let op_morph = *) +(* match opp with *) +(* Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] *) +(* | None -> lapp coq_eq_smorph [|r;add;mul|] in *) +(* (setoid,op_morph) *) +(* | Relation rel -> *) +(* let setoid = setoid_of_relation rel in *) +(* let is_endomorphism = function *) +(* { args=args } -> List.for_all *) +(* (function (var,Relation rel) -> *) +(* var=None && eq_constr req rel *) +(* | _ -> false) args in *) +(* let add_m = *) +(* try default_morphism ~filter:is_endomorphism add *) +(* with Not_found -> *) +(* error "ring addition should be declared as a morphism" in *) +(* let mul_m = *) +(* try default_morphism ~filter:is_endomorphism mul *) +(* with Not_found -> *) +(* error "ring multiplication should be declared as a morphism" in *) +(* let op_morph = *) +(* match opp with *) +(* | Some opp -> *) +(* (let opp_m = *) +(* try default_morphism ~filter:is_endomorphism opp *) +(* with Not_found -> *) +(* error "ring opposite should be declared as a morphism" in *) +(* let op_morph = *) +(* op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in *) +(* msgnl *) +(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++ *) +(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) +(* str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ *) +(* str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ *) +(* str"\""); *) +(* op_morph) *) +(* | None -> *) +(* (msgnl *) +(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ *) +(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) +(* str"\""++spc()++str"and \""++ *) +(* pr_constr mul_m.morphism_theory++str"\""); *) +(* op_smorph r add mul req add_m.lem mul_m.lem) in *) +(* (setoid,op_morph) *) + +let ring_equality (r,add,mul,opp,req) = + match kind_of_term req with + | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> + let setoid = lapp coq_eq_setoid [|r|] in + let op_morph = + match opp with + Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] + | None -> lapp coq_eq_smorph [|r;add;mul|] in + (setoid,op_morph) + | _ -> + let setoid = setoid_of_relation (Global.env ()) r req in + let signature = [Some (r,req);Some (r,req)],Some(r,req) in + let add_m, add_m_lem = + try Rewrite.default_morphism signature add + with Not_found -> + error "ring addition should be declared as a morphism" in + let mul_m, mul_m_lem = + try Rewrite.default_morphism signature mul + with Not_found -> + error "ring multiplication should be declared as a morphism" in + let op_morph = + match opp with + | Some opp -> + (let opp_m,opp_m_lem = + try Rewrite.default_morphism ([Some(r,req)],Some(r,req)) opp + with Not_found -> + error "ring opposite should be declared as a morphism" in + let op_morph = + op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in + Flags.if_verbose + msgnl + (str"Using setoid \""++pr_constr req++str"\""++spc()++ + str"and morphisms \""++pr_constr add_m_lem ++ + str"\","++spc()++ str"\""++pr_constr mul_m_lem++ + str"\""++spc()++str"and \""++pr_constr opp_m_lem++ + str"\""); + op_morph) + | None -> + (Flags.if_verbose + msgnl + (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ + str"and morphisms \""++pr_constr add_m_lem ++ + str"\""++spc()++str"and \""++ + pr_constr mul_m_lem++str"\""); + op_smorph r add mul req add_m_lem mul_m_lem) in + (setoid,op_morph) + +let build_setoid_params r add mul opp req eqth = + match eqth with + Some th -> th + | None -> ring_equality (r,add,mul,opp,req) + +let dest_ring env sigma th_spec = + let th_typ = Retyping.get_type_of env sigma th_spec in + match kind_of_term th_typ with + App(f,[|r;zero;one;add;mul;sub;opp;req|]) + when f = Lazy.force coq_almost_ring_theory -> + (None,r,zero,one,add,mul,Some sub,Some opp,req) + | App(f,[|r;zero;one;add;mul;req|]) + when f = Lazy.force coq_semi_ring_theory -> + (Some true,r,zero,one,add,mul,None,None,req) + | App(f,[|r;zero;one;add;mul;sub;opp;req|]) + when f = Lazy.force coq_ring_theory -> + (Some false,r,zero,one,add,mul,Some sub,Some opp,req) + | _ -> error "bad ring structure" + + +let dest_morph env sigma m_spec = + let m_typ = Retyping.get_type_of env sigma m_spec in + match kind_of_term m_typ with + App(f,[|r;zero;one;add;mul;sub;opp;req; + c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|]) + when f = Lazy.force coq_ring_morph -> + (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi) + | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|]) + when f = Lazy.force coq_semi_morph -> + (c,czero,cone,cadd,cmul,None,None,ceqb,phi) + | _ -> error "bad morphism structure" + + +type coeff_spec = + Computational of constr (* equality test *) + | Abstract (* coeffs = Z *) + | Morphism of constr (* general morphism *) + + +let reflect_coeff rkind = + (* We build an ill-typed terms on purpose... *) + match rkind with + Abstract -> Lazy.force coq_abstract + | Computational c -> lapp coq_comp [|c|] + | Morphism m -> lapp coq_morph [|m|] + +type cst_tac_spec = + CstTac of raw_tactic_expr + | Closed of reference list + +let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = + match cst_tac with + Some (CstTac t) -> Tacinterp.glob_tactic t + | Some (Closed lc) -> + closed_term_ast (List.map Smartlocate.global_with_alias lc) + | None -> + (match rk, opp, kind with + Abstract, None, _ -> + let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in + TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul])) + | Abstract, Some opp, Some _ -> + let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in + TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) + | Abstract, Some opp, None -> + let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphNword) in + TacArg + (TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) + | Computational _,_,_ -> + let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in + TacArg + (TacCall(dummy_loc,t,List.map carg [zero;one;zero;one])) + | Morphism mth,_,_ -> + let (_,czero,cone,_,_,_,_,_,_) = dest_morph env sigma mth in + let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in + TacArg + (TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone]))) + +let make_hyp env c = + let t = Retyping.get_type_of env Evd.empty c in + lapp coq_mkhypo [|t;c|] + +let make_hyp_list env lH = + let carrier = Lazy.force coq_hypo in + List.fold_right + (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH + (lapp coq_nil [|carrier|]) + +let interp_power env pow = + let carrier = Lazy.force coq_hypo in + match pow with + | None -> + let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in + (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|]) + | Some (tac, spec) -> + let tac = + match tac with + | CstTac t -> Tacinterp.glob_tactic t + | Closed lc -> + closed_term_ast (List.map Smartlocate.global_with_alias lc) in + let spec = make_hyp env (ic spec) in + (tac, lapp coq_Some [|carrier; spec|]) + +let interp_sign env sign = + let carrier = Lazy.force coq_hypo in + match sign with + | None -> lapp coq_None [|carrier|] + | Some spec -> + let spec = make_hyp env (ic spec) in + lapp coq_Some [|carrier;spec|] + (* Same remark on ill-typed terms ... *) + +let interp_div env div = + let carrier = Lazy.force coq_hypo in + match div with + | None -> lapp coq_None [|carrier|] + | Some spec -> + let spec = make_hyp env (ic spec) in + lapp coq_Some [|carrier;spec|] + (* Same remark on ill-typed terms ... *) + +let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = + check_required_library (cdir@["Ring_base"]); + let env = Global.env() in + let sigma = Evd.empty in + let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in + let (sth,ext) = build_setoid_params r add mul opp req eqth in + let (pow_tac, pspec) = interp_power env power in + let sspec = interp_sign env sign in + let dspec = interp_div env div in + let rk = reflect_coeff morphth in + let params = + exec_tactic env 5 (zltac "ring_lemmas") + (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in + let lemma1 = constr_of params.(3) in + let lemma2 = constr_of params.(4) in + + let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in + let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in + let cst_tac = + interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in + let pretac = + match pre with + Some t -> Tacinterp.glob_tactic t + | _ -> TacId [] in + let posttac = + match post with + Some t -> Tacinterp.glob_tactic t + | _ -> TacId [] in + let _ = + Lib.add_leaf name + (theory_to_obj + { ring_carrier = r; + ring_req = req; + ring_setoid = sth; + ring_ext = constr_of params.(1); + ring_morph = constr_of params.(2); + ring_th = constr_of params.(0); + ring_cst_tac = cst_tac; + ring_pow_tac = pow_tac; + ring_lemma1 = lemma1; + ring_lemma2 = lemma2; + ring_pre_tac = pretac; + ring_post_tac = posttac }) in + () + +type ring_mod = + Ring_kind of coeff_spec + | Const_tac of cst_tac_spec + | Pre_tac of raw_tactic_expr + | Post_tac of raw_tactic_expr + | Setoid of Topconstr.constr_expr * Topconstr.constr_expr + | Pow_spec of cst_tac_spec * Topconstr.constr_expr + (* Syntaxification tactic , correctness lemma *) + | Sign_spec of Topconstr.constr_expr + | Div_spec of Topconstr.constr_expr + + +VERNAC ARGUMENT EXTEND ring_mod + | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ] + | [ "abstract" ] -> [ Ring_kind Abstract ] + | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic morph)) ] + | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ] + | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ] + | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ] + | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ] + | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ] + | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ] + | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] -> + [ Pow_spec (Closed l, pow_spec) ] + | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] -> + [ Pow_spec (CstTac cst_tac, pow_spec) ] + | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ] +END + +let set_once s r v = + if !r = None then r := Some v else error (s^" cannot be set twice") + +let process_ring_mods l = + let kind = ref None in + let set = ref None in + let cst_tac = ref None in + let pre = ref None in + let post = ref None in + let sign = ref None in + let power = ref None in + let div = ref None in + List.iter(function + Ring_kind k -> set_once "ring kind" kind k + | Const_tac t -> set_once "tactic recognizing constants" cst_tac t + | Pre_tac t -> set_once "preprocess tactic" pre t + | Post_tac t -> set_once "postprocess tactic" post t + | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) + | Pow_spec(t,spec) -> set_once "power" power (t,spec) + | Sign_spec t -> set_once "sign" sign t + | Div_spec t -> set_once "div" div t) l; + let k = match !kind with Some k -> k | None -> Abstract in + (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) + +VERNAC COMMAND EXTEND AddSetoidRing + | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] -> + [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in + add_theory id (ic t) set k cst (pre,post) power sign div] +END + +(*****************************************************************************) +(* The tactics consist then only in a lookup in the ring database and + call the appropriate ltac. *) + +let make_args_list rl t = + match rl with + | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2] + | _ -> rl + +let make_term_list carrier rl = + List.fold_right + (fun x l -> lapp coq_cons [|carrier;x;l|]) rl + (lapp coq_nil [|carrier|]) + +let ltac_ring_structure e = + let req = carg e.ring_req in + let sth = carg e.ring_setoid in + let ext = carg e.ring_ext in + let morph = carg e.ring_morph in + let th = carg e.ring_th in + let cst_tac = Tacexp e.ring_cst_tac in + let pow_tac = Tacexp e.ring_pow_tac in + let lemma1 = carg e.ring_lemma1 in + let lemma2 = carg e.ring_lemma2 in + let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in + let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in + [req;sth;ext;morph;th;cst_tac;pow_tac; + lemma1;lemma2;pretac;posttac] + +let ring_lookup (f:glob_tactic_expr) lH rl t gl = + let env = pf_env gl in + let sigma = project gl in + let rl = make_args_list rl t in + let e = find_ring_structure env sigma rl in + let rl = carg (make_term_list e.ring_carrier rl) in + let lH = carg (make_hyp_list env lH) in + let ring = ltac_ring_structure e in + ltac_apply f (ring@[lH;rl]) gl + +TACTIC EXTEND ring_lookup +| [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] -> + [ let (t,lr) = list_sep_last lrt in ring_lookup (fst f) lH lr t] +END + + + +(***********************************************************************) + +let new_field_path = + make_dirpath (List.map id_of_string ["Field_tac";plugin_dir;"Coq"]) + +let field_ltac s = + lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s)) + + +let _ = add_map "field" + (map_with_eq + [coq_cons,(function -1->Eval|2->Rec|_->Prot); + coq_nil, (function -1->Eval|_ -> Prot); + (* display_linear: evaluate polynomials and coef operations, protect + field operations and make recursive call on the var map *) + my_constant "display_linear", + (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); + my_constant "display_pow_linear", + (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot); + (* Pphi_dev: evaluate polynomial and coef operations, protect + ring operations and make recursive call on the var map *) + pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); + pol_cst "Pphi_pow", + (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); + (* PEeval: evaluate morphism and polynomial, protect ring + operations and make recursive call on the var map *) + pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot); + (* FEeval: evaluate morphism, protect field + operations and make recursive call on the var map *) + my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; + +let _ = add_map "field_cond" + (map_with_eq + [coq_cons,(function -1->Eval|2->Rec|_->Prot); + coq_nil, (function -1->Eval|_ -> Prot); + (* PCond: evaluate morphism and denum list, protect ring + operations and make recursive call on the var map *) + my_constant "PCond", (function -1|8|10|13->Eval|12->Rec|_->Prot)]);; +(* (function -1|8|10->Eval|9->Rec|_->Prot)]);;*) + + +let _ = Redexpr.declare_reduction "simpl_field_expr" + (protect_red "field") + + + +let afield_theory = my_constant "almost_field_theory" +let field_theory = my_constant "field_theory" +let sfield_theory = my_constant "semi_field_theory" +let af_ar = my_constant"AF_AR" +let f_r = my_constant"F_R" +let sf_sr = my_constant"SF_SR" +let dest_field env sigma th_spec = + let th_typ = Retyping.get_type_of env sigma th_spec in + match kind_of_term th_typ with + | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) + when f = Lazy.force afield_theory -> + let rth = lapp af_ar + [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in + (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) + | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) + when f = Lazy.force field_theory -> + let rth = + lapp f_r + [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in + (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) + | App(f,[|r;zero;one;add;mul;div;inv;req|]) + when f = Lazy.force sfield_theory -> + let rth = lapp sf_sr + [|r;zero;one;add;mul;div;inv;req;th_spec|] in + (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) + | _ -> error "bad field structure" + +type field_info = + { field_carrier : types; + field_req : constr; + field_cst_tac : glob_tactic_expr; + field_pow_tac : glob_tactic_expr; + field_ok : constr; + field_simpl_eq_ok : constr; + field_simpl_ok : constr; + field_simpl_eq_in_ok : constr; + field_cond : constr; + field_pre_tac : glob_tactic_expr; + field_post_tac : glob_tactic_expr } + +let field_from_carrier = ref Cmap.empty +let field_from_relation = ref Cmap.empty +let field_from_name = ref Spmap.empty + + +let field_for_carrier r = Cmap.find r !field_from_carrier +let field_for_relation rel = Cmap.find rel !field_from_relation + +let find_field_structure env sigma l = + check_required_library (cdir@["Field_tac"]); + match l with + | t::cl' -> + let ty = Retyping.get_type_of env sigma t in + let check c = + let ty' = Retyping.get_type_of env sigma c in + if not (Reductionops.is_conv env sigma ty ty') then + errorlabstrm "field" + (str"arguments of field_simplify do not have all the same type") + in + List.iter check cl'; + (try field_for_carrier ty + with Not_found -> + errorlabstrm "field" + (str"cannot find a declared field structure over"++ + spc()++str"\""++pr_constr ty++str"\"")) + | [] -> assert false +(* let (req,_,_) = dest_rel cl in + (try field_for_relation req + with Not_found -> + errorlabstrm "field" + (str"cannot find a declared field structure for equality"++ + spc()++str"\""++pr_constr req++str"\"")) *) + +let _ = + Summary.declare_summary "tactic-new-field-table" + { Summary.freeze_function = + (fun () -> !field_from_carrier,!field_from_relation,!field_from_name); + Summary.unfreeze_function = + (fun (ct,rt,nt) -> + field_from_carrier := ct; field_from_relation := rt; + field_from_name := nt); + Summary.init_function = + (fun () -> + field_from_carrier := Cmap.empty; field_from_relation := Cmap.empty; + field_from_name := Spmap.empty) } + +let add_field_entry (sp,_kn) e = +(* + let _ = ty e.field_ok in + let _ = ty e.field_simpl_eq_ok in + let _ = ty e.field_simpl_ok in + let _ = ty e.field_cond in +*) + field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier; + field_from_relation := Cmap.add e.field_req e !field_from_relation; + field_from_name := Spmap.add sp e !field_from_name + +let subst_th (subst,th) = + let c' = subst_mps subst th.field_carrier in + let eq' = subst_mps subst th.field_req in + let thm1' = subst_mps subst th.field_ok in + let thm2' = subst_mps subst th.field_simpl_eq_ok in + let thm3' = subst_mps subst th.field_simpl_ok in + let thm4' = subst_mps subst th.field_simpl_eq_in_ok in + let thm5' = subst_mps subst th.field_cond in + let tac'= subst_tactic subst th.field_cst_tac in + let pow_tac' = subst_tactic subst th.field_pow_tac in + let pretac'= subst_tactic subst th.field_pre_tac in + let posttac'= subst_tactic subst th.field_post_tac in + if c' == th.field_carrier && + eq' == th.field_req && + thm1' == th.field_ok && + thm2' == th.field_simpl_eq_ok && + thm3' == th.field_simpl_ok && + thm4' == th.field_simpl_eq_in_ok && + thm5' == th.field_cond && + tac' == th.field_cst_tac && + pow_tac' == th.field_pow_tac && + pretac' == th.field_pre_tac && + posttac' == th.field_post_tac then th + else + { field_carrier = c'; + field_req = eq'; + field_cst_tac = tac'; + field_pow_tac = pow_tac'; + field_ok = thm1'; + field_simpl_eq_ok = thm2'; + field_simpl_ok = thm3'; + field_simpl_eq_in_ok = thm4'; + field_cond = thm5'; + field_pre_tac = pretac'; + field_post_tac = posttac' } + +let (ftheory_to_obj, obj_to_ftheory) = + let cache_th (name,th) = add_field_entry name th in + declare_object + {(default_object "tactic-new-field-theory") with + open_function = (fun i o -> if i=1 then cache_th o); + cache_function = cache_th; + subst_function = subst_th; + classify_function = (fun x -> Substitute x) } + +let field_equality r inv req = + match kind_of_term req with + | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> + mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) + | _ -> + let _setoid = setoid_of_relation (Global.env ()) r req in + let signature = [Some (r,req)],Some(r,req) in + let inv_m, inv_m_lem = + try Rewrite.default_morphism signature inv + with Not_found -> + error "field inverse should be declared as a morphism" in + inv_m_lem + +let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv = + check_required_library (cdir@["Field_tac"]); + let env = Global.env() in + let sigma = Evd.empty in + let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = + dest_field env sigma fth in + let (sth,ext) = build_setoid_params r add mul opp req eqth in + let eqth = Some(sth,ext) in + let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv in + let (pow_tac, pspec) = interp_power env power in + let sspec = interp_sign env sign in + let dspec = interp_div env odiv in + let inv_m = field_equality r inv req in + let rk = reflect_coeff morphth in + let params = + exec_tactic env 9 (field_ltac"field_lemmas") + (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in + let lemma1 = constr_of params.(3) in + let lemma2 = constr_of params.(4) in + let lemma3 = constr_of params.(5) in + let lemma4 = constr_of params.(6) in + let cond_lemma = + match inj with + | Some thm -> mkApp(constr_of params.(8),[|thm|]) + | None -> constr_of params.(7) in + let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in + let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in + let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in + let lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in + let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in + let cst_tac = + interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in + let pretac = + match pre with + Some t -> Tacinterp.glob_tactic t + | _ -> TacId [] in + let posttac = + match post with + Some t -> Tacinterp.glob_tactic t + | _ -> TacId [] in + let _ = + Lib.add_leaf name + (ftheory_to_obj + { field_carrier = r; + field_req = req; + field_cst_tac = cst_tac; + field_pow_tac = pow_tac; + field_ok = lemma1; + field_simpl_eq_ok = lemma2; + field_simpl_ok = lemma3; + field_simpl_eq_in_ok = lemma4; + field_cond = cond_lemma; + field_pre_tac = pretac; + field_post_tac = posttac }) in () + +type field_mod = + Ring_mod of ring_mod + | Inject of Topconstr.constr_expr + +VERNAC ARGUMENT EXTEND field_mod + | [ ring_mod(m) ] -> [ Ring_mod m ] + | [ "completeness" constr(inj) ] -> [ Inject inj ] +END + +let process_field_mods l = + let kind = ref None in + let set = ref None in + let cst_tac = ref None in + let pre = ref None in + let post = ref None in + let inj = ref None in + let sign = ref None in + let power = ref None in + let div = ref None in + List.iter(function + Ring_mod(Ring_kind k) -> set_once "field kind" kind k + | Ring_mod(Const_tac t) -> + set_once "tactic recognizing constants" cst_tac t + | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t + | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t + | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext) + | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec) + | Ring_mod(Sign_spec t) -> set_once "sign" sign t + | Ring_mod(Div_spec t) -> set_once "div" div t + | Inject i -> set_once "infinite property" inj (ic i)) l; + let k = match !kind with Some k -> k | None -> Abstract in + (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) + +VERNAC COMMAND EXTEND AddSetoidField +| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> + [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in + add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div] +END + + +let ltac_field_structure e = + let req = carg e.field_req in + let cst_tac = Tacexp e.field_cst_tac in + let pow_tac = Tacexp e.field_pow_tac in + let field_ok = carg e.field_ok in + let field_simpl_ok = carg e.field_simpl_ok in + let field_simpl_eq_ok = carg e.field_simpl_eq_ok in + let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in + let cond_ok = carg e.field_cond in + let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in + let posttac = Tacexp(TacFun([None],e.field_post_tac)) in + [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok; + field_simpl_eq_in_ok;cond_ok;pretac;posttac] + +let field_lookup (f:glob_tactic_expr) lH rl t gl = + let env = pf_env gl in + let sigma = project gl in + let rl = make_args_list rl t in + let e = find_field_structure env sigma rl in + let rl = carg (make_term_list e.field_carrier rl) in + let lH = carg (make_hyp_list env lH) in + let field = ltac_field_structure e in + ltac_apply f (field@[lH;rl]) gl + + +TACTIC EXTEND field_lookup +| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> + [ let (t,l) = list_sep_last lt in field_lookup (fst f) lH l t ] +END diff --git a/plugins/setoid_ring/newring_plugin.mllib b/plugins/setoid_ring/newring_plugin.mllib new file mode 100644 index 00000000..a98392f1 --- /dev/null +++ b/plugins/setoid_ring/newring_plugin.mllib @@ -0,0 +1,2 @@ +Newring +Newring_plugin_mod diff --git a/plugins/setoid_ring/vo.itarget b/plugins/setoid_ring/vo.itarget new file mode 100644 index 00000000..6934375b --- /dev/null +++ b/plugins/setoid_ring/vo.itarget @@ -0,0 +1,15 @@ +ArithRing.vo +BinList.vo +Field_tac.vo +Field_theory.vo +Field.vo +InitialRing.vo +NArithRing.vo +RealField.vo +Ring_base.vo +Ring_equiv.vo +Ring_polynom.vo +Ring_tac.vo +Ring_theory.vo +Ring.vo +ZArithRing.vo diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml new file mode 100644 index 00000000..4b95df19 --- /dev/null +++ b/plugins/subtac/eterm.ml @@ -0,0 +1,233 @@ +(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *) +(** + - Get types of existentials ; + - Flatten dependency tree (prefix order) ; + - Replace existentials by De Bruijn indices in term, applied to the right arguments ; + - Apply term prefixed by quantification on "existentials". +*) + +open Term +open Sign +open Names +open Evd +open List +open Pp +open Util +open Subtac_utils +open Proof_type + +let trace s = + if !Flags.debug then (msgnl s; msgerr s) + else () + +let succfix (depth, fixrels) = + (succ depth, List.map succ fixrels) + +type oblinfo = + { ev_name: int * identifier; + ev_hyps: named_context; + ev_status: obligation_definition_status; + ev_chop: int option; + ev_loc: Util.loc; + ev_typ: types; + ev_tac: tactic option; + ev_deps: Intset.t } + +(** Substitute evar references in t using De Bruijn indices, + where n binders were passed through. *) + +let subst_evar_constr evs n idf t = + let seen = ref Intset.empty in + let transparent = ref Idset.empty in + let evar_info id = List.assoc id evs in + let rec substrec (depth, fixrels) c = match kind_of_term c with + | Evar (k, args) -> + let { ev_name = (id, idstr) ; + ev_hyps = hyps ; ev_chop = chop } = + try evar_info k + with Not_found -> + anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") + in + seen := Intset.add id !seen; + (* Evar arguments are created in inverse order, + and we must not apply to defined ones (i.e. LetIn's) + *) + let args = + let n = match chop with None -> 0 | Some c -> c in + let (l, r) = list_chop n (List.rev (Array.to_list args)) in + List.rev r + in + let args = + let rec aux hyps args acc = + match hyps, args with + ((_, None, _) :: tlh), (c :: tla) -> + aux tlh tla ((substrec (depth, fixrels) c) :: acc) + | ((_, Some _, _) :: tlh), (_ :: tla) -> + aux tlh tla acc + | [], [] -> acc + | _, _ -> acc (*failwith "subst_evars: invalid argument"*) + in aux hyps args [] + in + if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then + transparent := Idset.add idstr !transparent; + mkApp (idf idstr, Array.of_list args) + | Fix _ -> + map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c + | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c + in + let t' = substrec (0, []) t in + t', !seen, !transparent + + +(** Substitute variable references in t using De Bruijn indices, + where n binders were passed through. *) +let subst_vars acc n t = + let var_index id = Util.list_index id acc in + let rec substrec depth c = match kind_of_term c with + | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c) + | _ -> map_constr_with_binders succ substrec depth c + in + substrec 0 t + +(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) + to a product : forall H1 : t1, ..., forall Hn : tn, concl. + Changes evars and hypothesis references to variable references. +*) +let etype_of_evar evs hyps concl = + let rec aux acc n = function + (id, copt, t) :: tl -> + let t', s, trans = subst_evar_constr evs n mkVar t in + let t'' = subst_vars acc 0 t' in + let rest, s', trans' = aux (id :: acc) (succ n) tl in + let s' = Intset.union s s' in + let trans' = Idset.union trans trans' in + (match copt with + Some c -> + let c', s'', trans'' = subst_evar_constr evs n mkVar c in + let c' = subst_vars acc 0 c' in + mkNamedProd_or_LetIn (id, Some c', t'') rest, + Intset.union s'' s', + Idset.union trans'' trans' + | None -> + mkNamedProd_or_LetIn (id, None, t'') rest, s', trans') + | [] -> + let t', s, trans = subst_evar_constr evs n mkVar concl in + subst_vars acc 0 t', s, trans + in aux [] 0 (rev hyps) + + +open Tacticals + +let trunc_named_context n ctx = + let len = List.length ctx in + list_firstn (len - n) ctx + +let rec chop_product n t = + if n = 0 then Some t + else + match kind_of_term t with + | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None + | _ -> None + +let evar_dependencies evm ev = + let one_step deps = + Intset.fold (fun ev s -> + let evi = Evd.find evm ev in + Intset.union (Evarutil.evars_of_evar_info evi) s) + deps deps + in + let rec aux deps = + let deps' = one_step deps in + if Intset.equal deps deps' then deps + else aux deps' + in aux (Intset.singleton ev) + +let sort_dependencies evl = + List.stable_sort + (fun (id, ev, deps) (id', ev', deps') -> + if id = id' then 0 + else if Intset.mem id deps' then -1 + else if Intset.mem id' deps then 1 + else Pervasives.compare id id') + evl + +let map_evar_body f = function + | Evar_empty -> Evar_empty + | Evar_defined c -> Evar_defined (f c) + +open Environ + +let map_evar_info f evi = + { evi with evar_hyps = val_of_named_context (map_named_context f (named_context_of_val evi.evar_hyps)); + evar_concl = f evi.evar_concl; + evar_body = map_evar_body f evi.evar_body } + +let eterm_obligations env name isevars evm fs ?status t ty = + (* 'Serialize' the evars *) + let nc = Environ.named_context env in + let nc_len = Sign.named_context_length nc in + let evl = List.rev (to_list evm) in + let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in + let sevl = sort_dependencies evl in + let evl = List.map (fun (id, ev, _) -> id, ev) sevl in + let evn = + let i = ref (-1) in + List.rev_map (fun (id, ev) -> incr i; + (id, (!i, id_of_string + (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))), + ev)) evl + in + let evts = + (* Remove existential variables in types and build the corresponding products *) + fold_right + (fun (id, (n, nstr), ev) l -> + let hyps = Evd.evar_filtered_context ev in + let hyps = trunc_named_context nc_len hyps in + let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in + let evtyp, hyps, chop = + match chop_product fs evtyp with + | Some t -> t, trunc_named_context fs hyps, fs + | None -> evtyp, hyps, 0 + in + let loc, k = evar_source id isevars in + let status = match k with QuestionMark o -> Some o | _ -> status in + let status, chop = match status with + | Some (Define true as stat) -> + if chop <> fs then Define false, None + else stat, Some chop + | Some s -> s, None + | None -> Define true, None + in + let tac = match ev.evar_extra with + | Some t -> + if Dyn.tag t = "tactic" then + Some (Tacinterp.interp + (Tacinterp.globTacticIn (Tacinterp.tactic_out t))) + else None + | None -> None + in + let info = { ev_name = (n, nstr); + ev_hyps = hyps; ev_status = status; ev_chop = chop; + ev_loc = loc; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac } + in (id, info) :: l) + evn [] + in + let t', _, transparent = (* Substitute evar refs in the term by variables *) + subst_evar_constr evts 0 mkVar t + in + let ty, _, _ = subst_evar_constr evts 0 mkVar ty in + let evars = + List.map (fun (ev, info) -> + let { ev_name = (_, name); ev_status = status; + ev_loc = loc; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info + in + let status = match status with + | Define true when Idset.mem name transparent -> Define false + | _ -> status + in name, typ, loc, status, deps, tac) evts + in + let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in + let evmap f c = pi1 (subst_evar_constr evts 0 f c) in + Array.of_list (List.rev evars), (evnames, evmap), t', ty + +let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n diff --git a/plugins/subtac/eterm.mli b/plugins/subtac/eterm.mli new file mode 100644 index 00000000..406f9433 --- /dev/null +++ b/plugins/subtac/eterm.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr list + +val evar_dependencies : evar_map -> int -> Intset.t +val sort_dependencies : (int * evar_info * Intset.t) list -> (int * evar_info * Intset.t) list + +(* env, id, evars, number of function prototypes to try to clear from + evars contexts, object and type *) +val eterm_obligations : env -> identifier -> evar_map -> evar_map -> int -> + ?status:obligation_definition_status -> constr -> types -> + (identifier * types * loc * obligation_definition_status * Intset.t * + tactic option) array + (* Existential key, obl. name, type as product, location of the original evar, associated tactic, + status and dependencies as indexes into the array *) + * ((existential_key * identifier) list * ((identifier -> constr) -> constr -> constr)) * constr * types + (* Translations from existential identifiers to obligation identifiers + and for terms with existentials to closed terms, given a + translation from obligation identifiers to constrs, new term, new type *) diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4 new file mode 100644 index 00000000..113b1680 --- /dev/null +++ b/plugins/subtac/g_subtac.ml4 @@ -0,0 +1,177 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + *) + +module Gram = Pcoq.Gram +module Vernac = Pcoq.Vernac_ +module Tactic = Pcoq.Tactic + +module SubtacGram = +struct + let gec s = Gram.Entry.create ("Subtac."^s) + (* types *) + let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.Entry.e = gec "subtac_gallina_loc" + + let subtac_withtac : Tacexpr.raw_tactic_expr option Gram.Entry.e = gec "subtac_withtac" +end + +open Rawterm +open SubtacGram +open Util +open Pcoq +open Prim +open Constr +let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig")) + +GEXTEND Gram + GLOBAL: subtac_gallina_loc typeclass_constraint Constr.binder subtac_withtac; + + subtac_gallina_loc: + [ [ g = Vernac.gallina -> loc, g + | g = Vernac.gallina_ext -> loc, g ] ] + ; + + subtac_withtac: + [ [ "with"; t = Tactic.tactic -> Some t + | -> None ] ] + ; + + Constr.binder_let: + [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> + let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in + [LocalRawAssum ([id], default_binder_kind, typ)] + ] ]; + + Constr.binder: + [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" -> + ([id],default_binder_kind, mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, c, p)])) + | "("; id=Prim.name; ":"; c=Constr.lconstr; ")" -> + ([id],default_binder_kind, c) + | "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" -> + (id::lid,default_binder_kind, c) + ] ]; + + END + + +type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) Genarg.abstract_argument_type + +let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype), + (globwit_subtac_gallina_loc : Genarg.glevel gallina_loc_argtype), + (rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) = + Genarg.create_arg "subtac_gallina_loc" + +type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type + +let (wit_subtac_withtac : Genarg.tlevel withtac_argtype), + (globwit_subtac_withtac : Genarg.glevel withtac_argtype), + (rawwit_subtac_withtac : Genarg.rlevel withtac_argtype) = + Genarg.create_arg "subtac_withtac" + +VERNAC COMMAND EXTEND Subtac +[ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ] + END + +let try_catch_exn f e = + try f e + with exn -> errorlabstrm "Program" (Cerrors.explain_exn exn) + +let subtac_obligation e = try_catch_exn Subtac_obligations.subtac_obligation e +let next_obligation e = try_catch_exn Subtac_obligations.next_obligation e +let try_solve_obligation e = try_catch_exn Subtac_obligations.try_solve_obligation e +let try_solve_obligations e = try_catch_exn Subtac_obligations.try_solve_obligations e +let solve_all_obligations e = try_catch_exn Subtac_obligations.solve_all_obligations e +let admit_obligations e = try_catch_exn Subtac_obligations.admit_obligations e + +VERNAC COMMAND EXTEND Subtac_Obligations +| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) subtac_withtac(tac) ] -> + [ subtac_obligation (num, Some name, Some t) tac ] +| [ "Obligation" integer(num) "of" ident(name) subtac_withtac(tac) ] -> + [ subtac_obligation (num, Some name, None) tac ] +| [ "Obligation" integer(num) ":" lconstr(t) subtac_withtac(tac) ] -> + [ subtac_obligation (num, None, Some t) tac ] +| [ "Obligation" integer(num) subtac_withtac(tac) ] -> + [ subtac_obligation (num, None, None) tac ] +| [ "Next" "Obligation" "of" ident(name) subtac_withtac(tac) ] -> + [ next_obligation (Some name) tac ] +| [ "Next" "Obligation" subtac_withtac(tac) ] -> [ next_obligation None tac ] +END + +VERNAC COMMAND EXTEND Subtac_Solve_Obligation +| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] -> + [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] -> + [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] + END + +VERNAC COMMAND EXTEND Subtac_Solve_Obligations +| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> + [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" "using" tactic(t) ] -> + [ try_solve_obligations None (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" ] -> + [ try_solve_obligations None None ] + END + +VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations +| [ "Solve" "All" "Obligations" "using" tactic(t) ] -> + [ solve_all_obligations (Some (Tacinterp.interp t)) ] +| [ "Solve" "All" "Obligations" ] -> + [ solve_all_obligations None ] + END + +VERNAC COMMAND EXTEND Subtac_Admit_Obligations +| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] +| [ "Admit" "Obligations" ] -> [ admit_obligations None ] + END + +VERNAC COMMAND EXTEND Subtac_Set_Solver +| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ + Subtac_obligations.set_default_tactic + (Vernacexpr.use_section_locality ()) + (Tacinterp.glob_tactic t) ] +END + +VERNAC COMMAND EXTEND Subtac_Show_Solver +| [ "Show" "Obligation" "Tactic" ] -> [ + Pp.msgnl (Pptactic.pr_glob_tactic (Global.env ()) (Subtac_obligations.default_tactic_expr ())) ] +END + +VERNAC COMMAND EXTEND Subtac_Show_Obligations +| [ "Obligations" "of" ident(name) ] -> [ Subtac_obligations.show_obligations (Some name) ] +| [ "Obligations" ] -> [ Subtac_obligations.show_obligations None ] +END + +VERNAC COMMAND EXTEND Subtac_Show_Preterm +| [ "Preterm" "of" ident(name) ] -> [ Subtac_obligations.show_term (Some name) ] +| [ "Preterm" ] -> [ Subtac_obligations.show_term None ] +END diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml new file mode 100644 index 00000000..0eba0f63 --- /dev/null +++ b/plugins/subtac/subtac.ml @@ -0,0 +1,250 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constant_value (Global.env()) + (match cst with ConstRef kn -> kn | _ -> assert false) + | _ -> + errorlabstrm "start_proof" + (str "The statement obligations could not be resolved automatically, " ++ spc () ++ + str "write a statement definition first.") + else + let _ = Typeops.infer_type env c in c + + +let start_proof_com env isevars sopt kind (bl,t) hook = + let id = match sopt with + | Some (loc,id) -> + (* We check existence here: it's a bit late at Qed time *) + if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then + user_err_loc (loc,"start_proof",pr_id id ++ str " already exists"); + id + | None -> + next_global_ident_away (id_of_string "Unnamed_thm") + (Pfedit.get_all_proof_names ()) + in + let evm, c, typ, imps = + Subtac_pretyping.subtac_process env isevars id [] (Topconstr.prod_constr_expr t bl) None + in + let c = solve_tccs_in_type env id isevars evm c typ in + Lemmas.start_proof id kind c (fun loc gr -> + Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true imps; + hook loc gr) + +let print_subgoals () = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () + +let start_proof_and_print env isevars idopt k t hook = + start_proof_com env isevars idopt k t hook; + print_subgoals () + +let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n))) + +let assumption_message id = + Flags.if_verbose message ((string_of_id id) ^ " is assumed") + +let declare_assumptions env isevars idl is_coe k bl c nl = + if not (Pfedit.refining ()) then + let id = snd (List.hd idl) in + let evm, c, typ, imps = + Subtac_pretyping.subtac_process env isevars id [] (Topconstr.prod_constr_expr c bl) None + in + let c = solve_tccs_in_type env id isevars evm c typ in + List.iter (Command.declare_assumption is_coe k c imps false nl) idl + else + errorlabstrm "Command.Assumption" + (str "Cannot declare an assumption while in proof editing mode.") + +let dump_constraint ty ((loc, n), _, _) = + match n with + | Name id -> Dumpglob.dump_definition (loc, id) false ty + | Anonymous -> () + +let dump_variable lid = () + +let vernac_assumption env isevars kind l nl = + let global = fst kind = Global in + List.iter (fun (is_coe,(idl,c)) -> + if Dumpglob.dump () then + List.iter (fun lid -> + if global then Dumpglob.dump_definition lid (not global) "ax" + else dump_variable lid) idl; + declare_assumptions env isevars idl is_coe kind [] c nl) l + +let check_fresh (loc,id) = + if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then + user_err_loc (loc,"",pr_id id ++ str " already exists") + +let subtac (loc, command) = + check_required_library ["Coq";"Init";"Datatypes"]; + check_required_library ["Coq";"Init";"Specif"]; + let env = Global.env () in + let isevars = ref (create_evar_defs Evd.empty) in + try + match command with + | VernacDefinition (defkind, (_, id as lid), expr, hook) -> + check_fresh lid; + Dumpglob.dump_definition lid false "def"; + (match expr with + | ProveBody (bl, t) -> + if Lib.is_modtype () then + errorlabstrm "Subtac_command.StartProof" + (str "Proof editing mode not supported in module types"); + start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t) + (fun _ _ -> ()) + | DefineBody (bl, _, c, tycon) -> + ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon)) + | VernacFixpoint (l, b) -> + List.iter (fun ((lid, _, _, _, _), _) -> + check_fresh lid; + Dumpglob.dump_definition lid false "fix") l; + let _ = trace (str "Building fixpoint") in + ignore(Subtac_command.build_recursive l b) + + | VernacStartTheoremProof (thkind, [Some id, (bl,t,guard)], lettop, hook) -> + if guard <> None then + error "Do not support building theorems as a fixpoint."; + Dumpglob.dump_definition id false "prf"; + if not(Pfedit.refining ()) then + if lettop then + errorlabstrm "Subtac_command.StartProof" + (str "Let declarations can only be used in proof editing mode"); + if Lib.is_modtype () then + errorlabstrm "Subtac_command.StartProof" + (str "Proof editing mode not supported in module types"); + check_fresh id; + start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook + + | VernacAssumption (stre,nl,l) -> + vernac_assumption env isevars stre l nl + + | VernacInstance (abst, glob, sup, is, props, pri) -> + dump_constraint "inst" is; + if abst then + error "Declare Instance not supported here."; + ignore(Subtac_classes.new_instance ~global:glob sup is props pri) + + | VernacCoFixpoint (l, b) -> + if Dumpglob.dump () then + List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l; + ignore(Subtac_command.build_corecursive l b) + + (*| VernacEndProof e -> + subtac_end_proof e*) + + | _ -> user_err_loc (loc,"", str ("Invalid Program command")) + with + | Typing_error e -> + msg_warning (str "Type error in Program tactic:"); + let cmds = + (match e with + | NonFunctionalApp (loc, x, mux, e) -> + str "non functional application of term " ++ + e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux + | NonSigma (loc, t) -> + str "Term is not of Sigma type: " ++ t + | NonConvertible (loc, x, y) -> + str "Unconvertible terms:" ++ spc () ++ + x ++ spc () ++ str "and" ++ spc () ++ y + | IllSorted (loc, t) -> + str "Term is ill-sorted:" ++ spc () ++ t + ) + in msg_warning cmds + + | Subtyping_error e -> + msg_warning (str "(Program tactic) Subtyping error:"); + let cmds = + match e with + | UncoercibleInferType (loc, x, y) -> + str "Uncoercible terms:" ++ spc () + ++ x ++ spc () ++ str "and" ++ spc () ++ y + | UncoercibleInferTerm (loc, x, y, tx, ty) -> + str "Uncoercible terms:" ++ spc () + ++ tx ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ x + ++ str "and" ++ spc() ++ ty ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ y + | UncoercibleRewrite (x, y) -> + str "Uncoercible terms:" ++ spc () + ++ x ++ spc () ++ str "and" ++ spc () ++ y + in msg_warning cmds + + | Cases.PatternMatchingError (env, exn) as e -> + debug 2 (Himsg.explain_pattern_matching_error env exn); + raise e + + | Type_errors.TypeError (env, exn) as e -> + debug 2 (Himsg.explain_type_error env exn); + raise e + + | Pretype_errors.PretypeError (env, exn) as e -> + debug 2 (Himsg.explain_pretype_error env exn); + raise e + + | (Stdpp.Exc_located (loc, Proof_type.LtacLocated (_,e')) | + Stdpp.Exc_located (loc, e') as e) -> + debug 2 (str "Parsing exception: "); + (match e' with + | Type_errors.TypeError (env, exn) -> + debug 2 (Himsg.explain_type_error env exn); + raise e + + | Pretype_errors.PretypeError (env, exn) -> + debug 2 (Himsg.explain_pretype_error env exn); + raise e + + | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e''); + raise e) + + | e -> + msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e); + raise e diff --git a/plugins/subtac/subtac.mli b/plugins/subtac/subtac.mli new file mode 100644 index 00000000..b51150aa --- /dev/null +++ b/plugins/subtac/subtac.mli @@ -0,0 +1,2 @@ +val require_library : string -> unit +val subtac : Util.loc * Vernacexpr.vernac_expr -> unit diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml new file mode 100644 index 00000000..e8f4f05f --- /dev/null +++ b/plugins/subtac/subtac_cases.ml @@ -0,0 +1,2027 @@ +(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* PatVar (dummy_loc,Anonymous)) + +(* Environment management *) +let push_rels vars env = List.fold_right push_rel vars env + +(* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize + over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *) + +let regeneralize_rel i k j = if j = i+k then k else if j < i+k then j else j + +let rec regeneralize_index i k t = match kind_of_term t with + | Rel j when j = i+k -> mkRel (k+1) + | Rel j when j < i+k -> t + | Rel j when j > i+k -> t + | _ -> map_constr_with_binders succ (regeneralize_index i) k t + +type alias_constr = + | DepAlias + | NonDepAlias + +let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) = + { uj_val = + (match d with + | DepAlias -> mkLetIn (na,deppat,t,j.uj_val) + | NonDepAlias -> + if (not (dependent (mkRel 1) j.uj_type)) + or (* A leaf: *) isRel deppat + then + (* The body of pat is not needed to type j - see *) + (* insert_aliases - and both deppat and nondeppat have the *) + (* same type, then one can freely substitute one by the other *) + subst1 nondeppat j.uj_val + else + (* The body of pat is not needed to type j but its value *) + (* is dependent in the type of j; our choice is to *) + (* enforce this dependency *) + mkLetIn (na,deppat,t,j.uj_val)); + uj_type = subst1 deppat j.uj_type } + +(**********************************************************************) +(* Structures used in compiling pattern-matching *) + +type rhs = + { rhs_env : env; + avoid_ids : identifier list; + it : rawconstr; + } + +type equation = + { patterns : cases_pattern list; + rhs : rhs; + alias_stack : name list; + eqn_loc : loc; + used : bool ref } + +type matrix = equation list + +(* 1st argument of IsInd is the original ind before extracting the summary *) +type tomatch_type = + | IsInd of types * inductive_type + | NotInd of constr option * types + +type tomatch_status = + | Pushed of ((constr * tomatch_type) * int list) + | Alias of (constr * constr * alias_constr * constr) + | Abstract of rel_declaration + +type tomatch_stack = tomatch_status list + +(* The type [predicate_signature] types the terms to match and the rhs: + + - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]), + if dep<>Anonymous, the term is dependent, let n=|names|, if + n<>0 then the type of the pushed term is necessarily an + inductive with n real arguments. Otherwise, it may be + non inductive, or inductive without real arguments, or inductive + originating from a subterm in which case real args are not dependent; + it accounts for n+1 binders if dep or n binders if not dep + - [PrProd] types abstracted term ([Abstract]); it accounts for one binder + - [PrCcl] types the right-hand-side + - Aliases [Alias] have no trace in [predicate_signature] +*) + +type predicate_signature = + | PrLetIn of (name list * name) * predicate_signature + | PrProd of predicate_signature + | PrCcl of constr + +(* We keep a constr for aliases and a cases_pattern for error message *) + +type alias_builder = + | AliasLeaf + | AliasConstructor of constructor + +type pattern_history = + | Top + | MakeAlias of alias_builder * pattern_continuation + +and pattern_continuation = + | Continuation of int * cases_pattern list * pattern_history + | Result of cases_pattern list + +let start_history n = Continuation (n, [], Top) + +let feed_history arg = function + | Continuation (n, l, h) when n>=1 -> + Continuation (n-1, arg :: l, h) + | Continuation (n, _, _) -> + anomaly ("Bad number of expected remaining patterns: "^(string_of_int n)) + | Result _ -> + anomaly "Exhausted pattern history" + +(* This is for non exhaustive error message *) + +let rec rawpattern_of_partial_history args2 = function + | Continuation (n, args1, h) -> + let args3 = make_anonymous_patvars (n - (List.length args2)) in + build_rawpattern (List.rev_append args1 (args2@args3)) h + | Result pl -> pl + +and build_rawpattern args = function + | Top -> args + | MakeAlias (AliasLeaf, rh) -> + assert (args = []); + rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh + | MakeAlias (AliasConstructor pci, rh) -> + rawpattern_of_partial_history + [PatCstr (dummy_loc, pci, args, Anonymous)] rh + +let complete_history = rawpattern_of_partial_history [] + +(* This is to build glued pattern-matching history and alias bodies *) + +let rec simplify_history = function + | Continuation (0, l, Top) -> Result (List.rev l) + | Continuation (0, l, MakeAlias (f, rh)) -> + let pargs = List.rev l in + let pat = match f with + | AliasConstructor pci -> + PatCstr (dummy_loc,pci,pargs,Anonymous) + | AliasLeaf -> + assert (l = []); + PatVar (dummy_loc, Anonymous) in + feed_history pat rh + | h -> h + +(* Builds a continuation expecting [n] arguments and building [ci] applied + to this [n] arguments *) + +let push_history_pattern n current cont = + Continuation (n, [], MakeAlias (current, cont)) + +(* A pattern-matching problem has the following form: + + env, isevars |- Cases tomatch of mat end + + where tomatch is some sequence of "instructions" (t1 ... tn) + + and mat is some matrix + (p11 ... p1n -> rhs1) + ( ... ) + (pm1 ... pmn -> rhsm) + + Terms to match: there are 3 kinds of instructions + + - "Pushed" terms to match are typed in [env]; these are usually just + Rel(n) except for the initial terms given by user and typed in [env] + - "Abstract" instructions means an abstraction has to be inserted in the + current branch to build (this means a pattern has been detected dependent + in another one and generalisation is necessary to ensure well-typing) + - "Alias" instructions means an alias has to be inserted (this alias + is usually removed at the end, except when its type is not the + same as the type of the matched term from which it comes - + typically because the inductive types are "real" parameters) + + Right-hand-sides: + + They consist of a raw term to type in an environment specific to the + clause they belong to: the names of declarations are those of the + variables present in the patterns. Therefore, they come with their + own [rhs_env] (actually it is the same as [env] except for the names + of variables). + +*) +type pattern_matching_problem = + { env : env; + isevars : Evd.evar_map ref; + pred : predicate_signature option; + tomatch : tomatch_stack; + history : pattern_continuation; + mat : matrix; + caseloc : loc; + casestyle: case_style; + typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment } + +(*--------------------------------------------------------------------------* + * A few functions to infer the inductive type from the patterns instead of * + * checking that the patterns correspond to the ind. type of the * + * destructurated object. Allows type inference of examples like * + * match n with O => true | _ => false end * + * match x in I with C => true | _ => false end * + *--------------------------------------------------------------------------*) + +(* Computing the inductive type from the matrix of patterns *) + +(* We use the "in I" clause to coerce the terms to match and otherwise + use the constructor to know in which type is the matching problem + + Note that insertion of coercions inside nested patterns is done + each time the matrix is expanded *) + +let rec find_row_ind = function + [] -> None + | PatVar _ :: l -> find_row_ind l + | PatCstr(loc,c,_,_) :: _ -> Some (loc,c) + +let inductive_template isevars env tmloc ind = + let arsign = get_full_arity_sign env ind in + let hole_source = match tmloc with + | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i)) + | None -> fun _ -> (dummy_loc, Evd.InternalHole) in + let (_,evarl,_) = + List.fold_right + (fun (na,b,ty) (subst,evarl,n) -> + match b with + | None -> + let ty' = substl subst ty in + let e = e_new_evar isevars env ~src:(hole_source n) ty' in + (e::subst,e::evarl,n+1) + | Some b -> + (b::subst,evarl,n+1)) + arsign ([],[],1) in + applist (mkInd ind,List.rev evarl) + + +(************************************************************************) +(* Utils *) + +let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars = + e_new_evar isevars env ~src:src (new_Type ()) + +let evd_comb2 f isevars x y = + let (evd',y) = f !isevars x y in + isevars := evd'; + y + +let context_of_arsign l = + let (x, _) = List.fold_right + (fun c (x, n) -> + (lift_rel_context n c @ x, List.length c + n)) + l ([], 0) + in x + +(* We put the tycon inside the arity signature, possibly discovering dependencies. *) + +let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c = + let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in + let subst, len = + List.fold_left2 (fun (subst, len) (tm, tmtype) sign -> + let signlen = List.length sign in + match kind_of_term tm with + | Rel n when dependent tm c + && signlen = 1 (* The term to match is not of a dependent type itself *) -> + ((n, len) :: subst, len - signlen) + | Rel n when signlen > 1 (* The term is of a dependent type, + maybe some variable in its type appears in the tycon. *) -> + (match tmtype with + | NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *) + | IsInd (_, IndType(indf,realargs)) -> + let subst = + if dependent tm c && List.for_all isRel realargs + then (n, 1) :: subst else subst + in + List.fold_left + (fun (subst, len) arg -> + match kind_of_term arg with + | Rel n when dependent arg c -> + ((n, len) :: subst, pred len) + | _ -> (subst, pred len)) + (subst, len) realargs) + | _ -> (subst, len - signlen)) + ([], nar) tomatchs arsign + in + let rec predicate lift c = + match kind_of_term c with + | Rel n when n > lift -> + (try + (* Make the predicate dependent on the matched variable *) + let idx = List.assoc (n - lift) subst in + mkRel (idx + lift) + with Not_found -> + (* A variable that is not matched, lift over the arsign. *) + mkRel (n + nar)) + | _ -> + map_constr_with_binders succ predicate lift c + in + try + (* The tycon may be ill-typed after abstraction. *) + let pred = predicate 0 c in + let env' = push_rel_context (context_of_arsign arsign) env in + ignore(Typing.sort_of env' evm pred); pred + with _ -> lift nar c + +module Cases_F(Coercion : Coercion.S) : S = struct + +let inh_coerce_to_ind isevars env ty tyi = + let expected_typ = inductive_template isevars env None tyi in + (* devrait être indifférent d'exiger leq ou pas puisque pour + un inductif cela doit être égal *) + let _ = e_cumul env isevars expected_typ ty in () + +let unify_tomatch_with_patterns isevars env loc typ pats = + match find_row_ind pats with + | None -> NotInd (None,typ) + | Some (_,(ind,_)) -> + inh_coerce_to_ind isevars env typ ind; + try IsInd (typ,find_rectype env ( !isevars) typ) + with Not_found -> NotInd (None,typ) + +let find_tomatch_tycon isevars env loc = function + (* Try if some 'in I ...' is present and can be used as a constraint *) + | Some (_,ind,_,_) -> mk_tycon (inductive_template isevars env loc ind) + | None -> empty_tycon + +let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) = + let loc = Some (loc_of_rawconstr tomatch) in + let tycon = find_tomatch_tycon isevars env loc indopt in + let j = typing_fun tycon env tomatch in + let evd, j = Coercion.inh_coerce_to_base (loc_of_rawconstr tomatch) env !isevars j in + isevars := evd; + let typ = nf_evar ( !isevars) j.uj_type in + let t = + try IsInd (typ,find_rectype env ( !isevars) typ) + with Not_found -> + unify_tomatch_with_patterns isevars env loc typ pats in + (j.uj_val,t) + +let coerce_to_indtype typing_fun isevars env matx tomatchl = + let pats = List.map (fun r -> r.patterns) matx in + let matx' = match matrix_transpose pats with + | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *) + | m -> m in + List.map2 (coerce_row typing_fun isevars env) matx' tomatchl + + + +let adjust_tomatch_to_pattern pb ((current,typ),deps) = + (* Ideally, we could find a common inductive type to which both the + term to match and the patterns coerce *) + (* In practice, we coerce the term to match if it is not already an + inductive type and it is not dependent; moreover, we use only + the first pattern type and forget about the others *) + let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in + let typ = + try IsInd (typ,find_rectype pb.env ( !(pb.isevars)) typ) + with Not_found -> NotInd (None,typ) in + let tomatch = ((current,typ),deps) in + match typ with + | NotInd (None,typ) -> + let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in + (match find_row_ind tm1 with + | None -> tomatch + | Some (_,(ind,_)) -> + let indt = inductive_template pb.isevars pb.env None ind in + let current = + if deps = [] & isEvar typ then + (* Don't insert coercions if dependent; only solve evars *) + let _ = e_cumul pb.env pb.isevars indt typ in + current + else + (evd_comb2 (Coercion.inh_conv_coerce_to dummy_loc pb.env) + pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in + let sigma = !(pb.isevars) in + let typ = IsInd (indt,find_rectype pb.env sigma indt) in + ((current,typ),deps)) + | _ -> tomatch + + (* extract some ind from [t], possibly coercing from constructors in [tm] *) +let to_mutind env isevars tm c t = +(* match c with + | Some body -> *) NotInd (c,t) +(* | None -> unify_tomatch_with_patterns isevars env t tm*) + +let type_of_tomatch = function + | IsInd (t,_) -> t + | NotInd (_,t) -> t + +let mkDeclTomatch na = function + | IsInd (t,_) -> (na,None,t) + | NotInd (c,t) -> (na,c,t) + +let map_tomatch_type f = function + | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind) + | NotInd (c,t) -> NotInd (Option.map f c, f t) + +let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth) +let lift_tomatch_type n = liftn_tomatch_type n 1 + +(**********************************************************************) +(* Utilities on patterns *) + +let current_pattern eqn = + match eqn.patterns with + | pat::_ -> pat + | [] -> anomaly "Empty list of patterns" + +let alias_of_pat = function + | PatVar (_,name) -> name + | PatCstr(_,_,_,name) -> name + +let remove_current_pattern eqn = + match eqn.patterns with + | pat::pats -> + { eqn with + patterns = pats; + alias_stack = alias_of_pat pat :: eqn.alias_stack } + | [] -> anomaly "Empty list of patterns" + +let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns } + +(**********************************************************************) +(* Well-formedness tests *) +(* Partial check on patterns *) + +exception NotAdjustable + +let rec adjust_local_defs loc = function + | (pat :: pats, (_,None,_) :: decls) -> + pat :: adjust_local_defs loc (pats,decls) + | (pats, (_,Some _,_) :: decls) -> + PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls) + | [], [] -> [] + | _ -> raise NotAdjustable + +let check_and_adjust_constructor env ind cstrs = function + | PatVar _ as pat -> pat + | PatCstr (loc,((_,i) as cstr),args,alias) as pat -> + (* Check it is constructor of the right type *) + let ind' = inductive_of_constructor cstr in + if Names.eq_ind ind' ind then + (* Check the constructor has the right number of args *) + let ci = cstrs.(i-1) in + let nb_args_constr = ci.cs_nargs in + if List.length args = nb_args_constr then pat + else + try + let args' = adjust_local_defs loc (args, List.rev ci.cs_args) + in PatCstr (loc, cstr, args', alias) + with NotAdjustable -> + error_wrong_numarg_constructor_loc loc (Global.env()) + cstr nb_args_constr + else + (* Try to insert a coercion *) + try + Coercion.inh_pattern_coerce_to loc pat ind' ind + with Not_found -> + error_bad_constructor_loc loc cstr ind + +let check_all_variables typ mat = + List.iter + (fun eqn -> match current_pattern eqn with + | PatVar (_,id) -> () + | PatCstr (loc,cstr_sp,_,_) -> + error_bad_pattern_loc loc cstr_sp typ) + mat + +let check_unused_pattern env eqn = + if not !(eqn.used) then + raise_pattern_matching_error + (eqn.eqn_loc, env, UnusedClause eqn.patterns) + +let set_used_pattern eqn = eqn.used := true + +let extract_rhs pb = + match pb.mat with + | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion()) + | eqn::_ -> + set_used_pattern eqn; + eqn.rhs + +(**********************************************************************) +(* Functions to deal with matrix factorization *) + +let occur_in_rhs na rhs = + match na with + | Anonymous -> false + | Name id -> occur_rawconstr id rhs.it + +let is_dep_patt eqn = function + | PatVar (_,name) -> occur_in_rhs name eqn.rhs + | PatCstr _ -> true + +let dependencies_in_rhs nargs eqns = + if eqns = [] then list_tabulate (fun _ -> false) nargs (* Only "_" patts *) + else + let deps = List.map (fun (tms,eqn) -> List.map (is_dep_patt eqn) tms) eqns in + let columns = matrix_transpose deps in + List.map (List.exists ((=) true)) columns + +let dependent_decl a = function + | (na,None,t) -> dependent a t + | (na,Some c,t) -> dependent a t || dependent a c + +(* Computing the matrix of dependencies *) + +(* We are in context d1...dn |- and [find_dependencies k 1 nextlist] + computes for declaration [k+1] in which of declarations in + [nextlist] (which corresponds to d(k+2)...dn) it depends; + declarations are expressed by index, e.g. in dependency list + [n-2;1], [1] points to [dn] and [n-2] to [d3] *) + +let rec find_dependency_list k n = function + | [] -> [] + | (used,tdeps,d)::rest -> + let deps = find_dependency_list k (n+1) rest in + if used && dependent_decl (mkRel n) d + then list_add_set (List.length rest + 1) (list_union deps tdeps) + else deps + +let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) = + let deps = find_dependency_list k 1 nextlist in + if is_dep_or_cstr_in_rhs || deps <> [] + then (k-1,(true ,deps,d)::nextlist) + else (k-1,(false,[] ,d)::nextlist) + +let find_dependencies_signature deps_in_rhs typs = + let k = List.length deps_in_rhs in + let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in + List.map (fun (_,deps,_) -> deps) l + +(******) + +(* A Pushed term to match has just been substituted by some + constructor t = (ci x1...xn) and the terms x1 ... xn have been added to + match + + - all terms to match and to push (dependent on t by definition) + must have (Rel depth) substituted by t and Rel's>depth lifted by n + - all pushed terms to match (non dependent on t by definition) must + be lifted by n + + We start with depth=1 +*) + +let regeneralize_index_tomatch n = + let rec genrec depth = function + | [] -> [] + | Pushed ((c,tm),l)::rest -> + let c = regeneralize_index n depth c in + let tm = map_tomatch_type (regeneralize_index n depth) tm in + let l = List.map (regeneralize_rel n depth) l in + Pushed ((c,tm),l)::(genrec depth rest) + | Alias (c1,c2,d,t)::rest -> + Alias (regeneralize_index n depth c1,c2,d,t)::(genrec depth rest) + | Abstract d::rest -> + Abstract (map_rel_declaration (regeneralize_index n depth) d) + ::(genrec (depth+1) rest) in + genrec 0 + +let rec replace_term n c k t = + if t = mkRel (n+k) then lift k c + else map_constr_with_binders succ (replace_term n c) k t + +let replace_tomatch n c = + let rec replrec depth = function + | [] -> [] + | Pushed ((b,tm),l)::rest -> + let b = replace_term n c depth b in + let tm = map_tomatch_type (replace_term n c depth) tm in + List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l; + Pushed ((b,tm),l)::(replrec depth rest) + | Alias (c1,c2,d,t)::rest -> + Alias (replace_term n c depth c1,c2,d,t)::(replrec depth rest) + | Abstract d::rest -> + Abstract (map_rel_declaration (replace_term n c depth) d) + ::(replrec (depth+1) rest) in + replrec 0 + +let rec liftn_tomatch_stack n depth = function + | [] -> [] + | Pushed ((c,tm),l)::rest -> + let c = liftn n depth c in + let tm = liftn_tomatch_type n depth tm in + let l = List.map (fun i -> if i + Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t) + ::(liftn_tomatch_stack n depth rest) + | Abstract d::rest -> + Abstract (map_rel_declaration (liftn n depth) d) + ::(liftn_tomatch_stack n (depth+1) rest) + + +let lift_tomatch_stack n = liftn_tomatch_stack n 1 + +(* if [current] has type [I(p1...pn u1...um)] and we consider the case + of constructor [ci] of type [I(p1...pn u'1...u'm)], then the + default variable [name] is expected to have which type? + Rem: [current] is [(Rel i)] except perhaps for initial terms to match *) + +(************************************************************************) +(* Some heuristics to get names for variables pushed in pb environment *) +(* Typical requirement: + + [match y with (S (S x)) => x | x => x end] should be compiled into + [match y with O => y | (S n) => match n with O => y | (S x) => x end end] + + and [match y with (S (S n)) => n | n => n end] into + [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end] + + i.e. user names should be preserved and created names should not + interfere with user names *) + +let merge_name get_name obj = function + | Anonymous -> get_name obj + | na -> na + +let merge_names get_name = List.map2 (merge_name get_name) + +let get_names env sign eqns = + let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in + (* If any, we prefer names used in pats, from top to bottom *) + let names2 = + List.fold_right + (fun (pats,eqn) names -> merge_names alias_of_pat pats names) + eqns names1 in + (* Otherwise, we take names from the parameters of the constructor but + avoiding conflicts with user ids *) + let allvars = + List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in + let names4,_ = + List.fold_left2 + (fun (l,avoid) d na -> + let na = + merge_name + (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid)) + d na + in + (na::l,(out_name na)::avoid)) + ([],allvars) (List.rev sign) names2 in + names4 + +(************************************************************************) +(* Recovering names for variables pushed to the rhs' environment *) + +let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t)) + +let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n | Anonymous -> Name (id_of_string "Anonymous") in + (n, b, t)) sign + +let push_rels_eqn sign eqn = + let sign = all_name sign in + {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env; } } + +let push_rels_eqn_with_names sign eqn = + let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in + let sign = recover_alias_names alias_of_pat pats sign in + push_rels_eqn sign eqn + +let build_aliases_context env sigma names allpats pats = + (* pats is the list of bodies to push as an alias *) + (* They all are defined in env and we turn them into a sign *) + (* cuts in sign need to be done in allpats *) + let rec insert env sign1 sign2 n newallpats oldallpats = function + | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) -> + (* Anonymous leaves must be considered named and treated in the *) + (* next clause because they may occur in implicit arguments *) + insert env sign1 sign2 + n newallpats (List.map List.tl oldallpats) (pats,names) + | (deppat,nondeppat,d,t)::pats, na::names -> + let nondeppat = lift n nondeppat in + let deppat = lift n deppat in + let newallpats = + List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in + let oldallpats = List.map List.tl oldallpats in + let decl = (na,Some deppat,t) in + let a = (deppat,nondeppat,d,t) in + insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) + newallpats oldallpats (pats,names) + | [], [] -> newallpats, sign1, sign2, env + | _ -> anomaly "Inconsistent alias and name lists" in + let allpats = List.map (fun x -> [x]) allpats + in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names) + +let insert_aliases_eqn sign eqnnames alias_rest eqn = + let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in + push_rels_eqn thissign { eqn with alias_stack = alias_rest; } + + +let insert_aliases env sigma alias eqns = + (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *) + (* défaut présent mais inutile, ce qui est le cas général, l'alias *) + (* est introduit même s'il n'est pas utilisé dans les cas réguliers *) + let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in + let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in + (* names2 takes the meet of all needed aliases *) + let names2 = + List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in + (* Only needed aliases are kept by build_aliases_context *) + let eqnsnames, sign1, sign2, env = + build_aliases_context env sigma [names2] eqnsnames [alias] in + let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in + sign2, env, eqns + +(**********************************************************************) +(* Functions to deal with elimination predicate *) + +exception Occur +let noccur_between_without_evar n m term = + let rec occur_rec n c = match kind_of_term c with + | Rel p -> if n<=p && p () + | _ -> iter_constr_with_binders succ occur_rec n c + in + try occur_rec n term; true with Occur -> false + +(* Inferring the predicate *) +let prepare_unif_pb typ cs = + let n = List.length (assums_of_rel_context cs.cs_args) in + + (* We may need to invert ci if its parameters occur in typ *) + let typ' = + if noccur_between_without_evar 1 n typ then lift (-n) typ + else (* TODO4-1 *) + error "Unable to infer return clause of this pattern-matching problem" in + let args = extended_rel_list (-n) cs.cs_args in + let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in + + (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = typ' *) + (Array.map (lift (-n)) cs.cs_concl_realargs, ci, typ') + + +(* Infering the predicate *) +(* +The problem to solve is the following: + +We match Gamma |- t : I(u01..u0q) against the following constructors: + + Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q) + ... + Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq) + +Assume the types in the branches are the following + + Gamma, x11...x1p1 |- branch1 : T1 + ... + Gamma, xn1...xnpn |- branchn : Tn + +Assume the type of the global case expression is Gamma |- T + +The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy +the following n+1 equations: + + Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1)) = T1 + ... + Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn)) = Tn + Gamma |- (phi u01..u0q t) = T + +Some hints: + +- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..." + should be inserted somewhere in Ti. + +- If T is undefined, an easy solution is to insert a "match z with (Ci + xi1..xipi) => ..." in front of each Ti + +- Otherwise, T1..Tn and T must be step by step unified, if some of them + diverge, then try to replace the diverging subterm by one of y1..yq or z. + +- The main problem is what to do when an existential variables is encountered + +let prepare_unif_pb typ cs = + let n = cs.cs_nargs in + let _,p = decompose_prod_n n typ in + let ci = build_dependent_constructor cs in + (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p *) + (n, cs.cs_concl_realargs, ci, p) + +let eq_operator_lift k (n,n') = function + | OpRel p, OpRel p' when p > k & p' > k -> + if p < k+n or p' < k+n' then false else p - n = p' - n' + | op, op' -> op = op' + +let rec transpose_args n = + if n=0 then [] + else + (Array.map (fun l -> List.hd l) lv):: + (transpose_args (m-1) (Array.init (fun l -> List.tl l))) + +let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k + +let reloc_operator (k,n) = function OpRel p when p > k -> +let rec unify_clauses k pv = + let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) ( isevars)) p) pv in + let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in + if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv' + then + let argvl = transpose_args (List.length args1) pv' in + let k' = shift_operator k op1 in + let argl = List.map (unify_clauses k') argvl in + gather_constr (reloc_operator (k,n1) op1) argl +*) + +let abstract_conclusion typ cs = + let n = List.length (assums_of_rel_context cs.cs_args) in + let (sign,p) = decompose_prod_n n typ in + it_mkLambda p sign + +let infer_predicate loc env isevars typs cstrs indf = + (* Il faudra substituer les isevars a un certain moment *) + if Array.length cstrs = 0 then (* "TODO4-3" *) + error "Inference of annotation for empty inductive types not implemented" + else + (* Empiric normalization: p may depend in a irrelevant way on args of the*) + (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *) + let typs = + Array.map (local_strong whd_beta ( !isevars)) typs + in + let eqns = array_map2 prepare_unif_pb typs cstrs in + (* First strategy: no dependencies at all *) +(* + let (mis,_) = dest_ind_family indf in + let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in +*) + let (sign,_) = get_arity env indf in + let mtyp = + if array_exists is_Type typs then + (* Heuristic to avoid comparison between non-variables algebric univs*) + new_Type () + else + mkExistential env ~src:(loc, Evd.CasesType) isevars + in + if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns + then + (* Non dependent case -> turn it into a (dummy) dependent one *) + let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in + let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in + (true,pred) (* true = dependent -- par défaut *) + else +(* + let s = get_sort_of env ( isevars) typs.(0) in + let predpred = it_mkLambda_or_LetIn (mkSort s) sign in + let caseinfo = make_default_case_info mis in + let brs = array_map2 abstract_conclusion typs cstrs in + let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in + let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in +*) + (* "TODO4-2" *) + (* We skip parameters *) + let cis = + Array.map + (fun cs -> + applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args)) + cstrs in + let ct = array_map2 (fun ci (_,_,t) -> (ci,t)) cis eqns in + raise_pattern_matching_error (loc,env, CannotInferPredicate ct) +(* + (true,pred) +*) + +(* Propagation of user-provided predicate through compilation steps *) + +let rec map_predicate f k = function + | PrCcl ccl -> PrCcl (f k ccl) + | PrProd pred -> + PrProd (map_predicate f (k+1) pred) + | PrLetIn ((names,dep as tm),pred) -> + let k' = List.length names + (if dep<>Anonymous then 1 else 0) in + PrLetIn (tm, map_predicate f (k+k') pred) + +let rec noccurn_predicate k = function + | PrCcl ccl -> noccurn k ccl + | PrProd pred -> noccurn_predicate (k+1) pred + | PrLetIn ((names,dep),pred) -> + let k' = List.length names + (if dep<>Anonymous then 1 else 0) in + noccurn_predicate (k+k') pred + +let liftn_predicate n = map_predicate (liftn n) + +let lift_predicate n = liftn_predicate n 1 + +let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0 + +let substnl_predicate sigma = map_predicate (substnl sigma) + +(* This is parallel bindings *) +let subst_predicate (args,copt) pred = + let sigma = match copt with + | None -> List.rev args + | Some c -> c::(List.rev args) in + substnl_predicate sigma 0 pred + +let specialize_predicate_var (cur,typ) = function + | PrProd _ | PrCcl _ -> + anomaly "specialize_predicate_var: a pattern-variable must be pushed" + | PrLetIn (([],dep),pred) -> + subst_predicate ([],if dep<>Anonymous then Some cur else None) pred + | PrLetIn ((_,dep),pred) -> + (match typ with + | IsInd (_,IndType (_,realargs)) -> + subst_predicate (realargs,if dep<>Anonymous then Some cur else None) pred + | _ -> anomaly "specialize_predicate_var") + +let ungeneralize_predicate = function + | PrLetIn _ | PrCcl _ -> anomaly "ungeneralize_predicate: expects a product" + | PrProd pred -> pred + +(*****************************************************************************) +(* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *) +(* and we want to abstract P over y:t(x) typed in the same context to get *) +(* *) +(* pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y'] *) +(* *) +(* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x' *) +(* then we have to replace x by x' in t(x) and y by y' in P *) +(*****************************************************************************) +let generalize_predicate ny d = function + | PrLetIn ((names,dep as tm),pred) -> + if dep=Anonymous then anomaly "Undetected dependency"; + let p = List.length names + 1 in + let pred = lift_predicate 1 pred in + let pred = regeneralize_index_predicate (ny+p+1) pred in + PrLetIn (tm, PrProd pred) + | PrProd _ | PrCcl _ -> + anomaly "generalize_predicate: expects a non trivial pattern" + +let rec extract_predicate l = function + | pred, Alias (deppat,nondeppat,_,_)::tms -> + let tms' = match kind_of_term nondeppat with + | Rel i -> replace_tomatch i deppat tms + | _ -> (* initial terms are not dependent *) tms in + extract_predicate l (pred,tms') + | PrProd pred, Abstract d'::tms -> + let d' = map_rel_declaration (lift (List.length l)) d' in + substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms))) + | PrLetIn (([],dep),pred), Pushed ((cur,_),_)::tms -> + extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms) + | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms -> + let l = List.rev realargs@l in + extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms) + | PrCcl ccl, [] -> + substl l ccl + | _ -> anomaly"extract_predicate: predicate inconsistent with terms to match" + +let abstract_predicate env sigma indf cur tms = function + | (PrProd _ | PrCcl _) -> anomaly "abstract_predicate: must be some LetIn" + | PrLetIn ((names,dep),pred) -> + let sign = make_arity_signature env true indf in + (* n is the number of real args + 1 *) + let n = List.length sign in + let tms = lift_tomatch_stack n tms in + let tms = + match kind_of_term cur with + | Rel i -> regeneralize_index_tomatch (i+n) tms + | _ -> (* Initial case *) tms in + (* Depending on whether the predicate is dependent or not, and has real + args or not, we lift it to make room for [sign] *) + (* Even if not intrinsically dep, we move the predicate into a dep one *) + let sign,k = + if names = [] & n <> 1 then + (* Real args were not considered *) + (if dep<>Anonymous then + ((let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign),n-1) + else + (sign,n)) + else + (* Real args are OK *) + (List.map2 (fun na (_,c,t) -> (na,c,t)) (dep::names) sign, + if dep<>Anonymous then 0 else 1) in + let pred = lift_predicate k pred in + let pred = extract_predicate [] (pred,tms) in + (true, it_mkLambda_or_LetIn_name env pred sign) + +let rec known_dependent = function + | None -> false + | Some (PrLetIn ((_,dep),_)) -> dep<>Anonymous + | Some (PrCcl _) -> false + | Some (PrProd _) -> + anomaly "known_dependent: can only be used when patterns remain" + +(* [expand_arg] is used by [specialize_predicate] + it replaces gamma, x1...xn, x1...xk |- pred + by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or + by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *) + +let expand_arg n alreadydep (na,t) deps (k,pred) = + (* current can occur in pred even if the original problem is not dependent *) + let dep = + if alreadydep<>Anonymous then alreadydep + else if deps = [] && noccurn_predicate 1 pred then Anonymous + else Name (id_of_string "x") in + let pred = if dep<>Anonymous then pred else lift_predicate (-1) pred in + (* There is no dependency in realargs for subpattern *) + (k-1, PrLetIn (([],dep), pred)) + + +(*****************************************************************************) +(* pred = [X:=realargs;x:=c]P types the following problem: *) +(* *) +(* Gamma |- match Pushed(c:I(realargs)) rest with...end: pred *) +(* *) +(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi) *) +(* is considered. Assume each Ti is some Ii(argsi). *) +(* We let e=Ci(x1,...,xn) and replace pred by *) +(* *) +(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *) +(* *) +(* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*) +(* *) +(*****************************************************************************) +let specialize_predicate tomatchs deps cs = function + | (PrProd _ | PrCcl _) -> + anomaly "specialize_predicate: a matched pattern must be pushed" + | PrLetIn ((names,isdep),pred) -> + (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *) + let nrealargs = List.length names in + let k = nrealargs + (if isdep<>Anonymous then 1 else 0) in + (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt) |- pred' *) + let n = cs.cs_nargs in + let pred' = liftn_predicate n (k+1) pred in + let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in + let copti = if isdep<>Anonymous then Some (build_dependent_constructor cs) else None in + (* The substituends argsi, copti are all defined in gamma, x1...xn *) + (* We need _parallel_ bindings to get gamma, x1...xn |- pred'' *) + let pred'' = subst_predicate (argsi, copti) pred' in + (* We adjust pred st: gamma, x1..xn, x1..xn |- pred'' *) + let pred''' = liftn_predicate n (n+1) pred'' in + (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*) + snd (List.fold_right2 (expand_arg n isdep) tomatchs deps (n,pred''')) + +let find_predicate loc env isevars p typs cstrs current + (IndType (indf,realargs)) tms = + let (dep,pred) = + match p with + | Some p -> abstract_predicate env ( !isevars) indf current tms p + | None -> infer_predicate loc env isevars typs cstrs indf in + let typ = whd_beta ( !isevars) (applist (pred, realargs)) in + if dep then + (pred, whd_beta ( !isevars) (applist (typ, [current])), + new_Type ()) + else + (pred, typ, new_Type ()) + +(************************************************************************) +(* Sorting equations by constructor *) + +type inversion_problem = + (* the discriminating arg in some Ind and its order in Ind *) + | Incompatible of int * (int * int) + | Constraints of (int * constr) list + +let solve_constraints constr_info indt = + (* TODO *) + Constraints [] + +let rec irrefutable env = function + | PatVar (_,name) -> true + | PatCstr (_,cstr,args,_) -> + let ind = inductive_of_constructor cstr in + let (_,mip) = Inductive.lookup_mind_specif env ind in + let one_constr = Array.length mip.mind_user_lc = 1 in + one_constr & List.for_all (irrefutable env) args + +let first_clause_irrefutable env = function + | eqn::mat -> List.for_all (irrefutable env) eqn.patterns + | _ -> false + +let group_equations pb ind current cstrs mat = + let mat = + if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in + let brs = Array.create (Array.length cstrs) [] in + let only_default = ref true in + let _ = + List.fold_right (* To be sure it's from bottom to top *) + (fun eqn () -> + let rest = remove_current_pattern eqn in + let pat = current_pattern eqn in + match check_and_adjust_constructor pb.env ind cstrs pat with + | PatVar (_,name) -> + (* This is a default clause that we expand *) + for i=1 to Array.length cstrs do + let n = cstrs.(i-1).cs_nargs in + let args = make_anonymous_patvars n in + brs.(i-1) <- (args, rest) :: brs.(i-1) + done + | PatCstr (loc,((_,i)),args,_) -> + (* This is a regular clause *) + only_default := false; + brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in + (brs,!only_default) + +(************************************************************************) +(* Here starts the pattern-matching compilation algorithm *) + +(* Abstracting over dependent subterms to match *) +let rec generalize_problem pb = function + | [] -> pb + | i::l -> + let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in + let pb' = generalize_problem pb l in + let tomatch = lift_tomatch_stack 1 pb'.tomatch in + let tomatch = regeneralize_index_tomatch (i+1) tomatch in + { pb with + tomatch = Abstract d :: tomatch; + pred = Option.map (generalize_predicate i d) pb'.pred } + +(* No more patterns: typing the right-hand-side of equations *) +let build_leaf pb = + let rhs = extract_rhs pb in + let tycon = match pb.pred with + | None -> anomaly "Predicate not found" + | Some (PrCcl typ) -> mk_tycon typ + | Some _ -> anomaly "not all parameters of pred have been consumed" in + pb.typing_function tycon rhs.rhs_env rhs.it + +(* Building the sub-problem when all patterns are variables *) +let shift_problem (current,t) pb = + {pb with + tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch; + pred = Option.map (specialize_predicate_var (current,t)) pb.pred; + history = push_history_pattern 0 AliasLeaf pb.history; + mat = List.map remove_current_pattern pb.mat } + +(* Building the sub-pattern-matching problem for a given branch *) +let build_branch current deps pb eqns const_info = + (* We remember that we descend through a constructor *) + let alias_type = + if Array.length const_info.cs_concl_realargs = 0 + & not (known_dependent pb.pred) & deps = [] + then + NonDepAlias + else + DepAlias + in + let history = + push_history_pattern const_info.cs_nargs + (AliasConstructor const_info.cs_cstr) + pb.history in + + (* We find matching clauses *) + let cs_args = (*assums_of_rel_context*) const_info.cs_args in + let names = get_names pb.env cs_args eqns in + let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in + if submat = [] then + raise_pattern_matching_error + (dummy_loc, pb.env, NonExhaustive (complete_history history)); + let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in + let _,typs',_ = + List.fold_right + (fun (na,c,t as d) (env,typs,tms) -> + let tm1 = List.map List.hd tms in + let tms = List.map List.tl tms in + (push_rel d env, (na,to_mutind env pb.isevars tm1 c t)::typs,tms)) + typs (pb.env,[],List.map fst eqns) in + + let dep_sign = + find_dependencies_signature + (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in + + (* The dependent term to subst in the types of the remaining UnPushed + terms is relative to the current context enriched by topushs *) + let ci = build_dependent_constructor const_info in + + (* We replace [(mkRel 1)] by its expansion [ci] *) + (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *) + (* This is done in two steps : first from "Gamma |- tms" *) + (* into "Gamma; typs; curalias |- tms" *) + let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in + + let currents = + list_map2_i + (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps)) + 1 typs' (List.rev dep_sign) in + + let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in + let ind = + appvect ( + applist (mkInd (inductive_of_constructor const_info.cs_cstr), + List.map (lift const_info.cs_nargs) const_info.cs_params), + const_info.cs_concl_realargs) in + + let cur_alias = lift (List.length sign) current in + let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in + let env' = push_rels sign pb.env in + let pred' = Option.map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in + sign, + { pb with + env = env'; + tomatch = List.rev_append currents tomatch; + pred = pred'; + history = history; + mat = List.map (push_rels_eqn_with_names sign) submat } + +(********************************************************************** + INVARIANT: + + pb = { env, subst, tomatch, mat, ...} + tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T) + + "Pushed" terms and types are relative to env + "Abstract" types are relative to env enriched by the previous terms to match + +*) + +(**********************************************************************) +(* Main compiling descent *) +let rec compile pb = + match pb.tomatch with + | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur + | (Alias x)::rest -> compile_alias pb x rest + | (Abstract d)::rest -> compile_generalization pb d rest + | [] -> build_leaf pb + +and match_current pb tomatch = + let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in + match typ with + | NotInd (_,typ) -> + check_all_variables typ pb.mat; + compile (shift_problem ct pb) + | IsInd (_,(IndType(indf,realargs) as indt)) -> + let mind,_ = dest_ind_family indf in + let cstrs = get_constructors pb.env indf in + let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in + if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt then + compile (shift_problem ct pb) + else + let _constraints = Array.map (solve_constraints indt) cstrs in + + (* We generalize over terms depending on current term to match *) + let pb = generalize_problem pb deps in + + (* We compile branches *) + let brs = array_map2 (compile_branch current deps pb) eqns cstrs in + + (* We build the (elementary) case analysis *) + let brvals = Array.map (fun (v,_) -> v) brs in + let brtyps = Array.map (fun (_,t) -> t) brs in + let (pred,typ,s) = + find_predicate pb.caseloc pb.env pb.isevars + pb.pred brtyps cstrs current indt pb.tomatch in + let ci = make_case_info pb.env mind pb.casestyle in + let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in + let inst = List.map mkRel deps in + { uj_val = applist (case, inst); + uj_type = substl inst typ } + +and compile_branch current deps pb eqn cstr = + let sign, pb = build_branch current deps pb eqn cstr in + let j = compile pb in + (it_mkLambda_or_LetIn j.uj_val sign, j.uj_type) + +and compile_generalization pb d rest = + let pb = + { pb with + env = push_rel d pb.env; + tomatch = rest; + pred = Option.map ungeneralize_predicate pb.pred; + mat = List.map (push_rels_eqn [d]) pb.mat } in + let j = compile pb in + { uj_val = mkLambda_or_LetIn d j.uj_val; + uj_type = mkProd_or_LetIn d j.uj_type } + +and compile_alias pb (deppat,nondeppat,d,t) rest = + let history = simplify_history pb.history in + let sign, newenv, mat = + insert_aliases pb.env ( !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in + let n = List.length sign in + + (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *) + (* Gamma1; x:current; Gamma2; typs; x':=curalias |- tomatch(x') *) + let tomatch = lift_tomatch_stack n rest in + let tomatch = match kind_of_term nondeppat with + | Rel i -> + if n = 1 then regeneralize_index_tomatch (i+n) tomatch + else replace_tomatch i deppat tomatch + | _ -> (* initial terms are not dependent *) tomatch in + + let pb = + {pb with + env = newenv; + tomatch = tomatch; + pred = Option.map (lift_predicate n) pb.pred; + history = history; + mat = mat } in + let j = compile pb in + List.fold_left mkSpecialLetInJudge j sign + +(* pour les alias des initiaux, enrichir les env de ce qu'il faut et +substituer après par les initiaux *) + +(**************************************************************************) +(* Preparation of the pattern-matching problem *) + +(* builds the matrix of equations testing that each eqn has n patterns + * and linearizing the _ patterns. + * Syntactic correctness has already been done in astterm *) +let matx_of_eqns env eqns = + let build_eqn (loc,ids,lpat,rhs) = + let rhs = + { rhs_env = env; + avoid_ids = ids@(ids_of_named_context (named_context env)); + it = rhs; + } in + { patterns = lpat; + alias_stack = []; + eqn_loc = loc; + used = ref false; + rhs = rhs } + in List.map build_eqn eqns + +(************************************************************************) +(* preparing the elimination predicate if any *) + +let oldprepare_predicate_from_tycon loc dep env isevars tomatchs sign c = + let cook (n, l, env, signs) = function + | c,IsInd (_,IndType(indf,realargs)) -> + let indf' = lift_inductive_family n indf in + let sign = make_arity_signature env dep indf' in + let p = List.length realargs in + if dep then + (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs) + else + (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs) + | c,NotInd _ -> + (n, l, env, []::signs) in + let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in + let names = List.rev (List.map (List.map pi1) signs) in + let allargs = + List.map (fun c -> lift n (nf_betadeltaiota env ( !isevars) c)) allargs in + let rec build_skeleton env c = + (* Don't put into normal form, it has effects on the synthesis of evars *) + (* let c = whd_betadeltaiota env ( isevars) c in *) + (* We turn all subterms possibly dependent into an evar with maximum ctxt*) + if isEvar c or List.exists (eq_constr c) allargs then + e_new_evar isevars env ~src:(loc, Evd.CasesType) + (Retyping.get_type_of env ( !isevars) c) + else + map_constr_with_full_binders push_rel build_skeleton env c + in + names, build_skeleton env (lift n c) + +(* Here, [pred] is assumed to be in the context built from all *) +(* realargs and terms to match *) +let build_initial_predicate isdep allnames pred = + let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in + let rec buildrec n pred = function + | [] -> PrCcl pred + | names::lnames -> + let names' = if isdep then List.tl names else names in + let n' = n + List.length names' in + let pred, p, user_p = + if isdep then + if dependent (mkRel (nar-n')) pred then pred, 1, 1 + else liftn (-1) (nar-n') pred, 0, 1 + else pred, 0, 0 in + let na = + if p=1 then + let na = List.hd names in + if na = Anonymous then + (* peut arriver en raison des evars *) + Name (id_of_string "x") (*Hum*) + else na + else Anonymous in + PrLetIn ((names',na), buildrec (n'+user_p) pred lnames) + in buildrec 0 pred allnames + +let extract_arity_signature env0 tomatchl tmsign = + let get_one_sign n tm (na,t) = + match tm with + | NotInd (bo,typ) -> + (match t with + | None -> [na,Option.map (lift n) bo,lift n typ] + | Some (loc,_,_,_) -> + user_err_loc (loc,"", + str "Unexpected type annotation for a term of non inductive type")) + | IsInd (_,IndType(indf,realargs)) -> + let indf' = lift_inductive_family n indf in + let (ind,params) = dest_ind_family indf' in + let nrealargs = List.length realargs in + let realnal = + match t with + | Some (loc,ind',nparams,realnal) -> + if ind <> ind' then + user_err_loc (loc,"",str "Wrong inductive type"); + if List.length params <> nparams + or nrealargs <> List.length realnal then + anomaly "Ill-formed 'in' clause in cases"; + List.rev realnal + | None -> list_tabulate (fun _ -> Anonymous) nrealargs in + let arsign = fst (get_arity env0 indf') in + (na,None,build_dependent_inductive env0 indf') + ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in + let rec buildrec n = function + | [],[] -> [] + | (_,tm)::ltm, x::tmsign -> + let l = get_one_sign n tm x in + l :: buildrec (n + List.length l) (ltm,tmsign) + | _ -> assert false + in List.rev (buildrec 0 (tomatchl,tmsign)) + +let extract_arity_signatures env0 tomatchl tmsign = + let get_one_sign tm (na,t) = + match tm with + | NotInd (bo,typ) -> + (match t with + | None -> [na,bo,typ] + | Some (loc,_,_,_) -> + user_err_loc (loc,"", + str "Unexpected type annotation for a term of non inductive type")) + | IsInd (_,IndType(indf,realargs)) -> + let (ind,params) = dest_ind_family indf in + let nrealargs = List.length realargs in + let realnal = + match t with + | Some (loc,ind',nparams,realnal) -> + if ind <> ind' then + user_err_loc (loc,"",str "Wrong inductive type"); + if List.length params <> nparams + or nrealargs <> List.length realnal then + anomaly "Ill-formed 'in' clause in cases"; + List.rev realnal + | None -> list_tabulate (fun _ -> Anonymous) nrealargs in + let arsign = fst (get_arity env0 indf) in + (na,None,build_dependent_inductive env0 indf) + ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign with _ -> assert false) in + let rec buildrec = function + | [],[] -> [] + | (_,tm)::ltm, x::tmsign -> + let l = get_one_sign tm x in + l :: buildrec (ltm,tmsign) + | _ -> assert false + in List.rev (buildrec (tomatchl,tmsign)) + +let inh_conv_coerce_to_tycon loc env isevars j tycon = + match tycon with + | Some p -> + let (evd',j) = Coercion.inh_conv_coerce_to loc env !isevars j p in + isevars := evd'; + j + | None -> j + +let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false) + +let string_of_name name = + match name with + | Anonymous -> "anonymous" + | Name n -> string_of_id n + +let id_of_name n = id_of_string (string_of_name n) + +let make_prime_id name = + let str = string_of_name name in + id_of_string str, id_of_string (str ^ "'") + +let prime avoid name = + let previd, id = make_prime_id name in + previd, next_ident_away id avoid + +let make_prime avoid prevname = + let previd, id = prime !avoid prevname in + avoid := id :: !avoid; + previd, id + +let eq_id avoid id = + let hid = id_of_string ("Heq_" ^ string_of_id id) in + let hid' = next_ident_away hid avoid in + hid' + +let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |]) +let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |]) +let mk_JMeq typ x typ' y = + mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |]) +let mk_JMeq_refl typ x = mkApp (Lazy.force Subtac_utils.jmeq_refl, [| typ; x |]) + +let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true)) + +let constr_of_pat env isevars arsign pat avoid = + let rec typ env (ty, realargs) pat avoid = + match pat with + | PatVar (l,name) -> + let name, avoid = match name with + Name n -> name, avoid + | Anonymous -> + let previd, id = prime avoid (Name (id_of_string "wildcard")) in + Name id, id :: avoid + in + PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid + | PatCstr (l,((_, i) as cstr),args,alias) -> + let cind = inductive_of_constructor cstr in + let IndType (indf, _) = + try find_rectype env ( !isevars) (lift (-(List.length realargs)) ty) + with Not_found -> error_case_not_inductive env + {uj_val = ty; uj_type = Typing.type_of env !isevars ty} + in + let ind, params = dest_ind_family indf in + if ind <> cind then error_bad_constructor_loc l cstr ind; + let cstrs = get_constructors env indf in + let ci = cstrs.(i-1) in + let nb_args_constr = ci.cs_nargs in + assert(nb_args_constr = List.length args); + let patargs, args, sign, env, n, m, avoid = + List.fold_right2 + (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid) -> + let pat', sign', arg', typ', argtypargs, n', avoid = + typ env (lift (n - m) t, []) ua avoid + in + let args' = arg' :: List.map (lift n') args in + let env' = push_rels sign' env in + (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid)) + ci.cs_args (List.rev args) ([], [], [], env, 0, 0, avoid) + in + let args = List.rev args in + let patargs = List.rev patargs in + let pat' = PatCstr (l, cstr, patargs, alias) in + let cstr = mkConstruct ci.cs_cstr in + let app = applistc cstr (List.map (lift (List.length sign)) params) in + let app = applistc app args in + let apptype = Retyping.get_type_of env ( !isevars) app in + let IndType (indf, realargs) = find_rectype env ( !isevars) apptype in + match alias with + Anonymous -> + pat', sign, app, apptype, realargs, n, avoid + | Name id -> + let sign = (alias, None, lift m ty) :: sign in + let avoid = id :: avoid in + let sign, i, avoid = + try + let env = push_rels sign env in + isevars := the_conv_x_leq (push_rels sign env) (lift (succ m) ty) (lift 1 apptype) !isevars; + let eq_t = mk_eq (lift (succ m) ty) + (mkRel 1) (* alias *) + (lift 1 app) (* aliased term *) + in + let neq = eq_id avoid id in + (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid + with Reduction.NotConvertible -> sign, 1, avoid + in + (* Mark the equality as a hole *) + pat', sign, lift i app, lift i apptype, realargs, n + i, avoid + in + let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in + pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid + + +(* shadows functional version *) +let eq_id avoid id = + let hid = id_of_string ("Heq_" ^ string_of_id id) in + let hid' = next_ident_away hid !avoid in + avoid := hid' :: !avoid; + hid' + +let rels_of_patsign = + List.map (fun ((na, b, t) as x) -> + match b with + | Some t' when kind_of_term t' = Rel 0 -> (na, None, t) + | _ -> x) + +let vars_of_ctx ctx = + let _, y = + List.fold_right (fun (na, b, t) (prev, vars) -> + match b with + | Some t' when kind_of_term t' = Rel 0 -> + prev, + (RApp (dummy_loc, + (RRef (dummy_loc, Lazy.force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars + | _ -> + match na with + Anonymous -> raise (Invalid_argument "vars_of_ctx") + | Name n -> n, RVar (dummy_loc, n) :: vars) + ctx (id_of_string "vars_of_ctx_error", []) + in List.rev y + +let rec is_included x y = + match x, y with + | PatVar _, _ -> true + | _, PatVar _ -> true + | PatCstr (l, (_, i), args, alias), PatCstr (l', (_, i'), args', alias') -> + if i = i' then List.for_all2 is_included args args' + else false + +(* liftsign is the current pattern's complete signature length. Hence pats is already typed in its + full signature. However prevpatterns are in the original one signature per pattern form. + *) +let build_ineqs prevpatterns pats liftsign = + let _tomatchs = List.length pats in + let diffs = + List.fold_left + (fun c eqnpats -> + let acc = List.fold_left2 + (* ppat is the pattern we are discriminating against, curpat is the current one. *) + (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) + (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) -> + match acc with + None -> None + | Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *) + if is_included curpat ppat then + (* Length of previous pattern's signature *) + let lens = List.length ppat_sign in + (* Accumulated length of previous pattern's signatures *) + let len' = lens + len in + let acc = + ((* Jump over previous prevpat signs *) + lift_rel_context len ppat_sign @ sign, + len', + succ n, (* nth pattern *) + mkApp (Lazy.force eq_ind, + [| lift (len' + liftsign) curpat_ty; + liftn (len + liftsign) (succ lens) ppat_c ; + lift len' curpat_c |]) :: + List.map (lift lens (* Jump over this prevpat signature *)) c) + in Some acc + else None) + (Some ([], 0, 0, [])) eqnpats pats + in match acc with + None -> c + | Some (sign, len, _, c') -> + let conj = it_mkProd_or_LetIn (mk_not (mk_conj c')) + (lift_rel_context liftsign sign) + in + conj :: c) + [] prevpatterns + in match diffs with [] -> None + | _ -> Some (mk_conj diffs) + +let subst_rel_context k ctx subst = + let (_, ctx') = + List.fold_right + (fun (n, b, t) (k, acc) -> + (succ k, (n, Option.map (substnl subst k) b, substnl subst k t) :: acc)) + ctx (k, []) + in ctx' + +let lift_rel_contextn n k sign = + let rec liftrec k = function + | (na,c,t)::sign -> + (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) + | [] -> [] + in + liftrec (rel_context_length sign + k) sign + +let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = + let i = ref 0 in + let (x, y, z) = + List.fold_left + (fun (branches, eqns, prevpatterns) eqn -> + let _, newpatterns, pats = + List.fold_left2 + (fun (idents, newpatterns, pats) pat arsign -> + let pat', cpat, idents = constr_of_pat env isevars arsign pat idents in + (idents, pat' :: newpatterns, cpat :: pats)) + ([], [], []) eqn.patterns sign + in + let newpatterns = List.rev newpatterns and opats = List.rev pats in + let rhs_rels, pats, signlen = + List.fold_left + (fun (renv, pats, n) (sign,c, (s, args), p) -> + (* Recombine signatures and terms of all of the row's patterns *) + let sign' = lift_rel_context n sign in + let len = List.length sign' in + (sign' @ renv, + (* lift to get outside of previous pattern's signatures. *) + (sign', liftn n (succ len) c, (s, List.map (liftn n (succ len)) args), p) :: pats, + len + n)) + ([], [], 0) opats in + let pats, _ = List.fold_left + (* lift to get outside of past patterns to get terms in the combined environment. *) + (fun (pats, n) (sign, c, (s, args), p) -> + let len = List.length sign in + ((rels_of_patsign sign, lift n c, (s, List.map (lift n) args), p) :: pats, len + n)) + ([], 0) pats + in + let ineqs = build_ineqs prevpatterns pats signlen in + let rhs_rels' = rels_of_patsign rhs_rels in + let _signenv = push_rel_context rhs_rels' env in + let arity = + let args, nargs = + List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> + (args @ c :: allargs, List.length args + succ n)) + pats ([], 0) + in + let args = List.rev args in + substl args (liftn signlen (succ nargs) arity) + in + let rhs_rels', tycon = + let neqs_rels, arity = + match ineqs with + | None -> [], arity + | Some ineqs -> + [Anonymous, None, ineqs], lift 1 arity + in + let eqs_rels, arity = decompose_prod_n_assum neqs arity in + eqs_rels @ neqs_rels @ rhs_rels', arity + in + let rhs_env = push_rels rhs_rels' env in + let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in + let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' + and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in + let branch_name = id_of_string ("branch_" ^ (string_of_int !i)) in + let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in + let branch = + let bref = RVar (dummy_loc, branch_name) in + match vars_of_ctx rhs_rels with + [] -> bref + | l -> RApp (dummy_loc, bref, l) + in + let branch = match ineqs with + Some _ -> RApp (dummy_loc, branch, [ hole ]) + | None -> branch + in + incr i; + let rhs = { eqn.rhs with it = branch } in + (branch_decl :: branches, + { eqn with patterns = newpatterns; rhs = rhs } :: eqns, + opats :: prevpatterns)) + ([], [], []) eqns + in x, y + +(* Builds the predicate. If the predicate is dependent, its context is + * made of 1+nrealargs assumptions for each matched term in an inductive + * type and 1 assumption for each term not _syntactically_ in an + * inductive type. + + * Each matched terms are independently considered dependent or not. + + * A type constraint but no annotation case: it is assumed non dependent. + *) + +let lift_ctx n ctx = + let ctx', _ = + List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0) + in ctx' + +(* Turn matched terms into variables. *) +let abstract_tomatch env tomatchs tycon = + let prev, ctx, names, tycon = + List.fold_left + (fun (prev, ctx, names, tycon) (c, t) -> + let lenctx = List.length ctx in + match kind_of_term c with + Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon + | _ -> + let tycon = Option.map + (fun t -> subst_term_occ all_occurrences (lift 1 c) (lift 1 t)) tycon in + let name = next_ident_away (id_of_string "filtered_var") names in + (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, + (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, + name :: names, tycon) + ([], [], [], tycon) tomatchs + in List.rev prev, ctx, tycon + +let is_dependent_ind = function + IsInd (_, IndType (indf, args)) when List.length args > 0 -> true + | _ -> false + +let build_dependent_signature env evars avoid tomatchs arsign = + let avoid = ref avoid in + let arsign = List.rev arsign in + let allnames = List.rev (List.map (List.map pi1) arsign) in + let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in + let eqs, neqs, refls, slift, arsign' = + List.fold_left2 + (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> + (* The accumulator: + previous eqs, + number of previous eqs, + lift to get outside eqs and in the introduced variables ('as' and 'in'), + new arity signatures + *) + match ty with + IsInd (ty, IndType (indf, args)) when List.length args > 0 -> + (* Build the arity signature following the names in matched terms as much as possible *) + let argsign = List.tl arsign in (* arguments in inverse application order *) + let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *) + let argsign = List.rev argsign in (* arguments in application order *) + let env', nargeqs, argeqs, refl_args, slift, argsign' = + List.fold_left2 + (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) -> + let argt = Retyping.get_type_of env evars arg in + let eq, refl_arg = + if Reductionops.is_conv env evars argt t then + (mk_eq (lift (nargeqs + slift) argt) + (mkRel (nargeqs + slift)) + (lift (nargeqs + nar) arg), + mk_eq_refl argt arg) + else + (mk_JMeq (lift (nargeqs + slift) t) + (mkRel (nargeqs + slift)) + (lift (nargeqs + nar) argt) + (lift (nargeqs + nar) arg), + mk_JMeq_refl argt arg) + in + let previd, id = + let name = + match kind_of_term arg with + Rel n -> pi1 (lookup_rel n env) + | _ -> name + in + make_prime avoid name + in + (env, succ nargeqs, + (Name (eq_id avoid previd), None, eq) :: argeqs, + refl_arg :: refl_args, + pred slift, + (Name id, b, t) :: argsign')) + (env, 0, [], [], slift, []) args argsign + in + let eq = mk_JMeq + (lift (nargeqs + slift) appt) + (mkRel (nargeqs + slift)) + (lift (nargeqs + nar) ty) + (lift (nargeqs + nar) tm) + in + let refl_eq = mk_JMeq_refl ty tm in + let previd, id = make_prime avoid appn in + (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs, + succ nargeqs, + refl_eq :: refl_args, + pred slift, + (((Name id, appb, appt) :: argsign') :: arsigns)) + + | _ -> + (* Non dependent inductive or not inductive, just use a regular equality *) + let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in + let previd, id = make_prime avoid name in + let arsign' = (Name id, b, typ) in + let tomatch_ty = type_of_tomatch ty in + let eq = + mk_eq (lift nar tomatch_ty) + (mkRel slift) (lift nar tm) + in + ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, + (mk_eq_refl tomatch_ty tm) :: refl_args, + pred slift, (arsign' :: []) :: arsigns)) + ([], 0, [], nar, []) tomatchs arsign + in + let arsign'' = List.rev arsign' in + assert(slift = 0); (* we must have folded over all elements of the arity signature *) + arsign'', allnames, nar, eqs, neqs, refls + +(**************************************************************************) +(* Main entry of the matching compilation *) + +let liftn_rel_context n k sign = + let rec liftrec k = function + | (na,c,t)::sign -> + (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) + | [] -> [] + in + liftrec (k + rel_context_length sign) sign + +let nf_evars_env sigma (env : env) : env = + let nf t = nf_evar sigma t in + let env0 : env = reset_context env in + let f e (na, b, t) e' : env = + Environ.push_named (na, Option.map nf b, nf t) e' + in + let env' = Environ.fold_named_context f ~init:env0 env in + Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, Option.map nf b, nf t) e') + ~init:env' env + + +let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp = + (* We extract the signature of the arity *) + let arsign = extract_arity_signature env tomatchs sign in + let newenv = List.fold_right push_rels arsign env in + let allnames = List.rev (List.map (List.map pi1) arsign) in + match rtntyp with + | Some rtntyp -> + let predcclj = typing_fun (mk_tycon (new_Type ())) newenv rtntyp in + let predccl = (j_nf_evar !isevars predcclj).uj_val in + Some (build_initial_predicate true allnames predccl) + | None -> + match valcon_of_tycon tycon with + | Some ty -> + let pred = + prepare_predicate_from_arsign_tycon loc env !isevars tomatchs arsign ty + in Some (build_initial_predicate true allnames pred) + | None -> None + +let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns) = + + let typing_fun tycon env = typing_fun tycon env isevars in + + (* We build the matrix of patterns and right-hand-side *) + let matx = matx_of_eqns env eqns in + + (* We build the vector of terms to match consistently with the *) + (* constructors found in patterns *) + let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in + let _isdep = List.exists (fun (x, y) -> is_dependent_ind y) tomatchs in + if predopt = None then + let tycon = valcon_of_tycon tycon in + let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env tomatchs tycon in + let env = push_rel_context tomatchs_lets env in + let len = List.length eqns in + let sign, allnames, signlen, eqs, neqs, args = + (* The arity signature *) + let arsign = extract_arity_signatures env tomatchs (List.map snd tomatchl) in + (* Build the dependent arity signature, the equalities which makes + the first part of the predicate and their instantiations. *) + let avoid = [] in + build_dependent_signature env ( !isevars) avoid tomatchs arsign + + in + let tycon, arity = + match tycon' with + | None -> let ev = mkExistential env isevars in ev, ev + | Some t -> + Option.get tycon, prepare_predicate_from_arsign_tycon loc env ( !isevars) + tomatchs sign t + in + let neqs, arity = + let ctx = context_of_arsign eqs in + let neqs = List.length ctx in + neqs, it_mkProd_or_LetIn (lift neqs arity) ctx + in + let lets, matx = + (* Type the rhs under the assumption of equations *) + constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity + in + let matx = List.rev matx in + let _ = assert(len = List.length lets) in + let env = push_rels lets env in + let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in + let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in + let args = List.rev_map (lift len) args in + let pred = liftn len (succ signlen) arity in + let pred = build_initial_predicate true allnames pred in + + (* We push the initial terms to match and push their alias to rhs' envs *) + (* names of aliases will be recovered from patterns (hence Anonymous here) *) + let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in + + let pb = + { env = env; + isevars = isevars; + pred = Some pred; + tomatch = initial_pushed; + history = start_history (List.length initial_pushed); + mat = matx; + caseloc = loc; + casestyle= style; + typing_function = typing_fun } in + + let j = compile pb in + (* We check for unused patterns *) + List.iter (check_unused_pattern env) matx; + let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in + let j = + { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; + uj_type = nf_evar !isevars tycon; } + in j + else + (* We build the elimination predicate if any and check its consistency *) + (* with the type of arguments to match *) + let tmsign = List.map snd tomatchl in + let pred = prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs tmsign tycon predopt in + + (* We push the initial terms to match and push their alias to rhs' envs *) + (* names of aliases will be recovered from patterns (hence Anonymous here) *) + let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in + let pb = + { env = env; + isevars = isevars; + pred = pred; + tomatch = initial_pushed; + history = start_history (List.length initial_pushed); + mat = matx; + caseloc = loc; + casestyle= style; + typing_function = typing_fun } in + + let j = compile pb in + (* We check for unused patterns *) + List.iter (check_unused_pattern env) matx; + inh_conv_coerce_to_tycon loc env isevars j tycon + +end + diff --git a/plugins/subtac/subtac_cases.mli b/plugins/subtac/subtac_cases.mli new file mode 100644 index 00000000..90989d2d --- /dev/null +++ b/plugins/subtac/subtac_cases.mli @@ -0,0 +1,23 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* SPretyping.understand_tcc_evars evdref env IsType t) + (SPretyping.understand_judgment_tcc evdref) !evdref env params + +let type_ctx_instance evars env ctx inst subst = + let rec aux (subst, instctx) l = function + (na, b, t) :: ctx -> + let t' = substl subst t in + let c', l = + match b with + | None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l + | Some b -> substl subst b, l + in + evars := resolve_typeclasses ~onlyargs:true ~fail:true env !evars; + let d = na, Some c', t' in + aux (c' :: subst, d :: instctx) l ctx + | [] -> subst + in aux (subst, []) inst (List.rev ctx) + +let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) pri = + let env = Global.env() in + let evars = ref Evd.empty in + let tclass, _ = + match bk with + | Implicit -> + Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *) + ~allow_partial:false (fun avoid (clname, (id, _, t)) -> + match clname with + | Some (cl, b) -> + let t = + if b then + let _k = class_info cl in + CHole (Util.dummy_loc, Some Evd.InternalHole) + else CHole (Util.dummy_loc, None) + in t, avoid + | None -> failwith ("new instance: under-applied typeclass")) + cl + | Explicit -> cl, Idset.empty + in + let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in + let k, cty, ctx', ctx, len, imps, subst = + let (env', ctx), imps = interp_context_evars evars env ctx in + let c', imps' = interp_type_evars_impls ~evdref:evars env' tclass in + let len = List.length ctx in + let imps = imps @ Impargs.lift_implicits len imps' in + let ctx', c = decompose_prod_assum c' in + let ctx'' = ctx' @ ctx in + let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in + let _, args = + List.fold_right (fun (na, b, t) (args, args') -> + match b with + | None -> (List.tl args, List.hd args :: args') + | Some b -> (args, substl args' b :: args')) + (snd cl.cl_context) (args, []) + in + cl, c', ctx', ctx, len, imps, args + in + let id = + match snd instid with + | Name id -> + let sp = Lib.make_path id in + if Nametab.exists_cci sp then + errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists"); + id + | Anonymous -> + let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in + Namegen.next_global_ident_away i (Termops.ids_of_context env) + in + let env' = push_rel_context ctx env in + evars := Evarutil.nf_evar_map !evars; + evars := resolve_typeclasses ~onlyargs:false ~fail:true env !evars; + let sigma = !evars in + let subst = List.map (Evarutil.nf_evar sigma) subst in + let props = + match props with + | CRecord (loc, _, fs) -> + if List.length fs > List.length k.cl_props then + Classes.mismatched_props env' (List.map snd fs) k.cl_props; + Inl fs + | _ -> Inr props + in + let subst = + match props with + | Inr term -> + let c = interp_casted_constr_evars evars env' term cty in + Inr (c, subst) + | Inl props -> + let get_id = + function + | Ident id' -> id' + | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled") + in + let props, rest = + List.fold_left + (fun (props, rest) (id,b,_) -> + if b = None then + try + let (loc_mid, c) = List.find (fun (id', _) -> Name (snd (get_id id')) = id) rest in + let rest' = List.filter (fun (id', _) -> Name (snd (get_id id')) <> id) rest in + let (loc, mid) = get_id loc_mid in + Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs); + c :: props, rest' + with Not_found -> + (CHole (Util.dummy_loc, None) :: props), rest + else props, rest) + ([], props) k.cl_props + in + if rest <> [] then + unbound_method env' k.cl_impl (get_id (fst (List.hd rest))) + else + Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst) + in + evars := Evarutil.nf_evar_map !evars; + let term, termtype = + match subst with + | Inl subst -> + let subst = List.fold_left2 + (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') + [] subst (k.cl_props @ snd k.cl_context) + in + let app, ty_constr = instance_constructor k subst in + let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in + let term = Termops.it_mkLambda_or_LetIn app (ctx' @ ctx) in + term, termtype + | Inr (def, subst) -> + let termtype = it_mkProd_or_LetIn cty ctx in + let term = Termops.it_mkLambda_or_LetIn def ctx in + term, termtype + in + let termtype = Evarutil.nf_evar !evars termtype in + let term = Evarutil.nf_evar !evars term in + evars := undefined_evars !evars; + Evarutil.check_evars env Evd.empty !evars termtype; + let hook vis gr = + let cst = match gr with ConstRef kn -> kn | _ -> assert false in + let inst = Typeclasses.new_instance k pri global (ConstRef cst) in + Impargs.declare_manual_implicits false gr ~enriching:false imps; + Typeclasses.add_instance inst + in + let evm = Subtac_utils.evars_of_term !evars Evd.empty term in + let obls, _, constr, typ = Eterm.eterm_obligations env id !evars evm 0 term termtype in + id, Subtac_obligations.add_definition id ~term:constr typ ~kind:(Global,false,Instance) ~hook obls diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli new file mode 100644 index 00000000..ee78ff68 --- /dev/null +++ b/plugins/subtac/subtac_classes.mli @@ -0,0 +1,41 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + Environ.env -> + ('a * Term.constr option * Term.constr) list -> + Topconstr.constr_expr list -> + Term.constr list -> + Term.constr list + +val new_instance : + ?global:bool -> + local_binder list -> + typeclass_constraint -> + constr_expr -> + ?generalize:bool -> + int option -> + identifier * Subtac_obligations.progress diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml new file mode 100644 index 00000000..5337baca --- /dev/null +++ b/plugins/subtac/subtac_coercion.ml @@ -0,0 +1,503 @@ +(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + (match kind_of_term c with + Ind i -> + let len = Array.length l in + let sig_ = Lazy.force sig_ in + if len = 2 && i = Term.destInd sig_.typ + then + let (a, b) = pair_of_array l in + Some (a, b) + else None + | _ -> None) + | _ -> None + +and disc_exist env x = + match kind_of_term x with + | App (c, l) -> + (match kind_of_term c with + Construct c -> + if c = Term.destConstruct (Lazy.force sig_).intro + then Some (l.(0), l.(1), l.(2), l.(3)) + else None + | _ -> None) + | _ -> None + +module Coercion = struct + + exception NoSubtacCoercion + + let disc_proj_exist env x = + match kind_of_term x with + | App (c, l) -> + (if Term.eq_constr c (Lazy.force sig_).proj1 + && Array.length l = 3 + then disc_exist env l.(2) + else None) + | _ -> None + + + let sort_rel s1 s2 = + match s1, s2 with + Prop Pos, Prop Pos -> Prop Pos + | Prop Pos, Prop Null -> Prop Null + | Prop Null, Prop Null -> Prop Null + | Prop Null, Prop Pos -> Prop Pos + | Type _, Prop Pos -> Prop Pos + | Type _, Prop Null -> Prop Null + | _, Type _ -> s2 + + let hnf env isevars c = whd_betadeltaiota env ( !isevars) c + + let lift_args n sign = + let rec liftrec k = function + | t::sign -> liftn n k t :: (liftrec (k-1) sign) + | [] -> [] + in + liftrec (List.length sign) sign + + let rec mu env isevars t = + let isevars = ref isevars in + let rec aux v = + let v = hnf env isevars v in + match disc_subset v with + Some (u, p) -> + let f, ct = aux u in + (Some (fun x -> + app_opt f (mkApp ((Lazy.force sig_).proj1, + [| u; p; x |]))), + ct) + | None -> (None, v) + in aux t + + and coerce loc env isevars (x : Term.constr) (y : Term.constr) + : (Term.constr -> Term.constr) option + = + let x = nf_evar ( !isevars) x and y = nf_evar ( !isevars) y in + let rec coerce_unify env x y = + let x = hnf env isevars x and y = hnf env isevars y in + try + isevars := the_conv_x_leq env x y !isevars; + None + with Reduction.NotConvertible -> coerce' env x y + and coerce' env x y : (Term.constr -> Term.constr) option = + let subco () = subset_coerce env isevars x y in + let dest_prod c = + match Reductionops.splay_prod_n env ( !isevars) 1 c with + | [(na,b,t)], c -> (na,t), c + | _ -> raise NoSubtacCoercion + in + let rec coerce_application typ typ' c c' l l' = + let len = Array.length l in + let rec aux tele typ typ' i co = + if i < len then + let hdx = l.(i) and hdy = l'.(i) in + try isevars := the_conv_x_leq env hdx hdy !isevars; + let (n, eqT), restT = dest_prod typ in + let (n', eqT'), restT' = dest_prod typ' in + aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co + with Reduction.NotConvertible -> + let (n, eqT), restT = dest_prod typ in + let (n', eqT'), restT' = dest_prod typ' in + let _ = + try isevars := the_conv_x_leq env eqT eqT' !isevars + with Reduction.NotConvertible -> raise NoSubtacCoercion + in + (* Disallow equalities on arities *) + if Reduction.is_arity env eqT then raise NoSubtacCoercion; + let restargs = lift_args 1 + (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) + in + let args = List.rev (restargs @ mkRel 1 :: lift_args 1 tele) in + let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in + let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in + let evar = make_existential loc env isevars eq in + let eq_app x = mkApp (Lazy.force eq_rect, + [| eqT; hdx; pred; x; hdy; evar|]) in + aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) + else Some co + in + if isEvar c || isEvar c' then + (* Second-order unification needed. *) + raise NoSubtacCoercion; + aux [] typ typ' 0 (fun x -> x) + in + match (kind_of_term x, kind_of_term y) with + | Sort s, Sort s' -> + (match s, s' with + Prop x, Prop y when x = y -> None + | Prop _, Type _ -> None + | Type x, Type y when x = y -> None (* false *) + | _ -> subco ()) + | Prod (name, a, b), Prod (name', a', b') -> + let name' = Name (Namegen.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in + let env' = push_rel (name', None, a') env in + let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in + (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) + let coec1 = app_opt c1 (mkRel 1) in + (* env, x : a' |- c1[x] : lift 1 a *) + let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in + (* env, x : a' |- c2 : b[c1[x]/x]] > b' *) + (match c1, c2 with + | None, None -> None + | _, _ -> + Some + (fun f -> + mkLambda (name', a', + app_opt c2 + (mkApp (Term.lift 1 f, [| coec1 |]))))) + + | App (c, l), App (c', l') -> + (match kind_of_term c, kind_of_term c' with + Ind i, Ind i' -> (* Inductive types *) + let len = Array.length l in + let existS = Lazy.force existS in + let prod = Lazy.force prod in + (* Sigma types *) + if len = Array.length l' && len = 2 && i = i' + && (i = Term.destInd existS.typ || i = Term.destInd prod.typ) + then + if i = Term.destInd existS.typ + then + begin + let (a, pb), (a', pb') = + pair_of_array l, pair_of_array l' + in + let c1 = coerce_unify env a a' in + let rec remove_head a c = + match kind_of_term c with + | Lambda (n, t, t') -> c, t' + (*| Prod (n, t, t') -> t'*) + | Evar (k, args) -> + let (evs, t) = Evarutil.define_evar_as_lambda !isevars (k,args) in + isevars := evs; + let (n, dom, rng) = destLambda t in + let (domk, args) = destEvar dom in + isevars := define domk a !isevars; + t, rng + | _ -> raise NoSubtacCoercion + in + let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in + let env' = push_rel (make_name "x", None, a) env in + let c2 = coerce_unify env' b b' in + match c1, c2 with + None, None -> + None + | _, _ -> + Some + (fun x -> + let x, y = + app_opt c1 (mkApp (existS.proj1, + [| a; pb; x |])), + app_opt c2 (mkApp (existS.proj2, + [| a; pb; x |])) + in + mkApp (existS.intro, [| a'; pb'; x ; y |])) + end + else + begin + let (a, b), (a', b') = + pair_of_array l, pair_of_array l' + in + let c1 = coerce_unify env a a' in + let c2 = coerce_unify env b b' in + match c1, c2 with + None, None -> None + | _, _ -> + Some + (fun x -> + let x, y = + app_opt c1 (mkApp (prod.proj1, + [| a; b; x |])), + app_opt c2 (mkApp (prod.proj2, + [| a; b; x |])) + in + mkApp (prod.intro, [| a'; b'; x ; y |])) + end + else + if i = i' && len = Array.length l' then + let evm = !isevars in + (try subco () + with NoSubtacCoercion -> + let typ = Typing.type_of env evm c in + let typ' = Typing.type_of env evm c' in + (* if not (is_arity env evm typ) then *) + coerce_application typ typ' c c' l l') + (* else subco () *) + else + subco () + | x, y when x = y -> + if Array.length l = Array.length l' then + let evm = !isevars in + let lam_type = Typing.type_of env evm c in + let lam_type' = Typing.type_of env evm c' in +(* if not (is_arity env evm lam_type) then ( *) + coerce_application lam_type lam_type' c c' l l' +(* ) else subco () *) + else subco () + | _ -> subco ()) + | _, _ -> subco () + + and subset_coerce env isevars x y = + match disc_subset x with + Some (u, p) -> + let c = coerce_unify env u y in + let f x = + app_opt c (mkApp ((Lazy.force sig_).proj1, + [| u; p; x |])) + in Some f + | None -> + match disc_subset y with + Some (u, p) -> + let c = coerce_unify env x u in + Some + (fun x -> + let cx = app_opt c x in + let evar = make_existential loc env isevars (mkApp (p, [| cx |])) + in + (mkApp + ((Lazy.force sig_).intro, + [| u; p; cx; evar |]))) + | None -> + raise NoSubtacCoercion + (*isevars := Evd.add_conv_pb (Reduction.CONV, x, y) !isevars; + None*) + in coerce_unify env x y + + let coerce_itf loc env isevars v t c1 = + let evars = ref isevars in + let coercion = coerce loc env evars t c1 in + !evars, Option.map (app_opt coercion) v + + (* Taken from pretyping/coercion.ml *) + + (* Typing operations dealing with coercions *) + + (* Here, funj is a coercion therefore already typed in global context *) + let apply_coercion_args env argl funj = + let rec apply_rec acc typ = function + | [] -> { uj_val = applist (j_val funj,argl); + uj_type = typ } + | h::restl -> + (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *) + match kind_of_term (whd_betadeltaiota env Evd.empty typ) with + | Prod (_,c1,c2) -> + (* Typage garanti par l'appel à app_coercion*) + apply_rec (h::acc) (subst1 h c2) restl + | _ -> anomaly "apply_coercion_args" + in + apply_rec [] funj.uj_type argl + + (* appliquer le chemin de coercions de patterns p *) + exception NoCoercion + + let apply_pattern_coercion loc pat p = + List.fold_left + (fun pat (co,n) -> + let f i = if i + let fv,isid = coercion_value i in + let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in + let jres = apply_coercion_args env argl fv in + (if isid then + { uj_val = ja.uj_val; uj_type = jres.uj_type } + else + jres), + jres.uj_type) + (hj,typ_cl) p) + with _ -> anomaly "apply_coercion" + + let inh_app_fun env isevars j = + let t = whd_betadeltaiota env ( isevars) j.uj_type in + match kind_of_term t with + | Prod (_,_,_) -> (isevars,j) + | Evar ev when not (is_defined_evar isevars ev) -> + let (isevars',t) = define_evar_as_product isevars ev in + (isevars',{ uj_val = j.uj_val; uj_type = t }) + | _ -> + (try + let t,p = + lookup_path_to_fun_from env ( isevars) j.uj_type in + (isevars,apply_coercion env ( isevars) p j t) + with Not_found -> + try + let coercef, t = mu env isevars t in + (isevars, { uj_val = app_opt coercef j.uj_val; uj_type = t }) + with NoSubtacCoercion | NoCoercion -> + (isevars,j)) + + let inh_tosort_force loc env isevars j = + try + let t,p = lookup_path_to_sort_from env ( isevars) j.uj_type in + let j1 = apply_coercion env ( isevars) p j t in + (isevars,type_judgment env (j_nf_evar ( isevars) j1)) + with Not_found -> + error_not_a_type_loc loc env ( isevars) j + + let inh_coerce_to_sort loc env isevars j = + let typ = whd_betadeltaiota env ( isevars) j.uj_type in + match kind_of_term typ with + | Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s }) + | Evar ev when not (is_defined_evar isevars ev) -> + let (isevars',s) = define_evar_as_sort isevars ev in + (isevars',{ utj_val = j.uj_val; utj_type = s }) + | _ -> + inh_tosort_force loc env isevars j + + let inh_coerce_to_base loc env isevars j = + let typ = whd_betadeltaiota env ( isevars) j.uj_type in + let ct, typ' = mu env isevars typ in + isevars, { uj_val = app_opt ct j.uj_val; + uj_type = typ' } + + let inh_coerce_to_prod loc env isevars t = + let typ = whd_betadeltaiota env ( isevars) (snd t) in + let _, typ' = mu env isevars typ in + isevars, (fst t, typ') + + let inh_coerce_to_fail env evd rigidonly v t c1 = + if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t) + then + raise NoCoercion + else + let v', t' = + try + let t2,t1,p = lookup_path_between env ( evd) (t,c1) in + match v with + Some v -> + let j = apply_coercion env ( evd) p + {uj_val = v; uj_type = t} t2 in + Some j.uj_val, j.uj_type + | None -> None, t + with Not_found -> raise NoCoercion + in + try (the_conv_x_leq env t' c1 evd, v') + with Reduction.NotConvertible -> raise NoCoercion + + + let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = + try (the_conv_x_leq env t c1 evd, v) + with Reduction.NotConvertible -> + try inh_coerce_to_fail env evd rigidonly v t c1 + with NoCoercion -> + match + kind_of_term (whd_betadeltaiota env ( evd) t), + kind_of_term (whd_betadeltaiota env ( evd) c1) + with + | Prod (name,t1,t2), Prod (_,u1,u2) -> + (* Conversion did not work, we may succeed with a coercion. *) + (* We eta-expand (hence possibly modifying the original term!) *) + (* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *) + (* has type forall (x:u1), u2 (with v' recursively obtained) *) + let name = match name with + | Anonymous -> Name (id_of_string "x") + | _ -> name in + let env1 = push_rel (name,None,u1) env in + let (evd', v1) = + inh_conv_coerce_to_fail loc env1 evd rigidonly + (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in + let v1 = Option.get v1 in + let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in + let t2 = Termops.subst_term v1 t2 in + let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in + (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') + | _ -> raise NoCoercion + + (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) + let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) = + match n with + None -> + let (evd', val') = + try + inh_conv_coerce_to_fail loc env evd rigidonly + (Some (nf_evar evd cj.uj_val)) + (nf_evar evd cj.uj_type) (nf_evar evd t) + with NoCoercion -> + let sigma = evd in + try + coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t + with NoSubtacCoercion -> + error_actual_type_loc loc env sigma cj t + in + let val' = match val' with Some v -> v | None -> assert(false) in + (evd',{ uj_val = val'; uj_type = t }) + | Some (init, cur) -> + (evd, cj) + + let inh_conv_coerce_to = inh_conv_coerce_to_gen false + let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true + + let inh_conv_coerces_to loc env isevars t ((abs, t') as _tycon) = + let nabsinit, nabs = + match abs with + None -> 0, 0 + | Some (init, cur) -> init, cur + in + try + let rels, rng = Reductionops.splay_prod_n env ( isevars) nabs t in + (* The final range free variables must have been replaced by evars, we accept only that evars + in rng are applied to free vars. *) + if noccur_with_meta 1 (succ nabs) rng then ( + let env', t, t' = + let env' = push_rel_context rels env in + env', rng, lift nabs t' + in + try + fst (try inh_conv_coerce_to_fail loc env' isevars false None t t' + with NoCoercion -> + coerce_itf loc env' isevars None t t') + with NoSubtacCoercion -> + let sigma = isevars in + error_cannot_coerce env' sigma (t, t')) + else isevars + with _ -> isevars +end diff --git a/plugins/subtac/subtac_coercion.mli b/plugins/subtac/subtac_coercion.mli new file mode 100644 index 00000000..5678c10e --- /dev/null +++ b/plugins/subtac/subtac_coercion.mli @@ -0,0 +1,4 @@ +open Term +val disc_subset : types -> (types * types) option + +module Coercion : Coercion.S diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml new file mode 100644 index 00000000..f2747225 --- /dev/null +++ b/plugins/subtac/subtac_command.ml @@ -0,0 +1,534 @@ +open Closure +open RedFlags +open Declarations +open Entries +open Libobject +open Pattern +open Matching +open Pp +open Rawterm +open Sign +open Tacred +open Util +open Names +open Nameops +open Libnames +open Nametab +open Pfedit +open Proof_type +open Refiner +open Tacmach +open Tactic_debug +open Topconstr +open Term +open Termops +open Tacexpr +open Safe_typing +open Typing +open Hiddentac +open Genarg +open Decl_kinds +open Mod_subst +open Printer +open Inductiveops +open Syntax_def +open Environ +open Tactics +open Tacticals +open Tacinterp +open Vernacexpr +open Notation +open Evd +open Evarutil + +module SPretyping = Subtac_pretyping.Pretyping +open Subtac_utils +open Pretyping +open Subtac_obligations + +(*********************************************************************) +(* Functions to parse and interpret constructions *) + +let evar_nf isevars c = + Evarutil.nf_evar !isevars c + +let interp_gen kind isevars env + ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[])) + c = + let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars ( !isevars) env c in + let c' = SPretyping.understand_tcc_evars isevars env kind c' in + evar_nf isevars c' + +let interp_constr isevars env c = + interp_gen (OfType None) isevars env c + +let interp_type_evars isevars env ?(impls=([],[])) c = + interp_gen IsType isevars env ~impls c + +let interp_casted_constr isevars env ?(impls=([],[])) c typ = + interp_gen (OfType (Some typ)) isevars env ~impls c + +let interp_casted_constr_evars isevars env ?(impls=([],[])) c typ = + interp_gen (OfType (Some typ)) isevars env ~impls c + +let interp_open_constr isevars env c = + msgnl (str "Pretyping " ++ my_print_constr_expr c); + let c = Constrintern.intern_constr ( !isevars) env c in + let c' = SPretyping.understand_tcc_evars isevars env (OfType None) c in + evar_nf isevars c' + +let interp_constr_judgment isevars env c = + let j = + SPretyping.understand_judgment_tcc isevars env + (Constrintern.intern_constr ( !isevars) env c) + in + { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type } + +let locate_if_isevar loc na = function + | RHole _ -> + (try match na with + | Name id -> Reserve.find_reserved_type id + | Anonymous -> raise Not_found + with Not_found -> RHole (loc, Evd.BinderType na)) + | x -> x + +let interp_binder sigma env na t = + let t = Constrintern.intern_gen true ( !sigma) env t in + SPretyping.understand_tcc_evars sigma env IsType (locate_if_isevar (loc_of_rawconstr t) na t) + +let interp_context_evars evdref env params = + let bl = Constrintern.intern_context false ( !evdref) env params in + let (env, par, _, impls) = + List.fold_left + (fun (env,params,n,impls) (na, k, b, t) -> + match b with + None -> + let t' = locate_if_isevar (loc_of_rawconstr t) na t in + let t = SPretyping.understand_tcc_evars evdref env IsType t' in + let d = (na,None,t) in + let impls = + if k = Implicit then + let na = match na with Name n -> Some n | Anonymous -> None in + (ExplByPos (n, na), (true, true, true)) :: impls + else impls + in + (push_rel d env, d::params, succ n, impls) + | Some b -> + let c = SPretyping.understand_judgment_tcc evdref env b in + let d = (na, Some c.uj_val, c.uj_type) in + (push_rel d env,d::params, succ n, impls)) + (env,[],1,[]) (List.rev bl) + in (env, par), impls + +(* try to find non recursive definitions *) + +let list_chop_hd i l = match list_chop i l with + | (l1,x::l2) -> (l1,x,l2) + | (x :: [], l2) -> ([], x, []) + | _ -> assert(false) + +let collect_non_rec env = + let rec searchrec lnonrec lnamerec ldefrec larrec nrec = + try + let i = + list_try_find_i + (fun i f -> + if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec + then i else failwith "try_find_i") + 0 lnamerec + in + let (lf1,f,lf2) = list_chop_hd i lnamerec in + let (ldef1,def,ldef2) = list_chop_hd i ldefrec in + let (lar1,ar,lar2) = list_chop_hd i larrec in + let newlnv = + try + match list_chop i nrec with + | (lnv1,_::lnv2) -> (lnv1@lnv2) + | _ -> [] (* nrec=[] for cofixpoints *) + with Failure "list_chop" -> [] + in + searchrec ((f,def,ar)::lnonrec) + (lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv + with Failure "try_find_i" -> + (List.rev lnonrec, + (Array.of_list lnamerec, Array.of_list ldefrec, + Array.of_list larrec, Array.of_list nrec)) + in + searchrec [] + +let list_of_local_binders l = + let rec aux acc = function + Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl + | Topconstr.LocalRawAssum (nl, k, c) :: tl -> + aux (List.fold_left (fun acc n -> (n, None, Some c) :: acc) acc nl) tl + | [] -> List.rev acc + in aux [] l + +let lift_binders k n l = + let rec aux n = function + | (id, t, c) :: tl -> (id, Option.map (liftn k n) t, liftn k n c) :: aux (pred n) tl + | [] -> [] + in aux n l + +let rec gen_rels = function + 0 -> [] + | n -> mkRel n :: gen_rels (pred n) + +let split_args n rel = match list_chop ((List.length rel) - n) rel with + (l1, x :: l2) -> l1, x, l2 + | _ -> assert(false) + +open Coqlib + +let sigT = Lazy.lazy_from_fun build_sigma_type +let sigT_info = lazy + { ci_ind = destInd (Lazy.force sigT).typ; + ci_npar = 2; + ci_cstr_nargs = [|2|]; + ci_pp_info = { ind_nargs = 0; style = LetStyle } + } + +let telescope = function + | [] -> assert false + | [(n, None, t)] -> t, [n, Some (mkRel 1), t], mkRel 1 + | (n, None, t) :: tl -> + let ty, tys, (k, constr) = + List.fold_left + (fun (ty, tys, (k, constr)) (n, b, t) -> + let pred = mkLambda (n, t, ty) in + let sigty = mkApp ((Lazy.force sigT).typ, [|t; pred|]) in + let intro = mkApp ((Lazy.force sigT).intro, [|lift k t; lift k pred; mkRel k; constr|]) in + (sigty, pred :: tys, (succ k, intro))) + (t, [], (2, mkRel 1)) tl + in + let (last, subst) = List.fold_right2 + (fun pred (n, b, t) (prev, subst) -> + let proj1 = applistc (Lazy.force sigT).proj1 [t; pred; prev] in + let proj2 = applistc (Lazy.force sigT).proj2 [t; pred; prev] in + (lift 1 proj2, (n, Some proj1, t) :: subst)) + (List.rev tys) tl (mkRel 1, []) + in ty, ((n, Some last, t) :: subst), constr + + | _ -> raise (Invalid_argument "telescope") + +let nf_evar_context isevars ctx = + List.map (fun (n, b, t) -> + (n, Option.map (Evarutil.nf_evar isevars) b, Evarutil.nf_evar isevars t)) ctx + +let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = + Coqlib.check_required_library ["Coq";"Program";"Wf"]; + let sigma = Evd.empty in + let isevars = ref (Evd.create_evar_defs sigma) in + let env = Global.env() in + let _pr c = my_print_constr env c in + let _prr = Printer.pr_rel_context env in + let _prn = Printer.pr_named_context env in + let _pr_rel env = Printer.pr_rel_context env in + let (env', binders_rel), impls = interp_context_evars isevars env bl in + let len = List.length binders_rel in + let top_env = push_rel_context binders_rel env in + let top_arity = interp_type_evars isevars top_env arityc in + let full_arity = it_mkProd_or_LetIn top_arity binders_rel in + let argtyp, letbinders, make = telescope binders_rel in + let argname = id_of_string "recarg" in + let arg = (Name argname, None, argtyp) in + let binders = letbinders @ [arg] in + let binders_env = push_rel_context binders_rel env in + let rel = interp_constr isevars env r in + let relty = type_of env !isevars rel in + let relargty = + let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in + match ctx, kind_of_term ar with + | [(_, None, t); (_, None, u)], Sort (Prop Null) + when Reductionops.is_conv env !isevars t u -> t + | _, _ -> + user_err_loc (constr_loc r, + "Subtac_command.build_wellfounded", + my_print_constr env rel ++ str " is not an homogeneous binary relation.") + in + let measure = interp_casted_constr isevars binders_env measure relargty in + let wf_rel, wf_rel_fun, measure_fn = + let measure_body, measure = + it_mkLambda_or_LetIn measure letbinders, + it_mkLambda_or_LetIn measure binders + in + let comb = constr_of_global (Lazy.force measure_on_R_ref) in + let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in + let wf_rel_fun x y = + mkApp (rel, [| subst1 x measure_body; + subst1 y measure_body |]) + in wf_rel, wf_rel_fun, measure + in + let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |]) in + let argid' = id_of_string (string_of_id argname ^ "'") in + let wfarg len = (Name argid', None, + mkSubset (Name argid') argtyp + (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) + in + let intern_bl = wfarg 1 :: [arg] in + let _intern_env = push_rel_context intern_bl env in + let proj = (Lazy.force sig_).Coqlib.proj1 in + let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in + let projection = (* in wfarg :: arg :: before *) + mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) + in + let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in + let intern_arity = substl [projection] top_arity_let in + (* substitute the projection of wfarg for something, + now intern_arity is in wfarg :: arg *) + let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in + let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in + let curry_fun = + let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in + let arg = mkApp ((Lazy.force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in + let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in + let rcurry = mkApp (rel, [| measure; lift len measure |]) in + let lam = (Name (id_of_string "recproof"), None, rcurry) in + let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in + let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in + (Name recname, Some body, ty) + in + let fun_bl = intern_fun_binder :: [arg] in + let lift_lets = Termops.lift_rel_context 1 letbinders in + let intern_body = + let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in + let (r, l, impls, scopes) = + Constrintern.compute_internalization_data env + Constrintern.Recursive full_arity impls + in + let newimpls = [(recname, (r, l, impls @ + [Some (id_of_string "recproof", Impargs.Manual, (true, false))], + scopes @ [None]))] in + let newimpls = Constrintern.set_internalization_env_params newimpls [] in + interp_casted_constr isevars ~impls:newimpls + (push_rel_context ctx env) body (lift 1 top_arity) + in + let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in + let prop = mkLambda (Name argname, argtyp, top_arity_let) in + let def = + mkApp (constr_of_global (Lazy.force fix_sub_ref), + [| argtyp ; wf_rel ; + make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ; + prop ; intern_body_lam |]) + in + let _ = isevars := Evarutil.nf_evar_map !isevars in + let binders_rel = nf_evar_context !isevars binders_rel in + let binders = nf_evar_context !isevars binders in + let top_arity = Evarutil.nf_evar !isevars top_arity in + let hook, recname, typ = + if List.length binders_rel > 1 then + let name = add_suffix recname "_func" in + let hook l gr = + let body = it_mkLambda_or_LetIn (mkApp (constr_of_global gr, [|make|])) binders_rel in + let ty = it_mkProd_or_LetIn top_arity binders_rel in + let ce = + { const_entry_body = Evarutil.nf_evar !isevars body; + const_entry_type = Some ty; + const_entry_opaque = false; + const_entry_boxed = false} + in + let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in + let gr = ConstRef c in + if Impargs.is_implicit_args () || impls <> [] then + Impargs.declare_manual_implicits false gr impls + in + let typ = it_mkProd_or_LetIn top_arity binders in + hook, name, typ + else + let typ = it_mkProd_or_LetIn top_arity binders_rel in + let hook l gr = + if Impargs.is_implicit_args () || impls <> [] then + Impargs.declare_manual_implicits false gr impls + in hook, recname, typ + in + let fullcoqc = Evarutil.nf_evar !isevars def in + let fullctyp = Evarutil.nf_evar !isevars typ in + let evm = evars_of_term !isevars Evd.empty fullctyp in + let evm = evars_of_term !isevars evm fullcoqc in + let evm = non_instanciated_map env isevars evm in + let evars, _, evars_def, evars_typ = + Eterm.eterm_obligations env recname !isevars evm 0 fullcoqc fullctyp + in + Subtac_obligations.add_definition recname ~term:evars_def evars_typ evars ~hook + +let interp_fix_context evdref env fix = + interp_context_evars evdref env fix.Command.fix_binders + +let interp_fix_ccl evdref (env,_) fix = + interp_type_evars evdref env fix.Command.fix_type + +let interp_fix_body evdref env_rec impls (_,ctx) fix ccl = + let env = push_rel_context ctx env_rec in + let body = Option.map (fun c -> interp_casted_constr_evars evdref env ~impls c ccl) fix.Command.fix_body in + Option.map (fun c -> it_mkLambda_or_LetIn c ctx) body + +let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx + +let prepare_recursive_declaration fixnames fixtypes fixdefs = + let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in + let names = List.map (fun id -> Name id) fixnames in + (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) + +let rel_index n ctx = + list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx)) + +let rec unfold f b = + match f b with + | Some (x, b') -> x :: unfold f b' + | None -> [] + +let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype = + match n with + | Some (loc, n) -> [rel_index n fixctx] + | None -> + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual + fixpoints ?) *) + let len = List.length fixctx in + unfold (function x when x = len -> None + | n -> Some (n, succ n)) 0 + +let push_named_context = List.fold_right push_named + +let check_evars env initial_sigma evd c = + let sigma = evd in + let c = nf_evar sigma c in + let rec proc_rec c = + match kind_of_term c with + | Evar (evk,args) -> + assert (Evd.mem sigma evk); + if not (Evd.mem initial_sigma evk) then + let (loc,k) = evar_source evk evd in + (match k with + | QuestionMark _ + | ImplicitArg (_, _, false) -> () + | _ -> + let evi = nf_evar_info sigma (Evd.find sigma evk) in + Pretype_errors.error_unsolvable_implicit loc env sigma evi k None) + | _ -> iter_constr proc_rec c + in proc_rec c + +let out_def = function + | Some def -> def + | None -> error "Program Fixpoint needs defined bodies." + +let interp_recursive fixkind l boxed = + let env = Global.env() in + let fixl, ntnl = List.split l in + let kind = fixkind <> IsCoFixpoint in + let fixnames = List.map (fun fix -> fix.Command.fix_name) fixl in + + (* Interp arities allowing for unresolved types *) + let evdref = ref Evd.empty in + let fixctxs, fiximps = List.split (List.map (interp_fix_context evdref env) fixl) in + let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in + let fixtypes = List.map2 build_fix_type fixctxs fixccls in + let rec_sign = + List.fold_left2 (fun env' id t -> + let sort = Retyping.get_type_of env !evdref t in + let fixprot = + try mkApp (Lazy.force Subtac_utils.fix_proto, [|sort; t|]) + with e -> t + in + (id,None,fixprot) :: env') + [] fixnames fixtypes + in + let env_rec = push_named_context rec_sign env in + + (* Get interpretation metadatas *) + let impls = Constrintern.compute_full_internalization_env env + Constrintern.Recursive [] fixnames fixtypes fiximps + in + let notations = List.flatten ntnl in + + (* Interp bodies with rollback because temp use of notations/implicit *) + let fixdefs = + States.with_state_protection (fun () -> + List.iter (Metasyntax.set_notation_for_interpretation impls) notations; + list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls) + () in + + let fixdefs = List.map out_def fixdefs in + + (* Instantiate evars and check all are resolved *) + let evd,_ = Evarconv.consider_remaining_unif_problems env_rec !evdref in + let evd = Typeclasses.resolve_typeclasses + ~onlyargs:true ~split:true ~fail:false env_rec evd + in + let evd = Evarutil.nf_evar_map evd in + let fixdefs = List.map (nf_evar evd) fixdefs in + let fixtypes = List.map (nf_evar evd) fixtypes in + let rec_sign = nf_named_context_evar evd rec_sign in + + let recdefs = List.length rec_sign in + List.iter (check_evars env_rec Evd.empty evd) fixdefs; + List.iter (check_evars env Evd.empty evd) fixtypes; + Command.check_mutuality env kind (List.combine fixnames fixdefs); + + (* Russell-specific code *) + + (* Get the interesting evars, those that were not instanciated *) + let isevars = Evd.undefined_evars evd in + let evm = isevars in + (* Solve remaining evars *) + let rec collect_evars id def typ imps = + (* Generalize by the recursive prototypes *) + let def = + Termops.it_mkNamedLambda_or_LetIn def rec_sign + and typ = + Termops.it_mkNamedProd_or_LetIn typ rec_sign + in + let evm' = Subtac_utils.evars_of_term evm Evd.empty def in + let evm' = Subtac_utils.evars_of_term evm evm' typ in + let evars, _, def, typ = Eterm.eterm_obligations env id isevars evm' recdefs def typ in + (id, def, typ, imps, evars) + in + let defs = list_map4 collect_evars fixnames fixdefs fixtypes fiximps in + (match fixkind with + | IsFixpoint wfl -> + let possible_indexes = + list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in + let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), + Array.of_list fixtypes, + Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) + in + let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in + list_iter_i (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) l + | IsCoFixpoint -> ()); + Subtac_obligations.add_mutual_definitions defs notations fixkind + +let out_n = function + Some n -> n + | None -> raise Not_found + +let build_recursive l b = + let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in + match g, l with + [(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] -> + ignore(build_wellfounded (id, n, bl, typ, out_def def) r + (match n with Some n -> mkIdentC (snd n) | None -> + errorlabstrm "Subtac_command.build_recursive" + (str "Recursive argument required for well-founded fixpoints")) + ntn false) + + | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] -> + ignore(build_wellfounded (id, n, bl, typ, out_def def) (Option.default (CRef lt_ref) r) + m ntn false) + + | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g -> + let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) -> + ({Command.fix_name = id; Command.fix_binders = bl; + Command.fix_body = def; Command.fix_type = typ},ntn)) l + in interp_recursive (IsFixpoint g) fixl b + | _, _ -> + errorlabstrm "Subtac_command.build_recursive" + (str "Well-founded fixpoints not allowed in mutually recursive blocks") + +let build_corecursive l b = + let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> + ({Command.fix_name = id; Command.fix_binders = bl; + Command.fix_body = def; Command.fix_type = typ},ntn)) + l in + interp_recursive IsCoFixpoint fixl b diff --git a/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli new file mode 100644 index 00000000..304aa139 --- /dev/null +++ b/plugins/subtac/subtac_command.mli @@ -0,0 +1,60 @@ +open Pretyping +open Evd +open Environ +open Term +open Topconstr +open Names +open Libnames +open Pp +open Vernacexpr +open Constrintern + +val interp_gen : + typing_constraint -> + evar_map ref -> + env -> + ?impls:full_internalization_env -> + ?allow_patvar:bool -> + ?ltacvars:ltac_sign -> + constr_expr -> constr +val interp_constr : + evar_map ref -> + env -> constr_expr -> constr +val interp_type_evars : + evar_map ref -> + env -> + ?impls:full_internalization_env -> + constr_expr -> constr +val interp_casted_constr_evars : + evar_map ref -> + env -> + ?impls:full_internalization_env -> + constr_expr -> types -> constr +val interp_open_constr : + evar_map ref -> env -> constr_expr -> constr +val interp_constr_judgment : + evar_map ref -> + env -> + constr_expr -> unsafe_judgment +val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list + +val interp_binder : Evd.evar_map ref -> + Environ.env -> Names.name -> Topconstr.constr_expr -> Term.constr + + +val telescope : + (Names.name * 'a option * Term.types) list -> + Term.types * (Names.name * Term.types option * Term.types) list * + Term.constr + +val build_wellfounded : + Names.identifier * 'a * Topconstr.local_binder list * + Topconstr.constr_expr * Topconstr.constr_expr -> + Topconstr.constr_expr -> + Topconstr.constr_expr -> 'b -> 'c -> Subtac_obligations.progress + +val build_recursive : + (fixpoint_expr * decl_notation list) list -> bool -> unit + +val build_corecursive : + (cofixpoint_expr * decl_notation list) list -> bool -> unit diff --git a/plugins/subtac/subtac_errors.ml b/plugins/subtac/subtac_errors.ml new file mode 100644 index 00000000..067da150 --- /dev/null +++ b/plugins/subtac/subtac_errors.ml @@ -0,0 +1,24 @@ +open Util +open Pp +open Printer + +type term_pp = Pp.std_ppcmds + +type subtyping_error = + | UncoercibleInferType of loc * term_pp * term_pp + | UncoercibleInferTerm of loc * term_pp * term_pp * term_pp * term_pp + | UncoercibleRewrite of term_pp * term_pp + +type typing_error = + | NonFunctionalApp of loc * term_pp * term_pp * term_pp + | NonConvertible of loc * term_pp * term_pp + | NonSigma of loc * term_pp + | IllSorted of loc * term_pp + +exception Subtyping_error of subtyping_error +exception Typing_error of typing_error + +exception Debug_msg of string + +let typing_error e = raise (Typing_error e) +let subtyping_error e = raise (Subtyping_error e) diff --git a/plugins/subtac/subtac_errors.mli b/plugins/subtac/subtac_errors.mli new file mode 100644 index 00000000..8d75b9c0 --- /dev/null +++ b/plugins/subtac/subtac_errors.mli @@ -0,0 +1,15 @@ +type term_pp = Pp.std_ppcmds +type subtyping_error = + UncoercibleInferType of Util.loc * term_pp * term_pp + | UncoercibleInferTerm of Util.loc * term_pp * term_pp * term_pp * term_pp + | UncoercibleRewrite of term_pp * term_pp +type typing_error = + NonFunctionalApp of Util.loc * term_pp * term_pp * term_pp + | NonConvertible of Util.loc * term_pp * term_pp + | NonSigma of Util.loc * term_pp + | IllSorted of Util.loc * term_pp +exception Subtyping_error of subtyping_error +exception Typing_error of typing_error +exception Debug_msg of string +val typing_error : typing_error -> 'a +val subtyping_error : subtyping_error -> 'a diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml new file mode 100644 index 00000000..2836bc73 --- /dev/null +++ b/plugins/subtac/subtac_obligations.ml @@ -0,0 +1,652 @@ +(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *) +open Printf +open Pp +open Subtac_utils +open Command +open Environ + +open Term +open Names +open Libnames +open Summary +open Libobject +open Entries +open Decl_kinds +open Util +open Evd +open Declare +open Proof_type + +let ppwarn cmd = Pp.warn (str"Program:" ++ cmd) +let pperror cmd = Util.errorlabstrm "Program" cmd +let error s = pperror (str s) + +let reduce = + Reductionops.clos_norm_flags Closure.betaiotazeta (Global.env ()) Evd.empty + +exception NoObligations of identifier option + +let explain_no_obligations = function + Some ident -> str "No obligations for program " ++ str (string_of_id ident) + | None -> str "No obligations remaining" + +type obligation_info = (Names.identifier * Term.types * loc * obligation_definition_status * Intset.t + * tactic option) array + +type obligation = + { obl_name : identifier; + obl_type : types; + obl_location : loc; + obl_body : constr option; + obl_status : obligation_definition_status; + obl_deps : Intset.t; + obl_tac : tactic option; + } + +type obligations = (obligation array * int) + +type fixpoint_kind = + | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list + | IsCoFixpoint + +type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list + +type program_info = { + prg_name: identifier; + prg_body: constr; + prg_type: constr; + prg_obligations: obligations; + prg_deps : identifier list; + prg_fixkind : fixpoint_kind option ; + prg_implicits : (Topconstr.explicitation * (bool * bool * bool)) list; + prg_notations : notations ; + prg_kind : definition_kind; + prg_hook : Tacexpr.declaration_hook; +} + +let assumption_message id = + Flags.if_verbose message ((string_of_id id) ^ " is assumed") + +let default_tactic : Proof_type.tactic ref = ref Refiner.tclIDTAC +let default_tactic_expr : Tacexpr.glob_tactic_expr ref = ref (Tacexpr.TacId []) + +let set_default_tactic t = default_tactic_expr := t; default_tactic := Tacinterp.eval_tactic t + +(* true = All transparent, false = Opaque if possible *) +let proofs_transparency = ref true + +let set_proofs_transparency = (:=) proofs_transparency +let get_proofs_transparency () = !proofs_transparency + +open Goptions + +let _ = + declare_bool_option + { optsync = true; + optname = "transparency of Program obligations"; + optkey = ["Transparent";"Obligations"]; + optread = get_proofs_transparency; + optwrite = set_proofs_transparency; } + +let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type + +let get_obligation_body expand obl = + let c = Option.get obl.obl_body in + if expand && obl.obl_status = Expand then + match kind_of_term c with + | Const c -> constant_value (Global.env ()) c + | _ -> c + else c + +let subst_deps expand obls deps t = + let subst = + Intset.fold + (fun x acc -> + let xobl = obls.(x) in + let oblb = + try get_obligation_body expand xobl + with _ -> assert(false) + in (xobl.obl_name, oblb) :: acc) + deps [] + in(* Termops.it_mkNamedProd_or_LetIn t subst *) + Term.replace_vars subst t + +let subst_deps_obl obls obl = + let t' = subst_deps true obls obl.obl_deps obl.obl_type in + { obl with obl_type = t' } + +module ProgMap = Map.Make(struct type t = identifier let compare = compare end) + +let map_replace k v m = ProgMap.add k v (ProgMap.remove k m) + +let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] + +let map_cardinal m = + let i = ref 0 in + ProgMap.iter (fun _ _ -> incr i) m; + !i + +exception Found of program_info + +let map_first m = + try + ProgMap.iter (fun _ v -> raise (Found v)) m; + assert(false) + with Found x -> x + +let from_prg : program_info ProgMap.t ref = ref ProgMap.empty + +let freeze () = !from_prg, !default_tactic_expr +let unfreeze (v, t) = from_prg := v; set_default_tactic t +let init () = + from_prg := ProgMap.empty; set_default_tactic (Tacexpr.TacId []) + +(** Beware: if this code is dynamically loaded via dynlink after the start + of Coq, then this [init] function will not be run by [Lib.init ()]. + Luckily, here we can launch [init] at load-time. *) + +let _ = init () + +let _ = + Summary.declare_summary "program-tcc-table" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init } + +let progmap_union = ProgMap.fold ProgMap.add + +let cache (_, (local, tac)) = + set_default_tactic tac + +let load (_, (local, tac)) = + if not local then set_default_tactic tac + +let subst (s, (local, tac)) = + (local, Tacinterp.subst_tactic s tac) + +let (input,output) = + declare_object + { (default_object "Program state") with + cache_function = cache; + load_function = (fun _ -> load); + open_function = (fun _ -> load); + classify_function = (fun (local, tac) -> + if not (ProgMap.is_empty !from_prg) then + errorlabstrm "Program" (str "Unsolved obligations when closing module:" ++ spc () ++ + prlist_with_sep spc (fun x -> Nameops.pr_id x) + (map_keys !from_prg)); + if local then Dispose else Substitute (local, tac)); + subst_function = subst} + +let update_state local = + Lib.add_anonymous_leaf (input (local, !default_tactic_expr)) + +let set_default_tactic local t = + set_default_tactic t; update_state local + +open Evd + +let progmap_remove prg = + from_prg := ProgMap.remove prg.prg_name !from_prg + +let rec intset_to = function + -1 -> Intset.empty + | n -> Intset.add n (intset_to (pred n)) + +let subst_body expand prg = + let obls, _ = prg.prg_obligations in + let ints = intset_to (pred (Array.length obls)) in + subst_deps expand obls ints prg.prg_body, + subst_deps expand obls ints (Termops.refresh_universes prg.prg_type) + +let declare_definition prg = + let body, typ = subst_body true prg in + (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++ + my_print_constr (Global.env()) body ++ str " : " ++ + my_print_constr (Global.env()) prg.prg_type); + with _ -> ()); + let (local, boxed, kind) = prg.prg_kind in + let ce = + { const_entry_body = body; + const_entry_type = Some typ; + const_entry_opaque = false; + const_entry_boxed = boxed} + in + (Command.get_declare_definition_hook ()) ce; + match local with + | Local when Lib.sections_are_opened () -> + let c = + SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in + let _ = declare_variable prg.prg_name (Lib.cwd(),c,IsDefinition kind) in + print_message (Subtac_utils.definition_message prg.prg_name); + if Pfedit.refining () then + Flags.if_verbose msg_warning + (str"Local definition " ++ Nameops.pr_id prg.prg_name ++ + str" is not visible from current goals"); + progmap_remove prg; + VarRef prg.prg_name + | (Global|Local) -> + let c = + Declare.declare_constant + prg.prg_name (DefinitionEntry ce,IsDefinition (pi3 prg.prg_kind)) + in + let gr = ConstRef c in + if Impargs.is_implicit_args () || prg.prg_implicits <> [] then + Impargs.declare_manual_implicits false gr prg.prg_implicits; + print_message (Subtac_utils.definition_message prg.prg_name); + progmap_remove prg; + prg.prg_hook local gr; + gr + +open Pp +open Ppconstr + +let rec lam_index n t acc = + match kind_of_term t with + | Lambda (na, _, b) -> + if na = Name n then acc + else lam_index n b (succ acc) + | _ -> raise Not_found + +let compute_possible_guardness_evidences (n,_) fixbody fixtype = + match n with + | Some (loc, n) -> [lam_index n fixbody 0] + | None -> + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual + fixpoints ?) *) + let m = Term.nb_prod fixtype in + let ctx = fst (decompose_prod_n_assum m fixtype) in + list_map_i (fun i _ -> i) 0 ctx + +let declare_mutual_definition l = + let len = List.length l in + let first = List.hd l in + let fixdefs, fixtypes, fiximps = + list_split3 + (List.map (fun x -> + let subs, typ = (subst_body true x) in + let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in + let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in + reduce term, reduce typ, x.prg_implicits) l) + in +(* let fixdefs = List.map reduce_fix fixdefs in *) + let fixkind = Option.get first.prg_fixkind in + let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in + let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in + let (local,boxed,kind) = first.prg_kind in + let fixnames = first.prg_deps in + let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in + let indexes, fixdecls = + match fixkind with + | IsFixpoint wfl -> + let possible_indexes = + list_map3 compute_possible_guardness_evidences wfl fixdefs fixtypes in + let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in + Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l + | IsCoFixpoint -> + None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l + in + (* Declare the recursive definitions *) + let kns = list_map4 (declare_fix boxed kind) fixnames fixdecls fixtypes fiximps in + (* Declare notations *) + List.iter Metasyntax.add_notation_interpretation first.prg_notations; + Declare.recursive_message (fixkind<>IsCoFixpoint) indexes fixnames; + let gr = List.hd kns in + let kn = match gr with ConstRef kn -> kn | _ -> assert false in + first.prg_hook local gr; + List.iter progmap_remove l; kn + +let declare_obligation prg obl body = + let body = reduce body in + let ty = reduce obl.obl_type in + match obl.obl_status with + | Expand -> { obl with obl_body = Some body } + | Define opaque -> + let opaque = if get_proofs_transparency () then false else opaque in + let ce = + { const_entry_body = body; + const_entry_type = Some ty; + const_entry_opaque = opaque; + const_entry_boxed = false} + in + let constant = Declare.declare_constant obl.obl_name + (DefinitionEntry ce,IsProof Property) + in + if not opaque then + Auto.add_hints false [string_of_id prg.prg_name] + (Auto.HintsUnfoldEntry [EvalConstRef constant]); + print_message (Subtac_utils.definition_message obl.obl_name); + { obl with obl_body = Some (mkConst constant) } + +let red = Reductionops.nf_betaiota Evd.empty + +let init_prog_info n b t deps fixkind notations obls impls kind hook = + let obls', b = + match b with + | None -> + assert(obls = [||]); + let n = Nameops.add_suffix n "_obligation" in + [| { obl_name = n; obl_body = None; + obl_location = dummy_loc; obl_type = t; + obl_status = Expand; obl_deps = Intset.empty; obl_tac = None } |], + mkVar n + | Some b -> + Array.mapi + (fun i (n, t, l, o, d, tac) -> + { obl_name = n ; obl_body = None; + obl_location = l; obl_type = red t; obl_status = o; + obl_deps = d; obl_tac = tac }) + obls, b + in + { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls'); + prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; + prg_implicits = impls; prg_kind = kind; prg_hook = hook; } + +let get_prog name = + let prg_infos = !from_prg in + match name with + Some n -> + (try ProgMap.find n prg_infos + with Not_found -> raise (NoObligations (Some n))) + | None -> + (let n = map_cardinal prg_infos in + match n with + 0 -> raise (NoObligations None) + | 1 -> map_first prg_infos + | _ -> error "More than one program with unsolved obligations") + +let get_prog_err n = + try get_prog n with NoObligations id -> pperror (explain_no_obligations id) + +let obligations_solved prg = (snd prg.prg_obligations) = 0 + +let all_programs () = + ProgMap.fold (fun k p l -> p :: l) !from_prg [] + +type progress = + | Remain of int + | Dependent + | Defined of global_reference + +let obligations_message rem = + if rem > 0 then + if rem = 1 then + Flags.if_verbose msgnl (int rem ++ str " obligation remaining") + else + Flags.if_verbose msgnl (int rem ++ str " obligations remaining") + else + Flags.if_verbose msgnl (str "No more obligations remaining") + +let update_obls prg obls rem = + let prg' = { prg with prg_obligations = (obls, rem) } in + from_prg := map_replace prg.prg_name prg' !from_prg; + obligations_message rem; + if rem > 0 then Remain rem + else ( + match prg'.prg_deps with + | [] -> + let kn = declare_definition prg' in + progmap_remove prg'; + Defined kn + | l -> + let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in + if List.for_all (fun x -> obligations_solved x) progs then + let kn = declare_mutual_definition progs in + Defined (ConstRef kn) + else Dependent) + +let is_defined obls x = obls.(x).obl_body <> None + +let deps_remaining obls deps = + Intset.fold + (fun x acc -> + if is_defined obls x then acc + else x :: acc) + deps [] + +let has_dependencies obls n = + let res = ref false in + Array.iteri + (fun i obl -> + if i <> n && Intset.mem n obl.obl_deps then + res := true) + obls; + !res + +let kind_of_opacity o = + match o with + | Define false | Expand -> Subtac_utils.goal_kind + | _ -> Subtac_utils.goal_proof_kind + +let not_transp_msg = + str "Obligation should be transparent but was declared opaque." ++ spc () ++ + str"Use 'Defined' instead." + +let warn_not_transp () = ppwarn not_transp_msg +let error_not_transp () = pperror not_transp_msg + +let rec solve_obligation prg num tac = + let user_num = succ num in + let obls, rem = prg.prg_obligations in + let obl = obls.(num) in + if obl.obl_body <> None then + pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.") + else + match deps_remaining obls obl.obl_deps with + | [] -> + let obl = subst_deps_obl obls obl in + Lemmas.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type + (fun strength gr -> + let cst = match gr with ConstRef cst -> cst | _ -> assert false in + let obl = + let transparent = evaluable_constant cst (Global.env ()) in + let body = + match obl.obl_status with + | Expand -> + if not transparent then error_not_transp () + else constant_value (Global.env ()) cst + | Define opaque -> + if not opaque && not transparent then error_not_transp () + else Libnames.constr_of_global gr + in + if transparent then + Auto.add_hints true [string_of_id prg.prg_name] + (Auto.HintsUnfoldEntry [EvalConstRef cst]); + { obl with obl_body = Some body } + in + let obls = Array.copy obls in + let _ = obls.(num) <- obl in + let res = try update_obls prg obls (pred rem) + with e -> pperror (Cerrors.explain_exn e) + in + match res with + | Remain n when n > 0 -> + if has_dependencies obls num then + ignore(auto_solve_obligations (Some prg.prg_name) None) + | _ -> ()); + trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ + Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); + Pfedit.by !default_tactic; + Option.iter (fun tac -> Pfedit.set_end_tac (Tacinterp.interp tac)) tac; + Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () + | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " + ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) + +and subtac_obligation (user_num, name, typ) tac = + let num = pred user_num in + let prg = get_prog_err name in + let obls, rem = prg.prg_obligations in + if num < Array.length obls then + let obl = obls.(num) in + match obl.obl_body with + None -> solve_obligation prg num tac + | Some r -> error "Obligation already solved" + else error (sprintf "Unknown obligation number %i" (succ num)) + + +and solve_obligation_by_tac prg obls i tac = + let obl = obls.(i) in + match obl.obl_body with + | Some _ -> false + | None -> + try + if deps_remaining obls obl.obl_deps = [] then + let obl = subst_deps_obl obls obl in + let tac = + match tac with + | Some t -> t + | None -> + match obl.obl_tac with + | Some t -> t + | None -> !default_tactic + in + let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in + obls.(i) <- declare_obligation prg obl t; + true + else false + with + | Stdpp.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s))) + | Stdpp.Exc_located(_, Refiner.FailError (_, s)) + | Refiner.FailError (_, s) -> + user_err_loc (obl.obl_location, "solve_obligation", Lazy.force s) + | e -> false + +and solve_prg_obligations prg tac = + let obls, rem = prg.prg_obligations in + let rem = ref rem in + let obls' = Array.copy obls in + let _ = + Array.iteri (fun i x -> + if solve_obligation_by_tac prg obls' i tac then + decr rem) + obls' + in + update_obls prg obls' !rem + +and solve_obligations n tac = + let prg = get_prog_err n in + solve_prg_obligations prg tac + +and solve_all_obligations tac = + ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg + +and try_solve_obligation n prg tac = + let prg = get_prog prg in + let obls, rem = prg.prg_obligations in + let obls' = Array.copy obls in + if solve_obligation_by_tac prg obls' n tac then + ignore(update_obls prg obls' (pred rem)); + +and try_solve_obligations n tac = + try ignore (solve_obligations n tac) with NoObligations _ -> () + +and auto_solve_obligations n tac : progress = + Flags.if_verbose msgnl (str "Solving obligations automatically..."); + try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent + +open Pp +let show_obligations_of_prg ?(msg=true) prg = + let n = prg.prg_name in + let obls, rem = prg.prg_obligations in + let showed = ref 5 in + if msg then msgnl (int rem ++ str " obligation(s) remaining: "); + Array.iteri (fun i x -> + match x.obl_body with + | None -> + if !showed > 0 then ( + decr showed; + msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ + str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ + hov 1 (my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ()))) + | Some _ -> ()) + obls + +let show_obligations ?(msg=true) n = + let progs = match n with + | None -> all_programs () + | Some n -> + try [ProgMap.find n !from_prg] + with Not_found -> raise (NoObligations (Some n)) + in List.iter (show_obligations_of_prg ~msg) progs + +let show_term n = + let prg = get_prog_err n in + let n = prg.prg_name in + msgnl (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++ + my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () + ++ my_print_constr (Global.env ()) prg.prg_body) + +let add_definition n ?term t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(hook=fun _ _ -> ()) obls = + Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); + let prg = init_prog_info n term t [] None [] obls implicits kind hook in + let obls,_ = prg.prg_obligations in + if Array.length obls = 0 then ( + Flags.if_verbose ppnl (str "."); + let cst = declare_definition prg in + Defined cst) + else ( + let len = Array.length obls in + let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in + from_prg := ProgMap.add n prg !from_prg; + let res = auto_solve_obligations (Some n) tactic in + match res with + | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res + | _ -> res) + +let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(hook=fun _ _ -> ()) notations fixkind = + let deps = List.map (fun (n, b, t, imps, obls) -> n) l in + let upd = List.fold_left + (fun acc (n, b, t, imps, obls) -> + let prg = init_prog_info n (Some b) t deps (Some fixkind) notations obls imps kind hook in + ProgMap.add n prg acc) + !from_prg l + in + from_prg := upd; + let _defined = + List.fold_left (fun finished x -> + if finished then finished + else + let res = auto_solve_obligations (Some x) tactic in + match res with + | Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true + | _ -> false) + false deps + in () + +let admit_obligations n = + let prg = get_prog_err n in + let obls, rem = prg.prg_obligations in + Array.iteri + (fun i x -> + match x.obl_body with + | None -> + let x = subst_deps_obl obls x in + let kn = Declare.declare_constant x.obl_name (ParameterEntry (x.obl_type,false), + IsAssumption Conjectural) + in + assumption_message x.obl_name; + obls.(i) <- { x with obl_body = Some (mkConst kn) } + | Some _ -> ()) + obls; + ignore(update_obls prg obls 0) + +exception Found of int + +let array_find f arr = + try Array.iteri (fun i x -> if f x then raise (Found i)) arr; + raise Not_found + with Found i -> i + +let next_obligation n tac = + let prg = get_prog_err n in + let obls, rem = prg.prg_obligations in + let i = + try array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) obls + with Not_found -> anomaly "Could not find a solvable obligation." + in solve_obligation prg i tac + +let default_tactic () = !default_tactic +let default_tactic_expr () = !default_tactic_expr diff --git a/plugins/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli new file mode 100644 index 00000000..1608c134 --- /dev/null +++ b/plugins/subtac/subtac_obligations.mli @@ -0,0 +1,69 @@ +open Names +open Util +open Libnames +open Evd +open Proof_type + +type obligation_info = + (identifier * Term.types * loc * + obligation_definition_status * Intset.t * tactic option) array + (* ident, type, location, (opaque or transparent, expand or define), + dependencies, tactic to solve it *) + +type progress = (* Resolution status of a program *) + | Remain of int (* n obligations remaining *) + | Dependent (* Dependent on other definitions *) + | Defined of global_reference (* Defined as id *) + +val set_default_tactic : bool -> Tacexpr.glob_tactic_expr -> unit +val default_tactic : unit -> Proof_type.tactic +val default_tactic_expr : unit -> Tacexpr.glob_tactic_expr + +val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *) +val get_proofs_transparency : unit -> bool + +val add_definition : Names.identifier -> ?term:Term.constr -> Term.types -> + ?implicits:(Topconstr.explicitation * (bool * bool * bool)) list -> + ?kind:Decl_kinds.definition_kind -> + ?tactic:Proof_type.tactic -> + ?hook:(Tacexpr.declaration_hook) -> obligation_info -> progress + +type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list + +type fixpoint_kind = + | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list + | IsCoFixpoint + +val add_mutual_definitions : + (Names.identifier * Term.constr * Term.types * + (Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list -> + ?tactic:Proof_type.tactic -> + ?kind:Decl_kinds.definition_kind -> + ?hook:Tacexpr.declaration_hook -> + notations -> + fixpoint_kind -> unit + +val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option -> + Tacexpr.raw_tactic_expr option -> unit + +val next_obligation : Names.identifier option -> Tacexpr.raw_tactic_expr option -> unit + +val solve_obligations : Names.identifier option -> Proof_type.tactic option -> progress +(* Number of remaining obligations to be solved for this program *) + +val solve_all_obligations : Proof_type.tactic option -> unit + +val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit + +val try_solve_obligations : Names.identifier option -> Proof_type.tactic option -> unit + +val show_obligations : ?msg:bool -> Names.identifier option -> unit + +val show_term : Names.identifier option -> unit + +val admit_obligations : Names.identifier option -> unit + +exception NoObligations of Names.identifier option + +val explain_no_obligations : Names.identifier option -> Pp.std_ppcmds + diff --git a/plugins/subtac/subtac_plugin.mllib b/plugins/subtac/subtac_plugin.mllib new file mode 100644 index 00000000..a4b9d67e --- /dev/null +++ b/plugins/subtac/subtac_plugin.mllib @@ -0,0 +1,13 @@ +Subtac_utils +Eterm +Subtac_errors +Subtac_coercion +Subtac_obligations +Subtac_cases +Subtac_pretyping_F +Subtac_pretyping +Subtac_command +Subtac_classes +Subtac +G_subtac +Subtac_plugin_mod diff --git a/plugins/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml new file mode 100644 index 00000000..f1541f25 --- /dev/null +++ b/plugins/subtac/subtac_pretyping.ml @@ -0,0 +1,137 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* A -> Prop *) + wf_proof: constr; (* : well_founded R *) + f_type: types; (* f: A -> Set *) + f_fulltype: types; (* Type with argument and wf proof product first *) +} + +let my_print_rec_info env t = + str "Name: " ++ Nameops.pr_name t.arg_name ++ spc () ++ + str "Arg type: " ++ my_print_constr env t.arg_type ++ spc () ++ + str "Wf relation: " ++ my_print_constr env t.wf_relation ++ spc () ++ + str "Wf proof: " ++ my_print_constr env t.wf_proof ++ spc () ++ + str "Abbreviated Type: " ++ my_print_constr env t.f_type ++ spc () ++ + str "Full type: " ++ my_print_constr env t.f_fulltype +(* trace (str "pretype for " ++ (my_print_rawconstr env c) ++ *) +(* str " and tycon "++ my_print_tycon env tycon ++ *) +(* str " in environment: " ++ my_print_env env); *) + +let merge_evms x y = + Evd.fold (fun ev evi evm -> Evd.add evm ev evi) x y + +let interp env isevars c tycon = + let j = pretype tycon env isevars ([],[]) c in + let _ = isevars := Evarutil.nf_evar_map !isevars in + let evd,_ = consider_remaining_unif_problems env !isevars in +(* let unevd = undefined_evars evd in *) + let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:true env evd in + let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:false env unevd' in + let evm = unevd' in + isevars := unevd'; + nf_evar evm j.uj_val, nf_evar evm j.uj_type + +let find_with_index x l = + let rec aux i = function + (y, _, _) as t :: tl -> if x = y then i, t else aux (succ i) tl + | [] -> raise Not_found + in aux 0 l + +open Vernacexpr + +let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_constr ( evd) env +let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_type ( evd) env + +let env_with_binders env isevars l = + let rec aux ((env, rels) as acc) = function + Topconstr.LocalRawDef ((loc, name), def) :: tl -> + let rawdef = coqintern_constr !isevars env def in + let coqdef, deftyp = interp env isevars rawdef empty_tycon in + let reldecl = (name, Some coqdef, deftyp) in + aux (push_rel reldecl env, reldecl :: rels) tl + | Topconstr.LocalRawAssum (bl, k, typ) :: tl -> + let rawtyp = coqintern_type !isevars env typ in + let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in + let acc = + List.fold_left (fun (env, rels) (loc, name) -> + let reldecl = (name, None, coqtyp) in + (push_rel reldecl env, + reldecl :: rels)) + (env, rels) bl + in aux acc tl + | [] -> acc + in aux (env, []) l + +let subtac_process env isevars id bl c tycon = + let c = Topconstr.abstract_constr_expr c bl in + let tycon = + match tycon with + None -> empty_tycon + | Some t -> + let t = Topconstr.prod_constr_expr t bl in + let t = coqintern_type !isevars env t in + let coqt, ttyp = interp env isevars t empty_tycon in + mk_tycon coqt + in + let c = coqintern_constr !isevars env c in + let imps = Implicit_quantifiers.implicits_of_rawterm c in + let coqc, ctyp = interp env isevars c tycon in + let evm = non_instanciated_map env isevars ( !isevars) in + let ty = nf_evar !isevars (match tycon with Some (None, c) -> c | _ -> ctyp) in + evm, coqc, ty, imps + +open Subtac_obligations + +let subtac_proof kind hook env isevars id bl c tycon = + let evm, coqc, coqt, imps = subtac_process env isevars id bl c tycon in + let evm' = Subtac_utils.evars_of_term evm Evd.empty coqc in + let evm' = Subtac_utils.evars_of_term evm evm' coqt in + let evars, _, def, ty = Eterm.eterm_obligations env id !isevars evm' 0 coqc coqt in + add_definition id ~term:def ty ~implicits:imps ~kind ~hook evars diff --git a/plugins/subtac/subtac_pretyping.mli b/plugins/subtac/subtac_pretyping.mli new file mode 100644 index 00000000..055c6df2 --- /dev/null +++ b/plugins/subtac/subtac_pretyping.mli @@ -0,0 +1,23 @@ +open Term +open Environ +open Names +open Sign +open Evd +open Global +open Topconstr +open Implicit_quantifiers +open Impargs + +module Pretyping : Pretyping.S + +val interp : + Environ.env -> + Evd.evar_map ref -> + Rawterm.rawconstr -> + Evarutil.type_constraint -> Term.constr * Term.constr + +val subtac_process : env -> evar_map ref -> identifier -> local_binder list -> + constr_expr -> constr_expr option -> evar_map * constr * types * manual_explicitation list + +val subtac_proof : Decl_kinds.definition_kind -> Tacexpr.declaration_hook -> env -> evar_map ref -> identifier -> local_binder list -> + constr_expr -> constr_expr option -> Subtac_obligations.progress diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml new file mode 100644 index 00000000..e574ef3b --- /dev/null +++ b/plugins/subtac/subtac_pretyping_F.ml @@ -0,0 +1,645 @@ +(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *) +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* j_nf_evar !evdref j + | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) evdref j t + + let push_rels vars env = List.fold_right push_rel vars env + + (* + let evar_type_case evdref env ct pt lft p c = + let (mind,bty,rslty) = type_case_branches env ( evdref) ct pt p c + in check_branches_message evdref env (c,ct) (bty,lft); (mind,rslty) + *) + + let strip_meta id = (* For Grammar v7 compatibility *) + let s = string_of_id id in + if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1)) + else id + + let invert_ltac_bound_name env id0 id = + try mkRel (pi1 (lookup_rel_id id (rel_context env))) + with Not_found -> + errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++ + str " depends on pattern variable name " ++ pr_id id ++ + str " which is not bound in current context") + + let pretype_id loc env sigma (lvar,unbndltacvars) id = + let id = strip_meta id in (* May happen in tactics defined by Grammar *) + try + let (n,_,typ) = lookup_rel_id id (rel_context env) in + { uj_val = mkRel n; uj_type = lift n typ } + with Not_found -> + try + let (ids,c) = List.assoc id lvar in + let subst = List.map (invert_ltac_bound_name env id) ids in + let c = substl subst c in + { uj_val = c; uj_type = Retyping.get_type_of env sigma c } + with Not_found -> + try + let (_,_,typ) = lookup_named id env in + { uj_val = mkVar id; uj_type = typ } + with Not_found -> + try (* To build a nicer ltac error message *) + match List.assoc id unbndltacvars with + | None -> user_err_loc (loc,"", + str "variable " ++ pr_id id ++ str " should be bound to a term") + | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0 + with Not_found -> + error_var_not_found_loc loc id + + (* make a dependent predicate from an undependent one *) + + let make_dep_of_undep env (IndType (indf,realargs)) pj = + let n = List.length realargs in + let rec decomp n p = + if n=0 then p else + match kind_of_term p with + | Lambda (_,_,c) -> decomp (n-1) c + | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) + in + let sign,s = decompose_prod_n n pj.uj_type in + let ind = build_dependent_inductive env indf in + let s' = mkProd (Anonymous, ind, s) in + let ccl = lift 1 (decomp n pj.uj_val) in + let ccl' = mkLambda (Anonymous, ind, ccl) in + {uj_val=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign} + + (*************************************************************************) + (* Main pretyping function *) + + let pretype_ref evdref env ref = + let c = constr_of_global ref in + make_judge c (Retyping.get_type_of env Evd.empty c) + + let pretype_sort = function + | RProp c -> judge_of_prop_contents c + | RType _ -> judge_of_new_Type () + + (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) + (* in environment [env], with existential variables [( evdref)] and *) + (* the type constraint tycon *) + let rec pretype (tycon : type_constraint) env evdref lvar c = +(* let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_rawconstr env c ++ *) +(* str " with tycon " ++ Evarutil.pr_tycon env tycon) *) +(* with _ -> () *) +(* in *) + match c with + | RRef (loc,ref) -> + inh_conv_coerce_to_tycon loc env evdref + (pretype_ref evdref env ref) + tycon + + | RVar (loc, id) -> + inh_conv_coerce_to_tycon loc env evdref + (pretype_id loc env !evdref lvar id) + tycon + + | REvar (loc, ev, instopt) -> + (* Ne faudrait-il pas s'assurer que hyps est bien un + sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *) + let hyps = evar_context (Evd.find ( !evdref) ev) in + let args = match instopt with + | None -> instance_from_named_context hyps + | Some inst -> failwith "Evar subtitutions not implemented" in + let c = mkEvar (ev, args) in + let j = (Retyping.get_judgment_of env ( !evdref) c) in + inh_conv_coerce_to_tycon loc env evdref j tycon + + | RPatVar (loc,(someta,n)) -> + anomaly "Found a pattern variable in a rawterm to type" + + | RHole (loc,k) -> + let ty = + match tycon with + | Some (None, ty) -> ty + | None | Some _ -> + e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in + { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } + + | RRec (loc,fixkind,names,bl,lar,vdef) -> + let rec type_bl env ctxt = function + [] -> ctxt + | (na,k,None,ty)::bl -> + let ty' = pretype_type empty_valcon env evdref lvar ty in + let dcl = (na,None,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl + | (na,k,Some bd,ty)::bl -> + let ty' = pretype_type empty_valcon env evdref lvar ty in + let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in + let dcl = (na,Some bd'.uj_val,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in + let ctxtv = Array.map (type_bl env empty_rel_context) bl in + let larj = + array_map2 + (fun e ar -> + pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) + ctxtv lar in + let lara = Array.map (fun a -> a.utj_val) larj in + let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in + let nbfix = Array.length lar in + let names = Array.map (fun id -> Name id) names in + (* Note: bodies are not used by push_rec_types, so [||] is safe *) + let newenv = + let marked_ftys = + Array.map (fun ty -> let sort = Retyping.get_type_of env !evdref ty in + mkApp (Lazy.force Subtac_utils.fix_proto, [| sort; ty |])) + ftys + in + push_rec_types (names,marked_ftys,[||]) env + in + let fixi = match fixkind with RFix (vn, i) -> i | RCoFix i -> i in + let vdefj = + array_map2_i + (fun i ctxt def -> + let fty = + let ty = ftys.(i) in + if i = fixi then ( + Option.iter (fun tycon -> + evdref := Coercion.inh_conv_coerces_to loc env !evdref ftys.(i) tycon) + tycon; + nf_evar !evdref ty) + else ty + in + (* we lift nbfix times the type in tycon, because of + * the nbfix variables pushed to newenv *) + let (ctxt,ty) = + decompose_prod_n_assum (rel_context_length ctxt) + (lift nbfix fty) in + let nenv = push_rel_context ctxt newenv in + let j = pretype (mk_tycon ty) nenv evdref lvar def in + { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; + uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) + ctxtv vdef in + evar_type_fixpoint loc env evdref names ftys vdefj; + let ftys = Array.map (nf_evar ( !evdref)) ftys in + let fdefs = Array.map (fun x -> nf_evar ( !evdref) (j_val x)) vdefj in + let fixj = match fixkind with + | RFix (vn,i) -> + (* First, let's find the guard indexes. *) + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally + doesn't seem worth the effort (except for huge mutual + fixpoints ?) *) + let possible_indexes = Array.to_list (Array.mapi + (fun i (n,_) -> match n with + | Some n -> [n] + | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i)) + vn) + in + let fixdecls = (names,ftys,fdefs) in + let indexes = search_guard loc env possible_indexes fixdecls in + make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) + | RCoFix i -> + let cofix = (i,(names,ftys,fdefs)) in + (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e); + make_judge (mkCoFix cofix) ftys.(i) in + inh_conv_coerce_to_tycon loc env evdref fixj tycon + + | RSort (loc,s) -> + inh_conv_coerce_to_tycon loc env evdref (pretype_sort s) tycon + + | RApp (loc,f,args) -> + let length = List.length args in + let ftycon = + let ty = + if length > 0 then + match tycon with + | None -> None + | Some (None, ty) -> mk_abstr_tycon length ty + | Some (Some (init, cur), ty) -> + Some (Some (length + init, length + cur), ty) + else tycon + in + match ty with + | Some (_, t) when Subtac_coercion.disc_subset t = None -> ty + | _ -> None + in + let fj = pretype ftycon env evdref lvar f in + let floc = loc_of_rawconstr f in + let rec apply_rec env n resj tycon = function + | [] -> resj + | c::rest -> + let argloc = loc_of_rawconstr c in + let resj = evd_comb1 (Coercion.inh_app_fun env) evdref resj in + let resty = whd_betadeltaiota env ( !evdref) resj.uj_type in + match kind_of_term resty with + | Prod (na,c1,c2) -> + Option.iter (fun ty -> evdref := + Coercion.inh_conv_coerces_to loc env !evdref resty ty) tycon; + let evd, (_, _, tycon) = split_tycon loc env !evdref tycon in + evdref := evd; + let hj = pretype (mk_tycon (nf_evar !evdref c1)) env evdref lvar c in + let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in + let typ' = nf_evar !evdref typ in + apply_rec env (n+1) + { uj_val = nf_evar !evdref value; + uj_type = nf_evar !evdref typ' } + (Option.map (fun (abs, c) -> abs, nf_evar !evdref c) tycon) rest + + | _ -> + let hj = pretype empty_tycon env evdref lvar c in + error_cant_apply_not_functional_loc + (join_loc floc argloc) env ( !evdref) + resj [hj] + in + let resj = j_nf_evar ( !evdref) (apply_rec env 1 fj ftycon args) in + let resj = + match kind_of_term resj.uj_val with + | App (f,args) when isInd f or isConst f -> + let sigma = !evdref in + let c = mkApp (f,Array.map (whd_evar sigma) args) in + let t = Retyping.get_type_of env sigma c in + make_judge c t + | _ -> resj in + inh_conv_coerce_to_tycon loc env evdref resj tycon + + | RLambda(loc,name,k,c1,c2) -> + let tycon' = evd_comb1 + (fun evd tycon -> + match tycon with + | None -> evd, tycon + | Some ty -> + let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in + evd, Some ty') + evdref tycon + in + let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in + let dom_valcon = valcon_of_tycon dom in + let j = pretype_type dom_valcon env evdref lvar c1 in + let var = (name,None,j.utj_val) in + let j' = pretype rng (push_rel var env) evdref lvar c2 in + let resj = judge_of_abstraction env name j j' in + inh_conv_coerce_to_tycon loc env evdref resj tycon + + | RProd(loc,name,k,c1,c2) -> + let j = pretype_type empty_valcon env evdref lvar c1 in + let var = (name,j.utj_val) in + let env' = push_rel_assum var env in + let j' = pretype_type empty_valcon env' evdref lvar c2 in + let resj = + try judge_of_product env name j j' + with TypeError _ as e -> Stdpp.raise_with_loc loc e in + inh_conv_coerce_to_tycon loc env evdref resj tycon + + | RLetIn(loc,name,c1,c2) -> + let j = pretype empty_tycon env evdref lvar c1 in + let t = refresh_universes j.uj_type in + let var = (name,Some j.uj_val,t) in + let tycon = lift_tycon 1 tycon in + let j' = pretype tycon (push_rel var env) evdref lvar c2 in + { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; + uj_type = subst1 j.uj_val j'.uj_type } + + | RLetTuple (loc,nal,(na,po),c,d) -> + let cj = pretype empty_tycon env evdref lvar c in + let (IndType (indf,realargs)) = + try find_rectype env ( !evdref) cj.uj_type + with Not_found -> + let cloc = loc_of_rawconstr c in + error_case_not_inductive_loc cloc env ( !evdref) cj + in + let cstrs = get_constructors env indf in + if Array.length cstrs <> 1 then + user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor"); + let cs = cstrs.(0) in + if List.length nal <> cs.cs_nargs then + user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables"); + let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) + (List.rev nal) cs.cs_args in + let env_f = push_rels fsign env in + (* Make dependencies from arity signature impossible *) + let arsgn = + let arsgn,_ = get_arity env indf in + if not !allow_anonymous_refs then + List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + else arsgn + in + let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let nar = List.length arsgn in + (match po with + | Some p -> + let env_p = push_rels psign env in + let pj = pretype_type empty_valcon env_p evdref lvar p in + let ccl = nf_evar ( !evdref) pj.utj_val in + let psign = make_arity_signature env true indf in (* with names *) + let p = it_mkLambda_or_LetIn ccl psign in + let inst = + (Array.to_list cs.cs_concl_realargs) + @[build_dependent_constructor cs] in + let lp = lift cs.cs_nargs p in + let fty = hnf_lam_applist env ( !evdref) lp inst in + let fj = pretype (mk_tycon fty) env_f evdref lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let v = + let mis,_ = dest_ind_family indf in + let ci = make_case_info env mis LetStyle in + mkCase (ci, p, cj.uj_val,[|f|]) in + { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } + + | None -> + let tycon = lift_tycon cs.cs_nargs tycon in + let fj = pretype tycon env_f evdref lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let ccl = nf_evar ( !evdref) fj.uj_type in + let ccl = + if noccur_between 1 cs.cs_nargs ccl then + lift (- cs.cs_nargs) ccl + else + error_cant_find_case_type_loc loc env ( !evdref) + cj.uj_val in + let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in + let v = + let mis,_ = dest_ind_family indf in + let ci = make_case_info env mis LetStyle in + mkCase (ci, p, cj.uj_val,[|f|] ) + in + { uj_val = v; uj_type = ccl }) + + | RIf (loc,c,(na,po),b1,b2) -> + let cj = pretype empty_tycon env evdref lvar c in + let (IndType (indf,realargs)) = + try find_rectype env ( !evdref) cj.uj_type + with Not_found -> + let cloc = loc_of_rawconstr c in + error_case_not_inductive_loc cloc env ( !evdref) cj in + let cstrs = get_constructors env indf in + if Array.length cstrs <> 2 then + user_err_loc (loc,"", + str "If is only for inductive types with two constructors."); + + let arsgn = + let arsgn,_ = get_arity env indf in + if not !allow_anonymous_refs then + (* Make dependencies from arity signature impossible *) + List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + else arsgn + in + let nar = List.length arsgn in + let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let pred,p = match po with + | Some p -> + let env_p = push_rels psign env in + let pj = pretype_type empty_valcon env_p evdref lvar p in + let ccl = nf_evar ( !evdref) pj.utj_val in + let pred = it_mkLambda_or_LetIn ccl psign in + let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in + let jtyp = inh_conv_coerce_to_tycon loc env evdref {uj_val = pred; + uj_type = typ} tycon + in + jtyp.uj_val, jtyp.uj_type + | None -> + let p = match tycon with + | Some (None, ty) -> ty + | None | Some _ -> + e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) + in + it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in + let pred = nf_evar ( !evdref) pred in + let p = nf_evar ( !evdref) p in + (* msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*) + let f cs b = + let n = rel_context_length cs.cs_args in + let pi = lift n pred in (* liftn n 2 pred ? *) + let pi = beta_applist (pi, [build_dependent_constructor cs]) in + let csgn = + if not !allow_anonymous_refs then + List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args + else + List.map + (fun (n, b, t) -> + match n with + Name _ -> (n, b, t) + | Anonymous -> (Name (id_of_string "H"), b, t)) + cs.cs_args + in + let env_c = push_rels csgn env in +(* msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *) + let bj = pretype (mk_tycon pi) env_c evdref lvar b in + it_mkLambda_or_LetIn bj.uj_val cs.cs_args in + let b1 = f cstrs.(0) b1 in + let b2 = f cstrs.(1) b2 in + let v = + let mis,_ = dest_ind_family indf in + let ci = make_case_info env mis IfStyle in + mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + in + { uj_val = v; uj_type = p } + + | RCases (loc,sty,po,tml,eqns) -> + Cases.compile_cases loc sty + ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) + tycon env (* loc *) (po,tml,eqns) + + | RCast (loc,c,k) -> + let cj = + match k with + CastCoerce -> + let cj = pretype empty_tycon env evdref lvar c in + evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj + | CastConv (k,t) -> + let tj = pretype_type empty_valcon env evdref lvar t in + let cj = pretype (mk_tycon tj.utj_val) env evdref lvar c in + (* User Casts are for helping pretyping, experimentally not to be kept*) + (* ... except for Correctness *) + let v = mkCast (cj.uj_val, k, tj.utj_val) in + { uj_val = v; uj_type = tj.utj_val } + in + inh_conv_coerce_to_tycon loc env evdref cj tycon + + | RDynamic (loc,d) -> + if (Dyn.tag d) = "constr" then + let c = constr_out d in + let j = (Retyping.get_judgment_of env ( !evdref) c) in + j + (*inh_conv_coerce_to_tycon loc env evdref j tycon*) + else + user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic.")) + + (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) + and pretype_type valcon env evdref lvar = function + | RHole loc -> + (match valcon with + | Some v -> + let s = + let sigma = !evdref in + let t = Retyping.get_type_of env sigma v in + match kind_of_term (whd_betadeltaiota env sigma t) with + | Sort s -> s + | Evar ev when is_Type (existential_type sigma ev) -> + evd_comb1 (define_evar_as_sort) evdref ev + | _ -> anomaly "Found a type constraint which is not a type" + in + { utj_val = v; + utj_type = s } + | None -> + let s = new_Type_sort () in + { utj_val = e_new_evar evdref env ~src:loc (mkSort s); + utj_type = s}) + | c -> + let j = pretype empty_tycon env evdref lvar c in + let loc = loc_of_rawconstr c in + let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in + match valcon with + | None -> tj + | Some v -> + if e_cumul env evdref v tj.utj_val then tj + else + error_unexpected_type_loc + (loc_of_rawconstr c) env ( !evdref) tj.utj_val v + + let pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c = + let c' = match kind with + | OfType exptyp -> + let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in + (pretype tycon env evdref lvar c).uj_val + | IsType -> + (pretype_type empty_valcon env evdref lvar c).utj_val in + evdref := fst (consider_remaining_unif_problems env !evdref); + if resolve_classes then + evdref := + Typeclasses.resolve_typeclasses ~onlyargs:false + ~split:true ~fail:fail_evar env !evdref; + let c = if expand_evar then nf_evar !evdref c' else c' in + if fail_evar then check_evars env Evd.empty !evdref c; + c + + (* TODO: comment faire remonter l'information si le typage a resolu des + variables du sigma original. il faudrait que la fonction de typage + retourne aussi le nouveau sigma... + *) + + let understand_judgment sigma env c = + let evdref = ref (create_evar_defs sigma) in + let j = pretype empty_tycon env evdref ([],[]) c in + let evd,_ = consider_remaining_unif_problems env !evdref in + let j = j_nf_evar evd j in + check_evars env sigma evd (mkCast(j.uj_val,DEFAULTcast, j.uj_type)); + j + + let understand_judgment_tcc evdref env c = + let j = pretype empty_tycon env evdref ([],[]) c in + j_nf_evar !evdref j + + (* Raw calls to the unsafe inference machine: boolean says if we must + fail on unresolved evars; the unsafe_judgment list allows us to + extend env with some bindings *) + + let ise_pretype_gen expand_evar fail_evar resolve_classes sigma env lvar kind c = + let evdref = ref (Evd.create_evar_defs sigma) in + let c = pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c in + !evdref, c + + (** Entry points of the high-level type synthesis algorithm *) + + let understand_gen kind sigma env c = + snd (ise_pretype_gen true true true sigma env ([],[]) kind c) + + let understand sigma env ?expected_type:exptyp c = + snd (ise_pretype_gen true true true sigma env ([],[]) (OfType exptyp) c) + + let understand_type sigma env c = + snd (ise_pretype_gen true false true sigma env ([],[]) IsType c) + + let understand_ltac expand_evar sigma env lvar kind c = + ise_pretype_gen expand_evar false true sigma env lvar kind c + + let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c = + ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c + + let understand_tcc_evars ?(fail_evar=false) ?(resolve_classes=true) evdref env kind c = + pretype_gen true fail_evar resolve_classes evdref env ([],[]) kind c +end + +module Default : S = SubtacPretyping_F(Coercion.Default) diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml new file mode 100644 index 00000000..06a80f68 --- /dev/null +++ b/plugins/subtac/subtac_utils.ml @@ -0,0 +1,484 @@ +open Evd +open Libnames +open Coqlib +open Term +open Names +open Util + +let ($) f x = f x + +(****************************************************************************) +(* Library linking *) + +let contrib_name = "Program" + +let subtac_dir = [contrib_name] +let fix_sub_module = "Wf" +let utils_module = "Utils" +let fixsub_module = subtac_dir @ [fix_sub_module] +let utils_module = subtac_dir @ [utils_module] +let tactics_module = subtac_dir @ ["Tactics"] +let init_constant dir s = gen_constant contrib_name dir s +let init_reference dir s = gen_reference contrib_name dir s + +let fixsub = lazy (init_constant fixsub_module "Fix_sub") +let ex_pi1 = lazy (init_constant utils_module "ex_pi1") +let ex_pi2 = lazy (init_constant utils_module "ex_pi2") + +let make_ref l s = lazy (init_reference l s) +let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded" +let acc_ref = make_ref ["Init";"Wf"] "Acc" +let acc_inv_ref = make_ref ["Init";"Wf"] "Acc_inv" +let fix_sub_ref = make_ref fixsub_module "Fix_sub" +let measure_on_R_ref = make_ref fixsub_module "MR" +let fix_measure_sub_ref = make_ref fixsub_module "Fix_measure_sub" +let refl_ref = make_ref ["Init";"Logic"] "refl_equal" + +let make_ref s = Qualid (dummy_loc, qualid_of_string s) +let lt_ref = make_ref "Init.Peano.lt" +let sig_ref = make_ref "Init.Specif.sig" +let proj1_sig_ref = make_ref "Init.Specif.proj1_sig" +let proj2_sig_ref = make_ref "Init.Specif.proj2_sig" + +let build_sig () = + { proj1 = init_constant ["Init"; "Specif"] "proj1_sig"; + proj2 = init_constant ["Init"; "Specif"] "proj2_sig"; + elim = init_constant ["Init"; "Specif"] "sig_rec"; + intro = init_constant ["Init"; "Specif"] "exist"; + typ = init_constant ["Init"; "Specif"] "sig" } + +let sig_ = lazy (build_sig ()) + +let fix_proto = lazy (init_constant tactics_module "fix_proto") +let fix_proto_ref () = + match Nametab.global (make_ref "Program.Tactics.fix_proto") with + | ConstRef c -> c + | _ -> assert false + +let eq_ind = lazy (init_constant ["Init"; "Logic"] "eq") +let eq_rec = lazy (init_constant ["Init"; "Logic"] "eq_rec") +let eq_rect = lazy (init_constant ["Init"; "Logic"] "eq_rect") +let eq_refl = lazy (init_constant ["Init"; "Logic"] "refl_equal") +let eq_ind_ref = lazy (init_reference ["Init"; "Logic"] "eq") +let refl_equal_ref = lazy (init_reference ["Init"; "Logic"] "refl_equal") + +let not_ref = lazy (init_constant ["Init"; "Logic"] "not") + +let and_typ = lazy (Coqlib.build_coq_and ()) + +let eqdep_ind = lazy (init_constant [ "Logic";"Eqdep"] "eq_dep") +let eqdep_rec = lazy (init_constant ["Logic";"Eqdep"] "eq_dep_rec") +let eqdep_ind_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep") +let eqdep_intro_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep_intro") + +let jmeq_ind = + lazy (check_required_library ["Coq";"Logic";"JMeq"]; + init_constant ["Logic";"JMeq"] "JMeq") +let jmeq_rec = + lazy (check_required_library ["Coq";"Logic";"JMeq"]; + init_constant ["Logic";"JMeq"] "JMeq_rec") +let jmeq_refl = + lazy (check_required_library ["Coq";"Logic";"JMeq"]; + init_constant ["Logic";"JMeq"] "JMeq_refl") + +let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex") +let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro") + +let proj1 = lazy (init_constant ["Init"; "Logic"] "proj1") +let proj2 = lazy (init_constant ["Init"; "Logic"] "proj2") + +let boolind = lazy (init_constant ["Init"; "Datatypes"] "bool") +let sumboolind = lazy (init_constant ["Init"; "Specif"] "sumbool") +let natind = lazy (init_constant ["Init"; "Datatypes"] "nat") +let intind = lazy (init_constant ["ZArith"; "binint"] "Z") +let existSind = lazy (init_constant ["Init"; "Specif"] "sigS") + +let existS = lazy (build_sigma_type ()) + +let prod = lazy (build_prod ()) + + +(* orders *) +let well_founded = lazy (init_constant ["Init"; "Wf"] "well_founded") +let fix = lazy (init_constant ["Init"; "Wf"] "Fix") +let acc = lazy (init_constant ["Init"; "Wf"] "Acc") +let acc_inv = lazy (init_constant ["Init"; "Wf"] "Acc_inv") + +let extconstr = Constrextern.extern_constr true (Global.env ()) +let extsort s = Constrextern.extern_constr true (Global.env ()) (mkSort s) + +open Pp + +let my_print_constr = Termops.print_constr_env +let my_print_constr_expr = Ppconstr.pr_constr_expr +let my_print_rel_context env ctx = Printer.pr_rel_context env ctx +let my_print_context = Termops.print_rel_context +let my_print_named_context = Termops.print_named_context +let my_print_env = Termops.print_env +let my_print_rawconstr = Printer.pr_rawconstr_env +let my_print_evardefs = Evd.pr_evar_map + +let my_print_tycon_type = Evarutil.pr_tycon_type + +let debug_level = 2 + +let debug_on = true + +let debug n s = + if debug_on then + if !Flags.debug && n >= debug_level then + msgnl s + else () + else () + +let debug_msg n s = + if debug_on then + if !Flags.debug && n >= debug_level then s + else mt () + else mt () + +let trace s = + if debug_on then + if !Flags.debug && debug_level > 0 then msgnl s + else () + else () + +let rec pp_list f = function + [] -> mt() + | x :: y -> f x ++ spc () ++ pp_list f y + +let wf_relations = Hashtbl.create 10 + +let std_relations () = + let add k v = Hashtbl.add wf_relations k v in + add (init_constant ["Init"; "Peano"] "lt") + (lazy (init_constant ["Arith"; "Wf_nat"] "lt_wf")) + +let std_relations = Lazy.lazy_from_fun std_relations + +type binders = Topconstr.local_binder list + +let app_opt c e = + match c with + Some constr -> constr e + | None -> e + +let print_args env args = + Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "") + +let make_existential loc ?(opaque = Define true) env isevars c = + let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in + let (key, args) = destEvar evar in + (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++ + print_args env args ++ str " for type: "++ + my_print_constr env c) with _ -> ()); + evar + +let make_existential_expr loc env c = + let key = Evarutil.new_untyped_evar () in + let evar = Topconstr.CEvar (loc, key, None) in + debug 2 (str "Constructed evar " ++ int key); + evar + +let string_of_hole_kind = function + | ImplicitArg _ -> "ImplicitArg" + | BinderType _ -> "BinderType" + | QuestionMark _ -> "QuestionMark" + | CasesType -> "CasesType" + | InternalHole -> "InternalHole" + | TomatchTypeParameter _ -> "TomatchTypeParameter" + | GoalEvar -> "GoalEvar" + | ImpossibleCase -> "ImpossibleCase" + | MatchingVar _ -> "MatchingVar" + +let evars_of_term evc init c = + let rec evrec acc c = + match kind_of_term c with + | Evar (n, _) when Evd.mem evc n -> Evd.add acc n (Evd.find evc n) + | Evar (n, _) -> assert(false) + | _ -> fold_constr evrec acc c + in + evrec init c + +let non_instanciated_map env evd evm = + List.fold_left + (fun evm (key, evi) -> + let (loc,k) = evar_source key !evd in + debug 2 (str "evar " ++ int key ++ str " has kind " ++ + str (string_of_hole_kind k)); + match k with + | QuestionMark _ -> Evd.add evm key evi + | ImplicitArg (_,_,false) -> Evd.add evm key evi + | _ -> + debug 2 (str " and is an implicit"); + Pretype_errors.error_unsolvable_implicit loc env evm (Evarutil.nf_evar_info evm evi) k None) + Evd.empty (Evarutil.non_instantiated evm) + +let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition +let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition + +let global_proof_kind = Decl_kinds.IsProof Decl_kinds.Lemma +let goal_proof_kind = Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma + +let global_fix_kind = Decl_kinds.IsDefinition Decl_kinds.Fixpoint +let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixpoint + +open Tactics +open Tacticals + +let id x = x +let filter_map f l = + let rec aux acc = function + hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl + | None -> aux acc tl) + | [] -> List.rev acc + in aux [] l + +let build_dependent_sum l = + let rec aux names conttac conttype = function + (n, t) :: ((_ :: _) as tl) -> + let hyptype = substl names t in + trace (spc () ++ str ("treating evar " ^ string_of_id n)); + (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype) + with _ -> ()); + let tac = assert_tac (Name n) hyptype in + let conttac = + (fun cont -> + conttac + (tclTHENS tac + ([intros; + (tclTHENSEQ + [constructor_tac false (Some 1) 1 + (Rawterm.ImplicitBindings [mkVar n]); + cont]); + ]))) + in + let conttype = + (fun typ -> + let tex = mkLambda (Name n, t, typ) in + conttype + (mkApp (Lazy.force ex_ind, [| t; tex |]))) + in + aux (mkVar n :: names) conttac conttype tl + | (n, t) :: [] -> + (conttac intros, conttype t) + | [] -> raise (Invalid_argument "build_dependent_sum") + in aux [] id id (List.rev l) + +open Proof_type +open Tacexpr + +let mkProj1 a b c = + mkApp (Lazy.force proj1, [| a; b; c |]) + +let mkProj2 a b c = + mkApp (Lazy.force proj2, [| a; b; c |]) + +let mk_ex_pi1 a b c = + mkApp (Lazy.force ex_pi1, [| a; b; c |]) + +let mk_ex_pi2 a b c = + mkApp (Lazy.force ex_pi2, [| a; b; c |]) + +let mkSubset name typ prop = + mkApp ((Lazy.force sig_).typ, + [| typ; mkLambda (name, typ, prop) |]) + +let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |]) +let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |]) +let mk_JMeq typ x typ' y = mkApp (Lazy.force jmeq_ind, [| typ; x ; typ'; y |]) +let mk_JMeq_refl typ x = mkApp (Lazy.force jmeq_refl, [| typ; x |]) + +let unsafe_fold_right f = function + hd :: tl -> List.fold_right f tl hd + | [] -> raise (Invalid_argument "unsafe_fold_right") + +let mk_conj l = + let conj_typ = Lazy.force and_typ in + unsafe_fold_right + (fun c conj -> + mkApp (conj_typ, [| c ; conj |])) + l + +let mk_not c = + let notc = Lazy.force not_ref in + mkApp (notc, [| c |]) + +let and_tac l hook = + let andc = Coqlib.build_coq_and () in + let rec aux ((accid, goal, tac, extract) as acc) = function + | [] -> (* Singleton *) acc + + | (id, x, elgoal, eltac) :: tl -> + let tac' = tclTHEN simplest_split (tclTHENLIST [tac; eltac]) in + let proj = fun c -> mkProj2 goal elgoal c in + let extract = List.map (fun (id, x, y, f) -> (id, x, y, (fun c -> f (mkProj1 goal elgoal c)))) extract in + aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac', + (id, x, elgoal, proj) :: extract) tl + + in + let and_proof_id, and_goal, and_tac, and_extract = + match l with + | [] -> raise (Invalid_argument "and_tac: empty list of goals") + | (hdid, x, hdg, hdt) :: tl -> + aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl + in + let and_proofid = id_of_string (and_proof_id ^ "_and_proof") in + Lemmas.start_proof and_proofid goal_kind and_goal + (hook (fun c -> List.map (fun (id, x, t, f) -> (id, x, t, f c)) and_extract)); + trace (str "Started and proof"); + Pfedit.by and_tac; + trace (str "Applied and tac") + + +let destruct_ex ext ex = + let rec aux c acc = + match kind_of_term c with + App (f, args) -> + (match kind_of_term f with + Ind i when i = Term.destInd (Lazy.force ex_ind) && Array.length args = 2 -> + let (dom, rng) = + try (args.(0), args.(1)) + with _ -> assert(false) + in + let pi1 = (mk_ex_pi1 dom rng acc) in + let rng_body = + match kind_of_term rng with + Lambda (_, _, t) -> subst1 pi1 t + | t -> rng + in + pi1 :: aux rng_body (mk_ex_pi2 dom rng acc) + | _ -> [acc]) + | _ -> [acc] + in aux ex ext + +open Rawterm + +let id_of_name = function + Name n -> n + | Anonymous -> raise (Invalid_argument "id_of_name") + +let definition_message id = + Nameops.pr_id id ++ str " is defined" + +let recursive_message v = + match Array.length v with + | 0 -> error "no recursive definition" + | 1 -> (Printer.pr_constant (Global.env ()) v.(0) ++ str " is recursively defined") + | _ -> hov 0 (prvect_with_sep pr_comma (Printer.pr_constant (Global.env ())) v ++ + spc () ++ str "are recursively defined") + +let print_message m = + Flags.if_verbose ppnl m + +(* Solve an obligation using tactics, return the corresponding proof term *) +let solve_by_tac evi t = + let id = id_of_string "H" in + try + Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl + (fun _ _ -> ()); + Pfedit.by (tclCOMPLETE t); + let _,(const,_,_,_) = Pfedit.cook_proof ignore in + Pfedit.delete_current_proof (); + Inductiveops.control_only_guard (Global.env ()) + const.Entries.const_entry_body; + const.Entries.const_entry_body + with e -> + Pfedit.delete_current_proof(); + raise e + +(* let apply_tac t goal = t goal *) + +(* let solve_by_tac evi t = *) +(* let ev = 1 in *) +(* let evm = Evd.add Evd.empty ev evi in *) +(* let goal = {it = evi; sigma = evm } in *) +(* let (res, valid) = apply_tac t goal in *) +(* if res.it = [] then *) +(* let prooftree = valid [] in *) +(* let proofterm, obls = Refiner.extract_open_proof res.sigma prooftree in *) +(* if obls = [] then proofterm *) +(* else raise Exit *) +(* else raise Exit *) + +let rec string_of_list sep f = function + [] -> "" + | x :: [] -> f x + | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl + +let string_of_intset d = + string_of_list "," string_of_int (Intset.elements d) + +(**********************************************************) +(* Pretty-printing *) +open Printer +open Ppconstr +open Nameops +open Termops +open Evd + +let pr_meta_map evd = + let ml = meta_list evd in + let pr_name = function + Name id -> str"[" ++ pr_id id ++ str"]" + | _ -> mt() in + let pr_meta_binding = function + | (mv,Cltyp (na,b)) -> + hov 0 + (pr_meta mv ++ pr_name na ++ str " : " ++ + print_constr b.rebus ++ fnl ()) + | (mv,Clval(na,b,_)) -> + hov 0 + (pr_meta mv ++ pr_name na ++ str " := " ++ + print_constr (fst b).rebus ++ fnl ()) + in + prlist pr_meta_binding ml + +let pr_idl idl = prlist_with_sep pr_spc pr_id idl + +let pr_evar_info evi = + let phyps = + (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *) + Printer.pr_named_context (Global.env()) (evar_context evi) + in + let pty = print_constr evi.evar_concl in + let pb = + match evi.evar_body with + | Evar_empty -> mt () + | Evar_defined c -> spc() ++ str"=> " ++ print_constr c + in + hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]") + +let pr_evar_map sigma = + h 0 + (prlist_with_sep pr_fnl + (fun (ev,evi) -> + h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi)) + (to_list sigma)) + +let pr_constraints pbs = + h 0 + (prlist_with_sep pr_fnl (fun (pbty,t1,t2) -> + print_constr t1 ++ spc() ++ + str (match pbty with + | Reduction.CONV -> "==" + | Reduction.CUMUL -> "<=") ++ + spc() ++ print_constr t2) pbs) + +let pr_evar_map evd = + let pp_evm = + let evars = evd in + if evars = empty then mt() else + str"EVARS:"++brk(0,1)++pr_evar_map evars++fnl() in + let pp_met = + if meta_list evd = [] then mt() else + str"METAS:"++brk(0,1)++pr_meta_map evd in + v 0 (pp_evm ++ pp_met) + +let contrib_tactics_path = + make_dirpath (List.map id_of_string ["Tactics";contrib_name;"Coq"]) +let tactics_tac s = + lazy(make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s)) + +let tactics_call tac args = + TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args)) diff --git a/plugins/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli new file mode 100644 index 00000000..d0ad334d --- /dev/null +++ b/plugins/subtac/subtac_utils.mli @@ -0,0 +1,136 @@ +open Term +open Libnames +open Coqlib +open Environ +open Pp +open Evd +open Decl_kinds +open Topconstr +open Rawterm +open Util +open Evarutil +open Names +open Sign + +val ($) : ('a -> 'b) -> 'a -> 'b +val contrib_name : string +val subtac_dir : string list +val fix_sub_module : string +val fixsub_module : string list +val init_constant : string list -> string -> constr +val init_reference : string list -> string -> global_reference +val fixsub : constr lazy_t +val well_founded_ref : global_reference lazy_t +val acc_ref : global_reference lazy_t +val acc_inv_ref : global_reference lazy_t +val fix_sub_ref : global_reference lazy_t +val measure_on_R_ref : global_reference lazy_t +val fix_measure_sub_ref : global_reference lazy_t +val refl_ref : global_reference lazy_t +val lt_ref : reference +val sig_ref : reference +val proj1_sig_ref : reference +val proj2_sig_ref : reference +val build_sig : unit -> coq_sigma_data +val sig_ : coq_sigma_data lazy_t + +val fix_proto : constr lazy_t +val fix_proto_ref : unit -> constant + +val eq_ind : constr lazy_t +val eq_rec : constr lazy_t +val eq_rect : constr lazy_t +val eq_refl : constr lazy_t + +val not_ref : constr lazy_t +val and_typ : constr lazy_t + +val eqdep_ind : constr lazy_t +val eqdep_rec : constr lazy_t + +val jmeq_ind : constr lazy_t +val jmeq_rec : constr lazy_t +val jmeq_refl : constr lazy_t + +val boolind : constr lazy_t +val sumboolind : constr lazy_t +val natind : constr lazy_t +val intind : constr lazy_t +val existSind : constr lazy_t +val existS : coq_sigma_data lazy_t +val prod : coq_sigma_data lazy_t + +val well_founded : constr lazy_t +val fix : constr lazy_t +val acc : constr lazy_t +val acc_inv : constr lazy_t +val extconstr : constr -> constr_expr +val extsort : sorts -> constr_expr + +val my_print_constr : env -> constr -> std_ppcmds +val my_print_constr_expr : constr_expr -> std_ppcmds +val my_print_evardefs : evar_map -> std_ppcmds +val my_print_context : env -> std_ppcmds +val my_print_rel_context : env -> rel_context -> std_ppcmds +val my_print_named_context : env -> std_ppcmds +val my_print_env : env -> std_ppcmds +val my_print_rawconstr : env -> rawconstr -> std_ppcmds +val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds + + +val debug : int -> std_ppcmds -> unit +val debug_msg : int -> std_ppcmds -> std_ppcmds +val trace : std_ppcmds -> unit +val wf_relations : (constr, constr lazy_t) Hashtbl.t + +type binders = local_binder list +val app_opt : ('a -> 'a) option -> 'a -> 'a +val print_args : env -> constr array -> std_ppcmds +val make_existential : loc -> ?opaque:obligation_definition_status -> + env -> evar_map ref -> types -> constr +val make_existential_expr : loc -> 'a -> 'b -> constr_expr +val string_of_hole_kind : hole_kind -> string +val evars_of_term : evar_map -> evar_map -> constr -> evar_map +val non_instanciated_map : env -> evar_map ref -> evar_map -> evar_map +val global_kind : logical_kind +val goal_kind : locality * goal_object_kind +val global_proof_kind : logical_kind +val goal_proof_kind : locality * goal_object_kind +val global_fix_kind : logical_kind +val goal_fix_kind : locality * goal_object_kind + +val mkSubset : name -> constr -> constr -> constr +val mkProj1 : constr -> constr -> constr -> constr +val mkProj1 : constr -> constr -> constr -> constr +val mk_ex_pi1 : constr -> constr -> constr -> constr +val mk_ex_pi1 : constr -> constr -> constr -> constr +val mk_eq : types -> constr -> constr -> types +val mk_eq_refl : types -> constr -> constr +val mk_JMeq : types -> constr-> types -> constr -> types +val mk_JMeq_refl : types -> constr -> constr +val mk_conj : types list -> types +val mk_not : types -> types + +val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types +val and_tac : (identifier * 'a * constr * Proof_type.tactic) list -> + ((constr -> (identifier * 'a * constr * constr) list) -> Tacexpr.declaration_hook) -> unit + +val destruct_ex : constr -> constr -> constr list + +val id_of_name : name -> identifier + +val definition_message : identifier -> std_ppcmds +val recursive_message : constant array -> std_ppcmds + +val print_message : std_ppcmds -> unit + +val solve_by_tac : evar_info -> Tacmach.tactic -> constr + +val string_of_list : string -> ('a -> string) -> 'a list -> string +val string_of_intset : Intset.t -> string + +val pr_evar_map : evar_map -> Pp.std_ppcmds + +val tactics_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr + +val pp_list : ('a -> Pp.std_ppcmds) -> 'a list -> Pp.std_ppcmds diff --git a/plugins/subtac/test/ListDep.v b/plugins/subtac/test/ListDep.v new file mode 100644 index 00000000..e3dbd127 --- /dev/null +++ b/plugins/subtac/test/ListDep.v @@ -0,0 +1,49 @@ +(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) +Require Import List. +Require Import Coq.Program.Program. + +Set Implicit Arguments. + +Definition sub_list (A : Set) (l' l : list A) := (forall v, In v l' -> In v l) /\ length l' <= length l. + +Lemma sub_list_tl : forall A : Set, forall x (l l' : list A), sub_list (x :: l) l' -> sub_list l l'. +Proof. + intros. + inversion H. + split. + intros. + apply H0. + auto with datatypes. + auto with arith. +Qed. + +Section Map_DependentRecursor. + Variable U V : Set. + Variable l : list U. + Variable f : { x : U | In x l } -> V. + + Obligations Tactic := unfold sub_list in * ; + program_simpl ; intuition. + + Program Fixpoint map_rec ( l' : list U | sub_list l' l ) + { measure length l' } : { r : list V | length r = length l' } := + match l' with + | nil => nil + | cons x tl => let tl' := map_rec tl in + f x :: tl' + end. + + Next Obligation. + destruct_call map_rec. + simpl in *. + subst l'. + simpl ; auto with arith. + Qed. + + Program Definition map : list V := map_rec l. + +End Map_DependentRecursor. + +Extraction map. +Extraction map_rec. + diff --git a/plugins/subtac/test/ListsTest.v b/plugins/subtac/test/ListsTest.v new file mode 100644 index 00000000..2cea0841 --- /dev/null +++ b/plugins/subtac/test/ListsTest.v @@ -0,0 +1,99 @@ +(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) +Require Import Coq.Program.Program. +Require Import List. + +Set Implicit Arguments. + +Section Accessors. + Variable A : Set. + + Program Definition myhd : forall (l : list A | length l <> 0), A := + fun l => + match l with + | nil => ! + | hd :: tl => hd + end. + + Program Definition mytail (l : list A | length l <> 0) : list A := + match l with + | nil => ! + | hd :: tl => tl + end. +End Accessors. + +Program Definition test_hd : nat := myhd (cons 1 nil). + +(*Eval compute in test_hd*) +(*Program Definition test_tail : list A := mytail nil.*) + +Section app. + Variable A : Set. + + Program Fixpoint app (l : list A) (l' : list A) { struct l } : + { r : list A | length r = length l + length l' } := + match l with + | nil => l' + | hd :: tl => hd :: (tl ++ l') + end + where "x ++ y" := (app x y). + + Next Obligation. + intros. + destruct_call app ; program_simpl. + Defined. + + Program Lemma app_id_l : forall l : list A, l = nil ++ l. + Proof. + simpl ; auto. + Qed. + + Program Lemma app_id_r : forall l : list A, l = l ++ nil. + Proof. + induction l ; simpl in * ; auto. + rewrite <- IHl ; auto. + Qed. + +End app. + +Extraction app. + +Section Nth. + + Variable A : Set. + + Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A := + match n, l with + | 0, hd :: _ => hd + | S n', _ :: tl => nth tl n' + | _, nil => ! + end. + + Next Obligation. + Proof. + simpl in *. auto with arith. + Defined. + + Next Obligation. + Proof. + inversion H. + Qed. + + Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A := + match l, n with + | hd :: _, 0 => hd + | _ :: tl, S n' => nth' tl n' + | nil, _ => ! + end. + Next Obligation. + Proof. + simpl in *. auto with arith. + Defined. + + Next Obligation. + Proof. + intros. + inversion H. + Defined. + +End Nth. + diff --git a/plugins/subtac/test/Mutind.v b/plugins/subtac/test/Mutind.v new file mode 100644 index 00000000..01e2d75f --- /dev/null +++ b/plugins/subtac/test/Mutind.v @@ -0,0 +1,20 @@ +Require Import List. + +Program Fixpoint f a : { x : nat | x > 0 } := + match a with + | 0 => 1 + | S a' => g a a' + end +with g a b : { x : nat | x > 0 } := + match b with + | 0 => 1 + | S b' => f b' + end. + +Check f. +Check g. + + + + + diff --git a/plugins/subtac/test/Test1.v b/plugins/subtac/test/Test1.v new file mode 100644 index 00000000..7e0755d5 --- /dev/null +++ b/plugins/subtac/test/Test1.v @@ -0,0 +1,16 @@ +Program Definition test (a b : nat) : { x : nat | x = a + b } := + ((a + b) : { x : nat | x = a + b }). +Proof. +intros. +reflexivity. +Qed. + +Print test. + +Require Import List. + +Program hd_opt (l : list nat) : { x : nat | x <> 0 } := + match l with + nil => 1 + | a :: l => a + end. diff --git a/plugins/subtac/test/euclid.v b/plugins/subtac/test/euclid.v new file mode 100644 index 00000000..97c3d941 --- /dev/null +++ b/plugins/subtac/test/euclid.v @@ -0,0 +1,24 @@ +Require Import Coq.Program.Program. +Require Import Coq.Arith.Compare_dec. +Notation "( x & y )" := (existS _ x y) : core_scope. + +Require Import Omega. + +Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf lt a} : + { q : nat & { r : nat | a = b * q + r /\ r < b } } := + if le_lt_dec b a then let (q', r) := euclid (a - b) b in + (S q' & r) + else (O & a). + +Next Obligation. + assert(b * S q' = b * q' + b) by auto with arith ; omega. +Defined. + +Program Definition test_euclid : (prod nat nat) := let (q, r) := euclid 4 2 in (q, q). + +Eval lazy beta zeta delta iota in test_euclid. + +Program Definition testsig (a : nat) : { x : nat & { y : nat | x < y } } := + (a & S a). + +Check testsig. diff --git a/plugins/subtac/test/id.v b/plugins/subtac/test/id.v new file mode 100644 index 00000000..9ae11088 --- /dev/null +++ b/plugins/subtac/test/id.v @@ -0,0 +1,46 @@ +Require Coq.Arith.Arith. + +Require Import Coq.subtac.Utils. +Program Fixpoint id (n : nat) : { x : nat | x = n } := + match n with + | O => O + | S p => S (id p) + end. +intros ; auto. + +pose (subset_simpl (id p)). +simpl in e. +unfold p0. +rewrite e. +auto. +Defined. + +Check id. +Print id. +Extraction id. + +Axiom le_gt_dec : forall n m, { n <= m } + { n > m }. +Require Import Omega. + +Program Fixpoint id_if (n : nat) { wf n lt }: { x : nat | x = n } := + if le_gt_dec n 0 then 0 + else S (id_if (pred n)). +intros. +auto with arith. +intros. +pose (subset_simpl (id_if (pred n))). +simpl in e. +rewrite e. +induction n ; auto with arith. +Defined. + +Print id_if_instance. +Extraction id_if_instance. + +Notation "( x & y )" := (@existS _ _ x y) : core_scope. + +Program Definition testsig ( a : nat ) : { x : nat & { y : nat | x = y }} := + (a & a). +intros. +auto. +Qed. diff --git a/plugins/subtac/test/measure.v b/plugins/subtac/test/measure.v new file mode 100644 index 00000000..4f938f4f --- /dev/null +++ b/plugins/subtac/test/measure.v @@ -0,0 +1,20 @@ +Notation "( x & y )" := (@existS _ _ x y) : core_scope. +Unset Printing All. +Require Import Coq.Arith.Compare_dec. + +Require Import Coq.Program.Program. + +Fixpoint size (a : nat) : nat := + match a with + 0 => 1 + | S n => S (size n) + end. + +Program Fixpoint test_measure (a : nat) {measure size a} : nat := + match a with + | S (S n) => S (test_measure n) + | 0 | S 0 => a + end. + +Check test_measure. +Print test_measure. \ No newline at end of file diff --git a/plugins/subtac/test/rec.v b/plugins/subtac/test/rec.v new file mode 100644 index 00000000..aaefd8cc --- /dev/null +++ b/plugins/subtac/test/rec.v @@ -0,0 +1,65 @@ +Require Import Coq.Arith.Arith. +Require Import Lt. +Require Import Omega. + +Axiom lt_ge_dec : forall x y : nat, { x < y } + { x >= y }. +(*Proof. + intros. + elim (le_lt_dec y x) ; intros ; auto with arith. +Defined. +*) +Require Import Coq.subtac.FixSub. +Require Import Wf_nat. + +Lemma preda_lt_a : forall a, 0 < a -> pred a < a. +auto with arith. +Qed. + +Program Fixpoint id_struct (a : nat) : nat := + match a with + 0 => 0 + | S n => S (id_struct n) + end. + +Check struct_rec. + + if (lt_ge_dec O a) + then S (wfrec (pred a)) + else O. + +Program Fixpoint wfrec (a : nat) { wf a lt } : nat := + if (lt_ge_dec O a) + then S (wfrec (pred a)) + else O. +intros. +apply preda_lt_a ; auto. + +Defined. + +Extraction wfrec. +Extraction Inline proj1_sig. +Extract Inductive bool => "bool" [ "true" "false" ]. +Extract Inductive sumbool => "bool" [ "true" "false" ]. +Extract Inlined Constant lt_ge_dec => "<". + +Extraction wfrec. +Extraction Inline lt_ge_dec le_lt_dec. +Extraction wfrec. + + +Program Fixpoint structrec (a : nat) { wf a lt } : nat := + match a with + S n => S (structrec n) + | 0 => 0 + end. +intros. +unfold n0. +omega. +Defined. + +Print structrec. +Extraction structrec. +Extraction structrec. + +Definition structrec_fun (a : nat) : nat := structrec a (lt_wf a). +Print structrec_fun. diff --git a/plugins/subtac/test/take.v b/plugins/subtac/test/take.v new file mode 100644 index 00000000..90ae8bae --- /dev/null +++ b/plugins/subtac/test/take.v @@ -0,0 +1,34 @@ +(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) +Require Import JMeq. +Require Import List. +Require Import Program. + +Set Implicit Arguments. +Obligations Tactic := idtac. + +Print cons. + +Program Fixpoint take (A : Set) (l : list A) (n : nat | n <= length l) { struct l } : { l' : list A | length l' = n } := + match n with + | 0 => nil + | S p => + match l with + | cons hd tl => let rest := take tl p in cons hd rest + | nil => ! + end + end. + +Require Import Omega. +Solve All Obligations. +Next Obligation. + destruct_call take ; program_simpl. +Defined. + +Next Obligation. + intros. + inversion H. +Defined. + + + + diff --git a/plugins/subtac/test/wf.v b/plugins/subtac/test/wf.v new file mode 100644 index 00000000..5ccc154a --- /dev/null +++ b/plugins/subtac/test/wf.v @@ -0,0 +1,48 @@ +Notation "( x & y )" := (@existS _ _ x y) : core_scope. +Unset Printing All. +Require Import Coq.Arith.Compare_dec. + +Require Import Coq.subtac.Utils. + +Ltac one_simpl_hyp := + match goal with + | [H : (`exist _ _ _) = _ |- _] => simpl in H + | [H : _ = (`exist _ _ _) |- _] => simpl in H + | [H : (`exist _ _ _) < _ |- _] => simpl in H + | [H : _ < (`exist _ _ _) |- _] => simpl in H + | [H : (`exist _ _ _) <= _ |- _] => simpl in H + | [H : _ <= (`exist _ _ _) |- _] => simpl in H + | [H : (`exist _ _ _) > _ |- _] => simpl in H + | [H : _ > (`exist _ _ _) |- _] => simpl in H + | [H : (`exist _ _ _) >= _ |- _] => simpl in H + | [H : _ >= (`exist _ _ _) |- _] => simpl in H + end. + +Ltac one_simpl_subtac := + destruct_exists ; + repeat one_simpl_hyp ; simpl. + +Ltac simpl_subtac := do 3 one_simpl_subtac ; simpl. + +Require Import Omega. +Require Import Wf_nat. + +Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt} : + { q : nat & { r : nat | a = b * q + r /\ r < b } } := + if le_lt_dec b a then let (q', r) := euclid (a - b) b in + (S q' & r) + else (O & a). +destruct b ; simpl_subtac. +omega. +simpl_subtac. +assert(x0 * S q' = x0 + x0 * q'). +rewrite <- mult_n_Sm. +omega. +rewrite H2 ; omega. +simpl_subtac. +split ; auto with arith. +omega. +apply lt_wf. +Defined. + +Check euclid_evars_proof. \ No newline at end of file diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml new file mode 100644 index 00000000..19473dfa --- /dev/null +++ b/plugins/syntax/ascii_syntax.ml @@ -0,0 +1,83 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 0 + | RRef (_,k)::l when k = glob_true -> 1+2*(uninterp_bool_list (n-1) l) + | RRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l) + | _ -> raise Non_closed_ascii in + try + let rec aux = function + | RApp (_,RRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l + | _ -> raise Non_closed_ascii in + Some (aux r) + with + Non_closed_ascii -> None + +let make_ascii_string n = + if n>=32 && n<=126 then String.make 1 (char_of_int n) + else Printf.sprintf "%03d" n + +let uninterp_ascii_string r = Option.map make_ascii_string (uninterp_ascii r) + +let _ = + Notation.declare_string_interpreter "char_scope" + (ascii_path,ascii_module) + interp_ascii_string + ([RRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true) diff --git a/plugins/syntax/ascii_syntax_plugin.mllib b/plugins/syntax/ascii_syntax_plugin.mllib new file mode 100644 index 00000000..b00f9250 --- /dev/null +++ b/plugins/syntax/ascii_syntax_plugin.mllib @@ -0,0 +1,2 @@ +Ascii_syntax +Ascii_syntax_plugin_mod diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml new file mode 100644 index 00000000..5d20c2a3 --- /dev/null +++ b/plugins/syntax/nat_syntax.ml @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* > *) + +let nat_of_int dloc n = + if is_pos_or_zero n then begin + if less_than (of_string "5000") n then + Flags.if_warn msg_warning + (strbrk "Stack overflow or segmentation fault happens when " ++ + strbrk "working with large numbers in nat (observed threshold " ++ + strbrk "may vary from 5000 to 70000 depending on your system " ++ + strbrk "limits and on the command executed)."); + let ref_O = RRef (dloc, glob_O) in + let ref_S = RRef (dloc, glob_S) in + let rec mk_nat acc n = + if n <> zero then + mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n) + else + acc + in + mk_nat ref_O n + end + else + user_err_loc (dloc, "nat_of_int", + str "Cannot interpret a negative number as a number of type nat") + +(************************************************************************) +(* Printing via scopes *) + +exception Non_closed_number + +let rec int_of_nat = function + | RApp (_,RRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a) + | RRef (_,z) when z = glob_O -> zero + | _ -> raise Non_closed_number + +let uninterp_nat p = + try + Some (int_of_nat p) + with + Non_closed_number -> None + +(************************************************************************) +(* Declare the primitive parsers and printers *) + +let _ = + Notation.declare_numeral_interpreter "nat_scope" + (nat_path,["Coq";"Init";"Datatypes"]) + nat_of_int + ([RRef (dummy_loc,glob_S); RRef (dummy_loc,glob_O)], uninterp_nat, true) diff --git a/plugins/syntax/nat_syntax_plugin.mllib b/plugins/syntax/nat_syntax_plugin.mllib new file mode 100644 index 00000000..69b0cb20 --- /dev/null +++ b/plugins/syntax/nat_syntax_plugin.mllib @@ -0,0 +1,2 @@ +Nat_syntax +Nat_syntax_plugin_mod diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml new file mode 100644 index 00000000..4375d5e0 --- /dev/null +++ b/plugins/syntax/numbers_syntax.ml @@ -0,0 +1,330 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + ConstructRef ((bigN_t,0), + if less_than i n_inlined then + (to_int i)+1 + else + (to_int n_inlined)+1 + ) + +(*bigZ stuff*) +let bigZ_module = ["Coq"; "Numbers"; "Integer"; "BigZ"; "BigZ" ] +let bigZ_path = make_path (bigZ_module@["BigZ"]) "t" +let bigZ_t = make_mind_mpdot bigZ_module "BigZ" "t_" +let bigZ_scope = "bigZ_scope" + +let bigZ_pos = ConstructRef ((bigZ_t,0),1) +let bigZ_neg = ConstructRef ((bigZ_t,0),2) + + +(*bigQ stuff*) +let bigQ_module = ["Coq"; "Numbers"; "Rational"; "BigQ"; "BigQ"] +let bigQ_path = make_path (bigQ_module@["BigQ"]) "t" +let bigQ_t = make_mind_mpdot bigQ_module "BigQ" "t_" +let bigQ_scope = "bigQ_scope" + +let bigQ_z = ConstructRef ((bigQ_t,0),1) + + +(*** Definition of the Non_closed exception, used in the pretty printing ***) +exception Non_closed + +(*** Parsing for int31 in digital notation ***) + +(* parses a *non-negative* integer (from bigint.ml) into an int31 + wraps modulo 2^31 *) +let int31_of_pos_bigint dloc n = + let ref_construct = RRef (dloc, int31_construct) in + let ref_0 = RRef (dloc, int31_0) in + let ref_1 = RRef (dloc, int31_1) in + let rec args counter n = + if counter <= 0 then + [] + else + let (q,r) = div2_with_rest n in + (if r then ref_1 else ref_0)::(args (counter-1) q) + in + RApp (dloc, ref_construct, List.rev (args 31 n)) + +let error_negative dloc = + Util.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.") + +let interp_int31 dloc n = + if is_pos_or_zero n then + int31_of_pos_bigint dloc n + else + error_negative dloc + +(* Pretty prints an int31 *) + +let bigint_of_int31 = + let rec args_parsing args cur = + match args with + | [] -> cur + | (RRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur) + | (RRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur)) + | _ -> raise Non_closed + in + function + | RApp (_, RRef (_, c), args) when c=int31_construct -> args_parsing args zero + | _ -> raise Non_closed + +let uninterp_int31 i = + try + Some (bigint_of_int31 i) + with Non_closed -> + None + +(* Actually declares the interpreter for int31 *) +let _ = Notation.declare_numeral_interpreter int31_scope + (int31_path, int31_module) + interp_int31 + ([RRef (Util.dummy_loc, int31_construct)], + uninterp_int31, + true) + + +(*** Parsing for bigN in digital notation ***) +(* the base for bigN (in Coq) that is 2^31 in our case *) +let base = pow two (of_string "31") + +(* base of the bigN of height N : *) +let rank n = pow base (pow two n) + +(* splits a number bi at height n, that is the rest needs 2^n int31 to be stored + it is expected to be used only when the quotient would also need 2^n int31 to be + stored *) +let split_at n bi = + euclid bi (rank (sub_1 n)) + +(* search the height of the Coq bigint needed to represent the integer bi *) +let height bi = + let rec height_aux n = + if less_than bi (rank n) then + n + else + height_aux (add_1 n) + in + height_aux zero + + +(* n must be a non-negative integer (from bigint.ml) *) +let word_of_pos_bigint dloc hght n = + let ref_W0 = RRef (dloc, zn2z_W0) in + let ref_WW = RRef (dloc, zn2z_WW) in + let rec decomp hgt n = + if is_neg_or_zero hgt then + int31_of_pos_bigint dloc n + else if equal n zero then + RApp (dloc, ref_W0, [RHole (dloc, Evd.InternalHole)]) + else + let (h,l) = split_at hgt n in + RApp (dloc, ref_WW, [RHole (dloc, Evd.InternalHole); + decomp (sub_1 hgt) h; + decomp (sub_1 hgt) l]) + in + decomp hght n + +let bigN_of_pos_bigint dloc n = + let ref_constructor i = RRef (dloc, bigN_constructor i) in + let result h word = RApp (dloc, ref_constructor h, if less_than h n_inlined then + [word] + else + [Nat_syntax.nat_of_int dloc (sub h n_inlined); + word]) + in + let hght = height n in + result hght (word_of_pos_bigint dloc hght n) + +let bigN_error_negative dloc = + Util.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.") + +let interp_bigN dloc n = + if is_pos_or_zero n then + bigN_of_pos_bigint dloc n + else + bigN_error_negative dloc + + +(* Pretty prints a bigN *) + +let bigint_of_word = + let rec get_height rc = + match rc with + | RApp (_,RRef(_,c), [_;lft;rght]) when c = zn2z_WW -> + let hleft = get_height lft in + let hright = get_height rght in + add_1 + (if less_than hleft hright then + hright + else + hleft) + | _ -> zero + in + let rec transform hght rc = + match rc with + | RApp (_,RRef(_,c),_) when c = zn2z_W0-> zero + | RApp (_,RRef(_,c), [_;lft;rght]) when c=zn2z_WW-> let new_hght = sub_1 hght in + add (mult (rank new_hght) + (transform (new_hght) lft)) + (transform (new_hght) rght) + | _ -> bigint_of_int31 rc + in + fun rc -> + let hght = get_height rc in + transform hght rc + +let bigint_of_bigN rc = + match rc with + | RApp (_,_,[one_arg]) -> bigint_of_word one_arg + | RApp (_,_,[_;second_arg]) -> bigint_of_word second_arg + | _ -> raise Non_closed + +let uninterp_bigN rc = + try + Some (bigint_of_bigN rc) + with Non_closed -> + None + + +(* declare the list of constructors of bigN used in the declaration of the + numeral interpreter *) + +let bigN_list_of_constructors = + let rec build i = + if less_than i (add_1 n_inlined) then + RRef (Util.dummy_loc, bigN_constructor i)::(build (add_1 i)) + else + [] + in + build zero + +(* Actually declares the interpreter for bigN *) +let _ = Notation.declare_numeral_interpreter bigN_scope + (bigN_path, bigN_module) + interp_bigN + (bigN_list_of_constructors, + uninterp_bigN, + true) + + +(*** Parsing for bigZ in digital notation ***) +let interp_bigZ dloc n = + let ref_pos = RRef (dloc, bigZ_pos) in + let ref_neg = RRef (dloc, bigZ_neg) in + if is_pos_or_zero n then + RApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n]) + else + RApp (dloc, ref_neg, [bigN_of_pos_bigint dloc (neg n)]) + +(* pretty printing functions for bigZ *) +let bigint_of_bigZ = function + | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_pos -> bigint_of_bigN one_arg + | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_neg -> + let opp_val = bigint_of_bigN one_arg in + if equal opp_val zero then + raise Non_closed + else + neg opp_val + | _ -> raise Non_closed + + +let uninterp_bigZ rc = + try + Some (bigint_of_bigZ rc) + with Non_closed -> + None + +(* Actually declares the interpreter for bigZ *) +let _ = Notation.declare_numeral_interpreter bigZ_scope + (bigZ_path, bigZ_module) + interp_bigZ + ([RRef (Util.dummy_loc, bigZ_pos); + RRef (Util.dummy_loc, bigZ_neg)], + uninterp_bigZ, + true) + +(*** Parsing for bigQ in digital notation ***) +let interp_bigQ dloc n = + let ref_z = RRef (dloc, bigQ_z) in + RApp (dloc, ref_z, [interp_bigZ dloc n]) + +let uninterp_bigQ rc = + try match rc with + | RApp (_, RRef(_,c), [one_arg]) when c = bigQ_z -> + Some (bigint_of_bigZ one_arg) + | _ -> None (* we don't pretty-print yet fractions *) + with Non_closed -> None + +(* Actually declares the interpreter for bigQ *) +let _ = Notation.declare_numeral_interpreter bigQ_scope + (bigQ_path, bigQ_module) + interp_bigQ + ([RRef (Util.dummy_loc, bigQ_z)], uninterp_bigQ, + true) diff --git a/plugins/syntax/numbers_syntax_plugin.mllib b/plugins/syntax/numbers_syntax_plugin.mllib new file mode 100644 index 00000000..ebc0bb20 --- /dev/null +++ b/plugins/syntax/numbers_syntax_plugin.mllib @@ -0,0 +1,2 @@ +Numbers_syntax +Numbers_syntax_plugin_mod diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml new file mode 100644 index 00000000..f85309e6 --- /dev/null +++ b/plugins/syntax/r_syntax.ml @@ -0,0 +1,125 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* zero then r_of_pos n else RRef(dloc,glob_R0) + +let r_of_int dloc z = + if is_strictly_neg z then + RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) + else + r_of_posint dloc z + +(**********************************************************************) +(* Printing R via scopes *) +(**********************************************************************) + +let bignat_of_r = +(* for numbers > 1 *) +let rec bignat_of_pos = function + (* 1+1 *) + | RApp (_,RRef (_,p), [RRef (_,o1); RRef (_,o2)]) + when p = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 -> two + (* 1+(1+1) *) + | RApp (_,RRef (_,p1), [RRef (_,o1); + RApp(_,RRef (_,p2),[RRef(_,o2);RRef(_,o3)])]) + when p1 = glob_Rplus & p2 = glob_Rplus & + o1 = glob_R1 & o2 = glob_R1 & o3 = glob_R1 -> three + (* (1+1)*b *) + | RApp (_,RRef (_,p), [a; b]) when p = glob_Rmult -> + if bignat_of_pos a <> two then raise Non_closed_number; + mult_2 (bignat_of_pos b) + (* 1+(1+1)*b *) + | RApp (_,RRef (_,p1), [RRef (_,o); RApp (_,RRef (_,p2),[a;b])]) + when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1 -> + if bignat_of_pos a <> two then raise Non_closed_number; + add_1 (mult_2 (bignat_of_pos b)) + | _ -> raise Non_closed_number +in +let bignat_of_r = function + | RRef (_,a) when a = glob_R0 -> zero + | RRef (_,a) when a = glob_R1 -> one + | r -> bignat_of_pos r +in +bignat_of_r + +let bigint_of_r = function + | RApp (_,RRef (_,o), [a]) when o = glob_Ropp -> + let n = bignat_of_r a in + if n = zero then raise Non_closed_number; + neg n + | a -> bignat_of_r a + +let uninterp_r p = + try + Some (bigint_of_r p) + with Non_closed_number -> + None + +let _ = Notation.declare_numeral_interpreter "R_scope" + (r_path,["Coq";"Reals";"Rdefinitions"]) + r_of_int + ([RRef(dummy_loc,glob_Ropp);RRef(dummy_loc,glob_R0); + RRef(dummy_loc,glob_Rplus);RRef(dummy_loc,glob_Rmult); + RRef(dummy_loc,glob_R1)], + uninterp_r, + false) diff --git a/plugins/syntax/r_syntax_plugin.mllib b/plugins/syntax/r_syntax_plugin.mllib new file mode 100644 index 00000000..5c173a14 --- /dev/null +++ b/plugins/syntax/r_syntax_plugin.mllib @@ -0,0 +1,2 @@ +R_syntax +R_syntax_plugin_mod diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml new file mode 100644 index 00000000..bc02357a --- /dev/null +++ b/plugins/syntax/string_syntax.ml @@ -0,0 +1,69 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + (match uninterp_ascii a with + | Some c -> Buffer.add_char b (Char.chr c); aux s + | _ -> raise Non_closed_string) + | RRef (_,z) when z = force glob_EmptyString -> + Some (Buffer.contents b) + | _ -> + raise Non_closed_string + in aux r + with + Non_closed_string -> None + +let _ = + Notation.declare_string_interpreter "string_scope" + (string_path,["Coq";"Strings";"String"]) + interp_string + ([RRef (dummy_loc,static_glob_String); + RRef (dummy_loc,static_glob_EmptyString)], + uninterp_string, true) diff --git a/plugins/syntax/string_syntax_plugin.mllib b/plugins/syntax/string_syntax_plugin.mllib new file mode 100644 index 00000000..b108c9e0 --- /dev/null +++ b/plugins/syntax/string_syntax_plugin.mllib @@ -0,0 +1,2 @@ +String_syntax +String_syntax_plugin_mod diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml new file mode 100644 index 00000000..f6afd080 --- /dev/null +++ b/plugins/syntax/z_syntax.ml @@ -0,0 +1,194 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* RApp (dloc, ref_xO,[pos_of q]) + | (q,true) when q <> zero -> RApp (dloc,ref_xI,[pos_of q]) + | (q,true) -> ref_xH + in + pos_of x + +let error_non_positive dloc = + user_err_loc (dloc, "interp_positive", + str "Only strictly positive numbers in type \"positive\".") + +let interp_positive dloc n = + if is_strictly_pos n then pos_of_bignat dloc n + else error_non_positive dloc + +(**********************************************************************) +(* Printing positive via scopes *) +(**********************************************************************) + +let rec bignat_of_pos = function + | RApp (_, RRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a) + | RApp (_, RRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a)) + | RRef (_, a) when a = glob_xH -> Bigint.one + | _ -> raise Non_closed_number + +let uninterp_positive p = + try + Some (bignat_of_pos p) + with Non_closed_number -> + None + +(************************************************************************) +(* Declaring interpreters and uninterpreters for positive *) +(************************************************************************) + +let _ = Notation.declare_numeral_interpreter "positive_scope" + (positive_path,positive_module) + interp_positive + ([RRef (dummy_loc, glob_xI); + RRef (dummy_loc, glob_xO); + RRef (dummy_loc, glob_xH)], + uninterp_positive, + true) + +(**********************************************************************) +(* Parsing N via scopes *) +(**********************************************************************) + +let binnat_module = ["Coq";"NArith";"BinNat"] +let n_kn = make_kn (make_dir binnat_module) (id_of_string "N") +let glob_n = IndRef (n_kn,0) +let path_of_N0 = ((n_kn,0),1) +let path_of_Npos = ((n_kn,0),2) +let glob_N0 = ConstructRef path_of_N0 +let glob_Npos = ConstructRef path_of_Npos + +let n_path = make_path binnat_module "N" + +let n_of_binnat dloc pos_or_neg n = + if n <> zero then + RApp(dloc, RRef (dloc,glob_Npos), [pos_of_bignat dloc n]) + else + RRef (dloc, glob_N0) + +let error_negative dloc = + user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".") + +let n_of_int dloc n = + if is_pos_or_zero n then n_of_binnat dloc true n + else error_negative dloc + +(**********************************************************************) +(* Printing N via scopes *) +(**********************************************************************) + +let bignat_of_n = function + | RApp (_, RRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a + | RRef (_, a) when a = glob_N0 -> Bigint.zero + | _ -> raise Non_closed_number + +let uninterp_n p = + try Some (bignat_of_n p) + with Non_closed_number -> None + +(************************************************************************) +(* Declaring interpreters and uninterpreters for N *) + +let _ = Notation.declare_numeral_interpreter "N_scope" + (n_path,binnat_module) + n_of_int + ([RRef (dummy_loc, glob_N0); + RRef (dummy_loc, glob_Npos)], + uninterp_n, + true) + +(**********************************************************************) +(* Parsing Z via scopes *) +(**********************************************************************) + +let binint_module = ["Coq";"ZArith";"BinInt"] +let z_path = make_path binint_module "Z" +let z_kn = make_kn (make_dir binint_module) (id_of_string "Z") +let glob_z = IndRef (z_kn,0) +let path_of_ZERO = ((z_kn,0),1) +let path_of_POS = ((z_kn,0),2) +let path_of_NEG = ((z_kn,0),3) +let glob_ZERO = ConstructRef path_of_ZERO +let glob_POS = ConstructRef path_of_POS +let glob_NEG = ConstructRef path_of_NEG + +let z_of_int dloc n = + if n <> zero then + let sgn, n = + if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in + RApp(dloc, RRef (dloc,sgn), [pos_of_bignat dloc n]) + else + RRef (dloc, glob_ZERO) + +(**********************************************************************) +(* Printing Z via scopes *) +(**********************************************************************) + +let bigint_of_z = function + | RApp (_, RRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a + | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a) + | RRef (_, a) when a = glob_ZERO -> Bigint.zero + | _ -> raise Non_closed_number + +let uninterp_z p = + try + Some (bigint_of_z p) + with Non_closed_number -> None + +(************************************************************************) +(* Declaring interpreters and uninterpreters for Z *) + +let _ = Notation.declare_numeral_interpreter "Z_scope" + (z_path,binint_module) + z_of_int + ([RRef (dummy_loc, glob_ZERO); + RRef (dummy_loc, glob_POS); + RRef (dummy_loc, glob_NEG)], + uninterp_z, + true) diff --git a/plugins/syntax/z_syntax_plugin.mllib b/plugins/syntax/z_syntax_plugin.mllib new file mode 100644 index 00000000..36d41acc --- /dev/null +++ b/plugins/syntax/z_syntax_plugin.mllib @@ -0,0 +1,2 @@ +Z_syntax +Z_syntax_plugin_mod diff --git a/plugins/xml/COPYRIGHT b/plugins/xml/COPYRIGHT new file mode 100644 index 00000000..c8d231fd --- /dev/null +++ b/plugins/xml/COPYRIGHT @@ -0,0 +1,25 @@ +(******************************************************************************) +(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen *) +(* Project Helm (http://helm.cs.unibo.it) *) +(* Project MoWGLI (http://mowgli.cs.unibo.it) *) +(* *) +(* Coq Exportation to XML *) +(* *) +(******************************************************************************) + +This Coq module has been developed by Claudio Sacerdoti Coen + as a developer of projects HELM and MoWGLI. + +Project HELM (for Hypertextual Electronic Library of Mathematics) is a +project developed at the Department of Computer Science, University of Bologna; +http://helm.cs.unibo.it + +Project MoWGLI (Mathematics on the Web: Get It by Logics and Interfaces) +is a UE IST project that generalizes and extends the HELM project; +http://mowgli.cs.unibo.it + +The author is interested in any possible usage of the module. +So, if you plan to use the module, please send him an e-mail. + +The licensing policy applied to the module is the same as for the whole Coq +distribution. diff --git a/plugins/xml/README b/plugins/xml/README new file mode 100644 index 00000000..a45dd31a --- /dev/null +++ b/plugins/xml/README @@ -0,0 +1,254 @@ +(******************************************************************************) +(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen *) +(* Project Helm (http://helm.cs.unibo.it) *) +(* Project MoWGLI (http://mowgli.cs.unibo.it) *) +(* *) +(* Coq Exportation to XML *) +(* *) +(******************************************************************************) + +This module provides commands to export a piece of Coq library in XML format. +Only the information relevant to proof-checking and proof-rendering is exported, +i.e. only the CIC proof objects (lambda-terms). + +This document is tructured in the following way: + 1. User documentation + 1.1. New vernacular commands available + 1.2. New coqc/coqtop flags and suggested usage + 1.3. How to exploit the XML files + 2. Technical informations + 2.1. Inner-types + 2.2. CIC with Explicit Named Substitutions + 2.3. The CIC with Explicit Named Substitutions XML DTD + +================================================================================ + USER DOCUMENTATION +================================================================================ + +======================================= +1.1. New vernacular commands available: +======================================= + +The new commands are: + + Print XML qualid. It prints in XML (to standard output) the + object whose qualified name is qualid and + its inner-types (see Sect. 2.1). + The inner-types are always printed + in their own XML file. If the object is a + constant, its type and body are also printed + as two distinct XML files. + The object printed is always the most + discharged form of the object (see + the Section command of the Coq manual). + + Print XML File "filename" qualid. Similar to "Print XML qualid". The generated + files are stored on the hard-disk using the + base file name "filename". + + Show XML Proof. It prints in XML the current proof in + progress. Its inner-types are also printed. + + Show XML File "filename" Proof. Similar to "Show XML Proof". The generated + files are stored on the hard-disk using + the base file name "filename". + + The verbosity of the previous commands is raised if the configuration + parameter verbose of xmlcommand.ml is set to true at compile time. + +============================================== +1.2. New coqc/coqtop flags and suggested usage +============================================== + + The following flag has been added to coqc and coqtop: + + -xml export XML files either to the hierarchy rooted in + the directory $COQ_XML_LIBRARY_ROOT (if the environment + variable is set) or to stdout (if unset) + + If the flag is set, every definition or declaration is immediately + exported to XML. The XML files describe the user-provided non-discharged + form of the definition or declaration. + + + The coq_makefile utility has also been modified to easily allow XML + exportation: + + make COQ_XML=-xml (or, equivalently, setting the environment + variable COQ_XML) + + + The suggested usage of the module is the following: + + 1. add to your own contribution a valid Make file and use coq_makefile + to generate the Makefile from the Make file. + *WARNING:* Since logical names are used to structure the XML hierarchy, + always add to the Make file at least one "-R" option to map physical + file names to logical module paths. See the Coq manual for further + informations on the -R flag. + 2. set $COQ_XML_LIBRARY_ROOT to the directory where the XML file hierarchy + must be physically rooted. + 3. compile your contribution with "make COQ_XML=-xml" + + +================================= +1.3. How to exploit the XML files +================================= + + Once the information is exported to XML, it becomes possible to implement + services that are completely Coq-independent. Projects HELM and MoWGLI + already provide rendering, searching and data mining functionalities. + + In particular, the standard library and contributions of Coq can be + browsed and searched on the HELM web site: + + http://helm.cs.unibo.it/library.html + + + If you want to publish your own contribution so that it is included in the + HELM library, use the MoWGLI prototype upload form: + + http://mowgli.cs.unibo.it + + +================================================================================ + TECHNICAL INFORMATIONS +================================================================================ + +========================== +2.1. Inner-types +========================== + +In order to do proof-rendering (for example in natural language), +some redundant typing information is required, i.e. the type of +at least some of the subterms of the bodies and types. So, each +new command described in section 1.1 print not only +the object, but also another XML file in which you can find +the type of all the subterms of the terms of the printed object +which respect the following conditions: + + 1. It's sort is Prop or CProp (the "sort"-like definition used in + CoRN to type computationally relevant predicative propositions). + 2. It is not a cast or an atomic term, i.e. it's root is not a CAST, REL, + VAR, MUTCONSTR or CONST. + 3. If it's root is a LAMBDA, then the root's parent node is not a LAMBDA, + i.e. only the type of the outer LAMBDA of a block of nested LAMBDAs is + printed. + +The rationale for the 3rd condition is that the type of the inner LAMBDAs +could be easily computed starting from the type of the outer LAMBDA; moreover, +the types of the inner LAMBDAs requires a lot of disk/memory space: removing +the 3rd condition leads to XML file that are two times as big as the ones +exported appling the 3rd condition. + +========================================== +2.2. CIC with Explicit Named Substitutions +========================================== + +The exported files are and XML encoding of the lambda-terms used by the +Coq system. The implementative details of the Coq system are hidden as much +as possible, so that the XML DTD is a straightforward encoding of the +Calculus of (Co)Inductive Constructions. + +Nevertheless, there is a feature of the Coq system that can not be +hidden in a completely satisfactory way: discharging. In Coq it is possible +to open a section, declare variables and use them in the rest of the section +as if they were axiom declarations. Once the section is closed, every definition +and theorem in the section is discharged by abstracting it over the section +variables. Variable declarations as well as section declarations are entirely +dropped. Since we are interested in an XML encoding of definitions and +theorems as close as possible to those directly provided the user, we +do not want to export discharged forms. Exporting non-discharged theorem +and definitions together with theorems that rely on the discharged forms +obliges the tools that work on the XML encoding to implement discharging to +achieve logical consistency. Moreover, the rendering of the files can be +misleading, since hyperlinks can be shown between occurrences of the discharge +form of a definition and the non-discharged definition, that are different +objects. + +To overcome the previous limitations, Claudio Sacerdoti Coen developed in his +PhD. thesis an extension of CIC, called Calculus of (Co)Inductive Constructions +with Explicit Named Substitutions, that is a slight extension of CIC where +discharging is not necessary. The DTD of the exported XML files describes +constants, inductive types and variables of the Calculus of (Co)Inductive +Constructions with Explicit Named Substitions. The conversion to the new +calculus is performed during the exportation phase. + +The following example shows a very small Coq development together with its +version in CIC with Explicit Named Substitutions. + +# CIC version: # +Section S. + Variable A : Prop. + + Definition impl := A -> A. + + Theorem t : impl. (* uses the undischarged form of impl *) + Proof. + exact (fun (a:A) => a). + Qed. + +End S. + +Theorem t' : (impl False). (* uses the discharged form of impl *) + Proof. + exact (t False). (* uses the discharged form of t *) + Qed. + +# Corresponding CIC with Explicit Named Substitutions version: # +Section S. + Variable A : Prop. + + Definition impl(A) := A -> A. (* theorems and definitions are + explicitly abstracted over the + variables. The name is sufficient + to completely describe the abstraction *) + + Theorem t(A) : impl. (* impl where A is not instantiated *) + Proof. + exact (fun (a:A) => a). + Qed. + +End S. + +Theorem t'() : impl{False/A}. (* impl where A is instantiated with False + Notice that t' does not depend on A *) + Proof. + exact t{False/A}. (* t where A is instantiated with False *) + Qed. + +Further details on the typing and reduction rules of the calculus can be +found in Claudio Sacerdoti Coen PhD. dissertation, where the consistency +of the calculus is also proved. + +====================================================== +2.3. The CIC with Explicit Named Substitutions XML DTD +====================================================== + +A copy of the DTD can be found in the file "cic.dtd". + + is the root element of the files that correspond to + constant types. + is the root element of the files that correspond to + constant bodies. It is used only for closed definitions and + theorems (i.e. when no metavariable occurs in the body + or type of the constant) + is the root element of the file that correspond to + the body of a constant that depends on metavariables + (e.g. unfinished proofs) + is the root element of the files that correspond to variables + is the root element of the files that correspond to blocks + of mutually defined inductive definitions + +The elements + ,,,,,,,, ,, + ,,,, and +are used to encode the constructors of CIC. The sort or type attribute of the +element, if present, is respectively the sort or the type of the term, that +is a sort because of the typing rules of CIC. + +The element correspond to the application of an explicit named +substitution to its first argument, that is a reference to a definition +or declaration in the environment. + +All the other elements are just syntactic sugar. diff --git a/plugins/xml/acic.ml b/plugins/xml/acic.ml new file mode 100644 index 00000000..40bc61bb --- /dev/null +++ b/plugins/xml/acic.ml @@ -0,0 +1,108 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Util.anomaly "find_last_id: empty list" + | [id,_,_] -> id + | _::tl -> find_last_id tl +;; + +let export_existential = string_of_int + +let print_term ids_to_inner_sorts = + let rec aux = + let module A = Acic in + let module N = Names in + let module X = Xml in + function + A.ARel (id,n,idref,b) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_empty "REL" + ["value",(string_of_int n) ; "binder",(N.string_of_id b) ; + "id",id ; "idref",idref; "sort",sort] + | A.AVar (id,uri) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_empty "VAR" ["uri", uri ; "id",id ; "sort",sort] + | A.AEvar (id,n,l) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_nempty "META" + ["no",(export_existential n) ; "id",id ; "sort",sort] + (List.fold_left + (fun i t -> + [< i ; X.xml_nempty "substitution" [] (aux t) >] + ) [< >] (List.rev l)) + | A.ASort (id,s) -> + let string_of_sort = + match Term.family_of_sort s with + Term.InProp -> "Prop" + | Term.InSet -> "Set" + | Term.InType -> "Type" + in + X.xml_empty "SORT" ["value",string_of_sort ; "id",id] + | A.AProds (prods,t) -> + let last_id = find_last_id prods in + let sort = Hashtbl.find ids_to_inner_sorts last_id in + X.xml_nempty "PROD" ["type",sort] + [< List.fold_left + (fun i (id,binder,s) -> + let sort = + Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id) + in + let attrs = + ("id",id)::("type",sort):: + match binder with + Names.Anonymous -> [] + | Names.Name b -> ["binder",Names.string_of_id b] + in + [< X.xml_nempty "decl" attrs (aux s) ; i >] + ) [< >] prods ; + X.xml_nempty "target" [] (aux t) + >] + | A.ACast (id,v,t) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_nempty "CAST" ["id",id ; "sort",sort] + [< X.xml_nempty "term" [] (aux v) ; + X.xml_nempty "type" [] (aux t) + >] + | A.ALambdas (lambdas,t) -> + let last_id = find_last_id lambdas in + let sort = Hashtbl.find ids_to_inner_sorts last_id in + X.xml_nempty "LAMBDA" ["sort",sort] + [< List.fold_left + (fun i (id,binder,s) -> + let sort = + Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id) + in + let attrs = + ("id",id)::("type",sort):: + match binder with + Names.Anonymous -> [] + | Names.Name b -> ["binder",Names.string_of_id b] + in + [< X.xml_nempty "decl" attrs (aux s) ; i >] + ) [< >] lambdas ; + X.xml_nempty "target" [] (aux t) + >] + | A.ALetIns (letins,t) -> + let last_id = find_last_id letins in + let sort = Hashtbl.find ids_to_inner_sorts last_id in + X.xml_nempty "LETIN" ["sort",sort] + [< List.fold_left + (fun i (id,binder,s) -> + let sort = + Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id) + in + let attrs = + ("id",id)::("sort",sort):: + match binder with + Names.Anonymous -> assert false + | Names.Name b -> ["binder",Names.string_of_id b] + in + [< X.xml_nempty "def" attrs (aux s) ; i >] + ) [< >] letins ; + X.xml_nempty "target" [] (aux t) + >] + | A.AApp (id,li) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_nempty "APPLY" ["id",id ; "sort",sort] + [< (List.fold_left (fun i x -> [< i ; (aux x) >]) [<>] li) + >] + | A.AConst (id,subst,uri) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + let attrs = ["uri", uri ; "id",id ; "sort",sort] in + aux_subst (X.xml_empty "CONST" attrs) subst + | A.AInd (id,subst,uri,i) -> + let attrs = ["uri", uri ; "noType",(string_of_int i) ; "id",id] in + aux_subst (X.xml_empty "MUTIND" attrs) subst + | A.AConstruct (id,subst,uri,i,j) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + let attrs = + ["uri", uri ; + "noType",(string_of_int i) ; "noConstr",(string_of_int j) ; + "id",id ; "sort",sort] + in + aux_subst (X.xml_empty "MUTCONSTRUCT" attrs) subst + | A.ACase (id,uri,typeno,ty,te,patterns) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_nempty "MUTCASE" + ["uriType", uri ; + "noType", (string_of_int typeno) ; + "id", id ; "sort",sort] + [< X.xml_nempty "patternsType" [] [< (aux ty) >] ; + X.xml_nempty "inductiveTerm" [] [< (aux te) >] ; + List.fold_left + (fun i x -> [< i ; X.xml_nempty "pattern" [] [< aux x >] >]) + [<>] patterns + >] + | A.AFix (id, no, funs) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_nempty "FIX" + ["noFun", (string_of_int no) ; "id",id ; "sort",sort] + [< List.fold_left + (fun i (id,fi,ai,ti,bi) -> + [< i ; + X.xml_nempty "FixFunction" + ["id",id ; "name", (Names.string_of_id fi) ; + "recIndex", (string_of_int ai)] + [< X.xml_nempty "type" [] [< aux ti >] ; + X.xml_nempty "body" [] [< aux bi >] + >] + >] + ) [<>] funs + >] + | A.ACoFix (id,no,funs) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_nempty "COFIX" + ["noFun", (string_of_int no) ; "id",id ; "sort",sort] + [< List.fold_left + (fun i (id,fi,ti,bi) -> + [< i ; + X.xml_nempty "CofixFunction" + ["id",id ; "name", Names.string_of_id fi] + [< X.xml_nempty "type" [] [< aux ti >] ; + X.xml_nempty "body" [] [< aux bi >] + >] + >] + ) [<>] funs + >] + and aux_subst target (id,subst) = + if subst = [] then + target + else + Xml.xml_nempty "instantiate" + (match id with None -> [] | Some id -> ["id",id]) + [< target ; + List.fold_left + (fun i (uri,arg) -> + [< i ; Xml.xml_nempty "arg" ["relUri", uri] (aux arg) >] + ) [<>] subst + >] + in + aux +;; + +let param_attribute_of_params params = + List.fold_right + (fun (path,l) i -> + List.fold_right + (fun x i ->path ^ "/" ^ x ^ ".var" ^ match i with "" -> "" | i' -> " " ^ i' + ) l "" ^ match i with "" -> "" | i' -> " " ^ i' + ) params "" +;; + +let print_object uri ids_to_inner_sorts = + let rec aux = + let module A = Acic in + let module X = Xml in + function + A.ACurrentProof (id,n,conjectures,bo,ty) -> + let xml_for_current_proof_body = +(*CSC: Should the CurrentProof also have the list of variables it depends on? *) +(*CSC: I think so. Not implemented yet. *) + X.xml_nempty "CurrentProof" ["of",uri ; "id", id] + [< List.fold_left + (fun i (cid,n,canonical_context,t) -> + [< i ; + X.xml_nempty "Conjecture" + ["id", cid ; "no",export_existential n] + [< List.fold_left + (fun i (hid,t) -> + [< (match t with + n,A.Decl t -> + X.xml_nempty "Decl" + ["id",hid;"name",Names.string_of_id n] + (print_term ids_to_inner_sorts t) + | n,A.Def (t,_) -> + X.xml_nempty "Def" + ["id",hid;"name",Names.string_of_id n] + (print_term ids_to_inner_sorts t) + ) ; + i + >] + ) [< >] canonical_context ; + X.xml_nempty "Goal" [] + (print_term ids_to_inner_sorts t) + >] + >]) + [<>] (List.rev conjectures) ; + X.xml_nempty "body" [] (print_term ids_to_inner_sorts bo) >] + in + let xml_for_current_proof_type = + X.xml_nempty "ConstantType" ["name",n ; "id", id] + (print_term ids_to_inner_sorts ty) + in + let xmlbo = + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n"); + xml_for_current_proof_body + >] in + let xmlty = + [< X.xml_cdata "\n" ; + X.xml_cdata + ("\n"); + xml_for_current_proof_type + >] + in + xmlty, Some xmlbo + | A.AConstant (id,n,bo,ty,params) -> + let params' = param_attribute_of_params params in + let xmlbo = + match bo with + None -> None + | Some bo -> + Some + [< X.xml_cdata + "\n" ; + X.xml_cdata + ("\n") ; + X.xml_nempty "ConstantBody" + ["for",uri ; "params",params' ; "id", id] + [< print_term ids_to_inner_sorts bo >] + >] + in + let xmlty = + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n"); + X.xml_nempty "ConstantType" + ["name",n ; "params",params' ; "id", id] + [< print_term ids_to_inner_sorts ty >] + >] + in + xmlty, xmlbo + | A.AVariable (id,n,bo,ty,params) -> + let params' = param_attribute_of_params params in + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n") ; + X.xml_nempty "Variable" ["name",n ; "params",params' ; "id", id] + [< (match bo with + None -> [<>] + | Some bo -> + X.xml_nempty "body" [] + (print_term ids_to_inner_sorts bo) + ) ; + X.xml_nempty "type" [] (print_term ids_to_inner_sorts ty) + >] + >], None + | A.AInductiveDefinition (id,tys,params,nparams) -> + let params' = param_attribute_of_params params in + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n") ; + X.xml_nempty "InductiveDefinition" + ["noParams",string_of_int nparams ; + "id",id ; + "params",params'] + [< (List.fold_left + (fun i (id,typename,finite,arity,cons) -> + [< i ; + X.xml_nempty "InductiveType" + ["id",id ; "name",Names.string_of_id typename ; + "inductive",(string_of_bool finite) + ] + [< X.xml_nempty "arity" [] + (print_term ids_to_inner_sorts arity) ; + (List.fold_left + (fun i (name,lc) -> + [< i ; + X.xml_nempty "Constructor" + ["name",Names.string_of_id name] + (print_term ids_to_inner_sorts lc) + >]) [<>] cons + ) + >] + >] + ) [< >] tys + ) + >] + >], None + in + aux +;; + +let print_inner_types curi ids_to_inner_sorts ids_to_inner_types = + let module C2A = Cic2acic in + let module X = Xml in + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n"); + X.xml_nempty "InnerTypes" ["of",curi] + (Hashtbl.fold + (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x -> + [< x ; + X.xml_nempty "TYPE" ["of",id] + [< X.xml_nempty "synthesized" [] + (print_term ids_to_inner_sorts synty) ; + match expty with + None -> [<>] + | Some expty' -> + X.xml_nempty "expected" [] + (print_term ids_to_inner_sorts expty') + >] + >] + ) ids_to_inner_types [<>] + ) + >] +;; diff --git a/plugins/xml/cic.dtd b/plugins/xml/cic.dtd new file mode 100644 index 00000000..c8035cab --- /dev/null +++ b/plugins/xml/cic.dtd @@ -0,0 +1,259 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/plugins/xml/cic2Xml.ml b/plugins/xml/cic2Xml.ml new file mode 100644 index 00000000..981503a6 --- /dev/null +++ b/plugins/xml/cic2Xml.ml @@ -0,0 +1,17 @@ +let print_xml_term ch env sigma cic = + let ids_to_terms = Hashtbl.create 503 in + let constr_to_ids = Acic.CicHash.create 503 in + let ids_to_father_ids = Hashtbl.create 503 in + let ids_to_inner_sorts = Hashtbl.create 503 in + let ids_to_inner_types = Hashtbl.create 503 in + let seed = ref 0 in + let acic = + Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids + ids_to_father_ids ids_to_inner_sorts ids_to_inner_types + env [] sigma (Unshare.unshare cic) None in + let xml = Acic2Xml.print_term ids_to_inner_sorts acic in + Xml.pp_ch xml ch +;; + +Tacinterp.declare_xml_printer print_xml_term +;; diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml new file mode 100644 index 00000000..a80ceb0f --- /dev/null +++ b/plugins/xml/cic2acic.ml @@ -0,0 +1,942 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Libnames.is_dirpath_prefix_of modul dirpath) modules + with + [] -> + Pp.warning ("Modules not supported: reference to "^ + Libnames.string_of_path path^" will be wrong"); + dirpath + | [modul] -> modul + | _ -> + raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther +;; + +(*CSC: Problem: here we are using the wrong (???) hypothesis that there do *) +(*CSC: not exist two modules whose dir_paths are one a prefix of the other *) +let remove_module_dirpath_from_dirpath ~basedir dir = + let module Ln = Libnames in + if Ln.is_dirpath_prefix_of basedir dir then + let ids = Names.repr_dirpath dir in + let rec remove_firsts n l = + match n,l with + (0,l) -> l + | (n,he::tl) -> remove_firsts (n-1) tl + | _ -> assert false + in + let ids' = + List.rev + (remove_firsts + (List.length (Names.repr_dirpath basedir)) + (List.rev ids)) + in + ids' + else Names.repr_dirpath dir +;; + + +let get_uri_of_var v pvars = + let module D = Decls in + let module N = Names in + let rec search_in_open_sections = + function + [] -> Util.error ("Variable "^v^" not found") + | he::tl as modules -> + let dirpath = N.make_dirpath modules in + if List.mem (N.id_of_string v) (D.last_section_hyps dirpath) then + modules + else + search_in_open_sections tl + in + let path = + if List.mem v pvars then + [] + else + search_in_open_sections (N.repr_dirpath (Lib.cwd ())) + in + "cic:" ^ + List.fold_left + (fun i x -> "/" ^ N.string_of_id x ^ i) "" path +;; + +type tag = + Constant of Names.constant + | Inductive of Names.mutual_inductive + | Variable of Names.kernel_name +;; + +type etag = + TConstant + | TInductive + | TVariable +;; + +let etag_of_tag = + function + Constant _ -> TConstant + | Inductive _ -> TInductive + | Variable _ -> TVariable + +let ext_of_tag = + function + TConstant -> "con" + | TInductive -> "ind" + | TVariable -> "var" +;; + +exception FunctorsXMLExportationNotImplementedYet;; + +let subtract l1 l2 = + let l1' = List.rev (Names.repr_dirpath l1) in + let l2' = List.rev (Names.repr_dirpath l2) in + let rec aux = + function + he::tl when tl = l2' -> [he] + | he::tl -> he::(aux tl) + | [] -> assert (l2' = []) ; [] + in + Names.make_dirpath (List.rev (aux l1')) +;; + +let token_list_of_path dir id tag = + let module N = Names in + let token_list_of_dirpath dirpath = + List.rev_map N.string_of_id (N.repr_dirpath dirpath) in + token_list_of_dirpath dir @ [N.string_of_id id ^ "." ^ (ext_of_tag tag)] + +let token_list_of_kernel_name tag = + let module N = Names in + let module LN = Libnames in + let id,dir = match tag with + | Variable kn -> + N.id_of_label (N.label kn), Lib.cwd () + | Constant con -> + N.id_of_label (N.con_label con), + Lib.remove_section_part (LN.ConstRef con) + | Inductive kn -> + N.id_of_label (N.mind_label kn), + Lib.remove_section_part (LN.IndRef (kn,0)) + in + token_list_of_path dir id (etag_of_tag tag) +;; + +let uri_of_kernel_name tag = + let tokens = token_list_of_kernel_name tag in + "cic:/" ^ String.concat "/" tokens + +let uri_of_declaration id tag = + let module LN = Libnames in + let dir = LN.pop_dirpath_n (Lib.sections_depth ()) (Lib.cwd ()) in + let tokens = token_list_of_path dir id tag in + "cic:/" ^ String.concat "/" tokens + +(* Special functions for handling of CCorn's CProp "sort" *) + +type sort = + Coq_sort of Term.sorts_family + | CProp +;; + +let prerr_endline _ = ();; + +let family_of_term ty = + match Term.kind_of_term ty with + Term.Sort s -> Coq_sort (Term.family_of_sort s) + | Term.Const _ -> CProp (* I could check that the constant is CProp *) + | _ -> Util.anomaly "family_of_term" +;; + +module CPropRetyping = + struct + module T = Term + + let outsort env sigma t = + family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma t) + + let rec subst_type env sigma typ = function + | [] -> typ + | h::rest -> + match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma typ) with + | T.Prod (na,c1,c2) -> subst_type env sigma (T.subst1 h c2) rest + | _ -> Util.anomaly "Non-functional construction" + + + let sort_of_atomic_type env sigma ft args = + let rec concl_of_arity env ar = + match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma ar) with + | T.Prod (na, t, b) -> concl_of_arity (Environ.push_rel (na,None,t) env) b + | T.Sort s -> Coq_sort (T.family_of_sort s) + | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args)) + in concl_of_arity env ft + +let typeur sigma metamap = + let rec type_of env cstr= + match Term.kind_of_term cstr with + | T.Meta n -> + (try T.strip_outer_cast (List.assoc n metamap) + with Not_found -> Util.anomaly "type_of: this is not a well-typed term") + | T.Rel n -> + let (_,_,ty) = Environ.lookup_rel n env in + T.lift n ty + | T.Var id -> + (try + let (_,_,ty) = Environ.lookup_named id env in + ty + with Not_found -> + Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound")) + | T.Const c -> + let cb = Environ.lookup_constant c env in + Typeops.type_of_constant_type env (cb.Declarations.const_type) + | T.Evar ev -> Evd.existential_type sigma ev + | T.Ind ind -> Inductiveops.type_of_inductive env ind + | T.Construct cstr -> Inductiveops.type_of_constructor env cstr + | T.Case (_,p,c,lf) -> + let Inductiveops.IndType(_,realargs) = + try Inductiveops.find_rectype env sigma (type_of env c) + with Not_found -> Util.anomaly "type_of: Bad recursive type" in + let t = Reductionops.whd_beta sigma (T.applist (p, realargs)) in + (match Term.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma (type_of env t)) with + | T.Prod _ -> Reductionops.whd_beta sigma (T.applist (t, [c])) + | _ -> t) + | T.Lambda (name,c1,c2) -> + T.mkProd (name, c1, type_of (Environ.push_rel (name,None,c1) env) c2) + | T.LetIn (name,b,c1,c2) -> + T.subst1 b (type_of (Environ.push_rel (name,Some b,c1) env) c2) + | T.Fix ((_,i),(_,tys,_)) -> tys.(i) + | T.CoFix (i,(_,tys,_)) -> tys.(i) + | T.App(f,args)-> + T.strip_outer_cast + (subst_type env sigma (type_of env f) (Array.to_list args)) + | T.Cast (c,_, t) -> t + | T.Sort _ | T.Prod _ -> + match sort_of env cstr with + Coq_sort T.InProp -> T.mkProp + | Coq_sort T.InSet -> T.mkSet + | Coq_sort T.InType -> T.mkType Univ.type1_univ (* ERROR HERE *) + | CProp -> T.mkConst DoubleTypeInference.cprop + + and sort_of env t = + match Term.kind_of_term t with + | T.Cast (c,_, s) when T.isSort s -> family_of_term s + | T.Sort (T.Prop c) -> Coq_sort T.InType + | T.Sort (T.Type u) -> Coq_sort T.InType + | T.Prod (name,t,c2) -> + (match sort_of env t,sort_of (Environ.push_rel (name,None,t) env) c2 with + | _, (Coq_sort T.InProp as s) -> s + | Coq_sort T.InProp, (Coq_sort T.InSet as s) + | Coq_sort T.InSet, (Coq_sort T.InSet as s) -> s + | Coq_sort T.InType, (Coq_sort T.InSet as s) + | CProp, (Coq_sort T.InSet as s) when + Environ.engagement env = Some Declarations.ImpredicativeSet -> s + | Coq_sort T.InType, Coq_sort T.InSet + | CProp, Coq_sort T.InSet -> Coq_sort T.InType + | _, (Coq_sort T.InType as s) -> s (*Type Univ.dummy_univ*) + | _, (CProp as s) -> s) + | T.App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args + | T.Lambda _ | T.Fix _ | T.Construct _ -> + Util.anomaly "sort_of: Not a type (1)" + | _ -> outsort env sigma (type_of env t) + + and sort_family_of env t = + match T.kind_of_term t with + | T.Cast (c,_, s) when T.isSort s -> family_of_term s + | T.Sort (T.Prop c) -> Coq_sort T.InType + | T.Sort (T.Type u) -> Coq_sort T.InType + | T.Prod (name,t,c2) -> sort_family_of (Environ.push_rel (name,None,t) env) c2 + | T.App(f,args) -> + sort_of_atomic_type env sigma (type_of env f) args + | T.Lambda _ | T.Fix _ | T.Construct _ -> + Util.anomaly "sort_of: Not a type (1)" + | _ -> outsort env sigma (type_of env t) + + in type_of, sort_of, sort_family_of + + let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c + let get_sort_family_of env sigma c = let _,_,f = typeur sigma [] in f env c + + end +;; + +let get_sort_family_of env evar_map ty = + CPropRetyping.get_sort_family_of env evar_map ty +;; + +let type_as_sort env evar_map ty = +(* CCorn code *) + family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env evar_map ty) +;; + +let is_a_Prop = + function + "Prop" + | "CProp" -> true + | _ -> false +;; + +(* Main Functions *) + +type anntypes = + {annsynthesized : Acic.aconstr ; annexpected : Acic.aconstr option} +;; + +let gen_id seed = + let res = "i" ^ string_of_int !seed in + incr seed ; + res +;; + +let fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids = + fun father t -> + let res = gen_id seed in + Hashtbl.add ids_to_father_ids res father ; + Hashtbl.add ids_to_terms res t ; + Acic.CicHash.add constr_to_ids t res ; + res +;; + +let source_id_of_id id = "#source#" ^ id;; + +let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids + ids_to_father_ids ids_to_inner_sorts ids_to_inner_types + ?(fake_dependent_products=false) env idrefs evar_map t expectedty += + let module D = DoubleTypeInference in + let module E = Environ in + let module N = Names in + let module A = Acic in + let module T = Term in + let fresh_id' = fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids in + (* CSC: do you have any reasonable substitute for 503? *) + let terms_to_types = Acic.CicHash.create 503 in + D.double_type_of env evar_map t expectedty terms_to_types ; + let rec aux computeinnertypes father passed_lambdas_or_prods_or_letins env + idrefs ?(subst=None,[]) tt + = + let fresh_id'' = fresh_id' father tt in + let aux' = aux computeinnertypes (Some fresh_id'') [] in + let string_of_sort_family = + function + Coq_sort T.InProp -> "Prop" + | Coq_sort T.InSet -> "Set" + | Coq_sort T.InType -> "Type" + | CProp -> "CProp" + in + let string_of_sort t = + string_of_sort_family + (type_as_sort env evar_map t) + in + let ainnertypes,innertype,innersort,expected_available = + let {D.synthesized = synthesized; D.expected = expected} = + if computeinnertypes then +try + Acic.CicHash.find terms_to_types tt +with _ -> +(*CSC: Warning: it really happens, for example in Ring_theory!!! *) +Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.pr_lconstr tt)) ; assert false + else + (* We are already in an inner-type and Coscoy's double *) + (* type inference algorithm has not been applied. *) + (* We need to refresh the universes because we are doing *) + (* type inference on an already inferred type. *) + {D.synthesized = + Reductionops.nf_beta evar_map + (CPropRetyping.get_type_of env evar_map + (Termops.refresh_universes tt)) ; + D.expected = None} + in +(* Debugging only: +print_endline "TERMINE:" ; flush stdout ; +Pp.ppnl (Printer.pr_lconstr tt) ; flush stdout ; +print_endline "TIPO:" ; flush stdout ; +Pp.ppnl (Printer.pr_lconstr synthesized) ; flush stdout ; +print_endline "ENVIRONMENT:" ; flush stdout ; +Pp.ppnl (Printer.pr_context_of env) ; flush stdout ; +print_endline "FINE_ENVIRONMENT" ; flush stdout ; +*) + let innersort = + let synthesized_innersort = + get_sort_family_of env evar_map synthesized + in + match expected with + None -> synthesized_innersort + | Some ty -> + let expected_innersort = + get_sort_family_of env evar_map ty + in + match expected_innersort, synthesized_innersort with + CProp, _ + | _, CProp -> CProp + | _, _ -> expected_innersort + in +(* Debugging only: +print_endline "PASSATO" ; flush stdout ; +*) + let ainnertypes,expected_available = + if computeinnertypes then + let annexpected,expected_available = + match expected with + None -> None,false + | Some expectedty' -> + Some (aux false (Some fresh_id'') [] env idrefs expectedty'), + true + in + Some + {annsynthesized = + aux false (Some fresh_id'') [] env idrefs synthesized ; + annexpected = annexpected + }, expected_available + else + None,false + in + ainnertypes,synthesized, string_of_sort_family innersort, + expected_available + in + let add_inner_type id = + match ainnertypes with + None -> () + | Some ainnertypes -> Hashtbl.add ids_to_inner_types id ainnertypes + in + + (* explicit_substitute_and_eta_expand_if_required h t t' *) + (* where [t] = [] and [tt] = [h]{[t']} ("{.}" denotes explicit *) + (* named substitution) or [tt] = (App [h]::[t]) (and [t'] = []) *) + (* check if [h] is a term that requires an explicit named *) + (* substitution and, in that case, uses the first arguments of *) + (* [t] as the actual arguments of the substitution. If there *) + (* are not enough parameters in the list [t], then eta-expansion *) + (* is performed. *) + let + explicit_substitute_and_eta_expand_if_required h t t' + compute_result_if_eta_expansion_not_required + = + let subst,residual_args,uninst_vars = + let variables,basedir = + try + let g = Libnames.global_of_constr h in + let sp = + match g with + Libnames.ConstructRef ((induri,_),_) + | Libnames.IndRef (induri,_) -> + Nametab.path_of_global (Libnames.IndRef (induri,0)) + | Libnames.VarRef id -> + (* Invariant: variables are never cooked in Coq *) + raise Not_found + | _ -> Nametab.path_of_global g + in + Dischargedhypsmap.get_discharged_hyps sp, + get_module_path_of_full_path sp + with Not_found -> + (* no explicit substitution *) + [], Libnames.dirpath_of_string "dummy" + in + (* returns a triple whose first element is *) + (* an explicit named substitution of "type" *) + (* (variable * argument) list, whose *) + (* second element is the list of residual *) + (* arguments and whose third argument is *) + (* the list of uninstantiated variables *) + let rec get_explicit_subst variables arguments = + match variables,arguments with + [],_ -> [],arguments,[] + | _,[] -> [],[],variables + | he1::tl1,he2::tl2 -> + let subst,extra_args,uninst = get_explicit_subst tl1 tl2 in + let (he1_sp, he1_id) = Libnames.repr_path he1 in + let he1' = remove_module_dirpath_from_dirpath ~basedir he1_sp in + let he1'' = + String.concat "/" + (List.map Names.string_of_id (List.rev he1')) ^ "/" + ^ (Names.string_of_id he1_id) ^ ".var" + in + (he1'',he2)::subst, extra_args, uninst + in + get_explicit_subst variables t' + in + let uninst_vars_length = List.length uninst_vars in + if uninst_vars_length > 0 then + (* Not enough arguments provided. We must eta-expand! *) + let un_args,_ = + T.decompose_prod_n uninst_vars_length + (CPropRetyping.get_type_of env evar_map tt) + in + let eta_expanded = + let arguments = + List.map (T.lift uninst_vars_length) t @ + Termops.rel_list 0 uninst_vars_length + in + Unshare.unshare + (T.lamn uninst_vars_length un_args + (T.applistc h arguments)) + in + D.double_type_of env evar_map eta_expanded + None terms_to_types ; + Hashtbl.remove ids_to_inner_types fresh_id'' ; + aux' env idrefs eta_expanded + else + compute_result_if_eta_expansion_not_required subst residual_args + in + + (* Now that we have all the auxiliary functions we *) + (* can finally proceed with the main case analysis. *) + match T.kind_of_term tt with + T.Rel n -> + let id = + match List.nth (E.rel_context env) (n - 1) with + (N.Name id,_,_) -> id + | (N.Anonymous,_,_) -> Nameops.make_ident "_" None + in + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort && expected_available then + add_inner_type fresh_id'' ; + A.ARel (fresh_id'', n, List.nth idrefs (n-1), id) + | T.Var id -> + let pvars = Termops.ids_of_named_context (E.named_context env) in + let pvars = List.map N.string_of_id pvars in + let path = get_uri_of_var (N.string_of_id id) pvars in + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort && expected_available then + add_inner_type fresh_id'' ; + A.AVar + (fresh_id'', path ^ "/" ^ (N.string_of_id id) ^ ".var") + | T.Evar (n,l) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort && expected_available then + add_inner_type fresh_id'' ; + A.AEvar + (fresh_id'', n, Array.to_list (Array.map (aux' env idrefs) l)) + | T.Meta _ -> Util.anomaly "Meta met during exporting to XML" + | T.Sort s -> A.ASort (fresh_id'', s) + | T.Cast (v,_, t) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort then + add_inner_type fresh_id'' ; + A.ACast (fresh_id'', aux' env idrefs v, aux' env idrefs t) + | T.Prod (n,s,t) -> + let n' = + match n with + N.Anonymous -> N.Anonymous + | _ -> + if not fake_dependent_products && T.noccurn 1 t then + N.Anonymous + else + N.Name + (Namegen.next_name_away n (Termops.ids_of_context env)) + in + Hashtbl.add ids_to_inner_sorts fresh_id'' + (string_of_sort innertype) ; + let sourcetype = CPropRetyping.get_type_of env evar_map s in + Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'') + (string_of_sort sourcetype) ; + let new_passed_prods = + let father_is_prod = + match father with + None -> false + | Some father' -> + match + Term.kind_of_term (Hashtbl.find ids_to_terms father') + with + T.Prod _ -> true + | _ -> false + in + (fresh_id'', n', aux' env idrefs s):: + (if father_is_prod then + passed_lambdas_or_prods_or_letins + else []) + in + let new_env = E.push_rel (n', None, s) env in + let new_idrefs = fresh_id''::idrefs in + (match Term.kind_of_term t with + T.Prod _ -> + aux computeinnertypes (Some fresh_id'') new_passed_prods + new_env new_idrefs t + | _ -> + A.AProds (new_passed_prods, aux' new_env new_idrefs t)) + | T.Lambda (n,s,t) -> + let n' = + match n with + N.Anonymous -> N.Anonymous + | _ -> + N.Name (Namegen.next_name_away n (Termops.ids_of_context env)) + in + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + let sourcetype = CPropRetyping.get_type_of env evar_map s in + Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'') + (string_of_sort sourcetype) ; + let father_is_lambda = + match father with + None -> false + | Some father' -> + match + Term.kind_of_term (Hashtbl.find ids_to_terms father') + with + T.Lambda _ -> true + | _ -> false + in + if is_a_Prop innersort && + ((not father_is_lambda) || expected_available) + then add_inner_type fresh_id'' ; + let new_passed_lambdas = + (fresh_id'',n', aux' env idrefs s):: + (if father_is_lambda then + passed_lambdas_or_prods_or_letins + else []) in + let new_env = E.push_rel (n', None, s) env in + let new_idrefs = fresh_id''::idrefs in + (match Term.kind_of_term t with + T.Lambda _ -> + aux computeinnertypes (Some fresh_id'') new_passed_lambdas + new_env new_idrefs t + | _ -> + let t' = aux' new_env new_idrefs t in + (* eta-expansion for explicit named substitutions *) + (* can create nested Lambdas. Here we perform the *) + (* flattening. *) + match t' with + A.ALambdas (lambdas, t'') -> + A.ALambdas (lambdas@new_passed_lambdas, t'') + | _ -> + A.ALambdas (new_passed_lambdas, t') + ) + | T.LetIn (n,s,t,d) -> + let id = + match n with + N.Anonymous -> N.id_of_string "_X" + | N.Name id -> id + in + let n' = + N.Name (Namegen.next_ident_away id (Termops.ids_of_context env)) + in + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + let sourcesort = + get_sort_family_of env evar_map + (CPropRetyping.get_type_of env evar_map s) + in + Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'') + (string_of_sort_family sourcesort) ; + let father_is_letin = + match father with + None -> false + | Some father' -> + match + Term.kind_of_term (Hashtbl.find ids_to_terms father') + with + T.LetIn _ -> true + | _ -> false + in + if is_a_Prop innersort then + add_inner_type fresh_id'' ; + let new_passed_letins = + (fresh_id'',n', aux' env idrefs s):: + (if father_is_letin then + passed_lambdas_or_prods_or_letins + else []) in + let new_env = E.push_rel (n', Some s, t) env in + let new_idrefs = fresh_id''::idrefs in + (match Term.kind_of_term d with + T.LetIn _ -> + aux computeinnertypes (Some fresh_id'') new_passed_letins + new_env new_idrefs d + | _ -> A.ALetIns + (new_passed_letins, aux' new_env new_idrefs d)) + | T.App (h,t) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort then + add_inner_type fresh_id'' ; + let + compute_result_if_eta_expansion_not_required subst residual_args + = + let residual_args_not_empty = residual_args <> [] in + let h' = + if residual_args_not_empty then + aux' env idrefs ~subst:(None,subst) h + else + aux' env idrefs ~subst:(Some fresh_id'',subst) h + in + (* maybe all the arguments were used for the explicit *) + (* named substitution *) + if residual_args_not_empty then + A.AApp (fresh_id'', h'::residual_args) + else + h' + in + let t' = + Array.fold_right (fun x i -> (aux' env idrefs x)::i) t [] + in + explicit_substitute_and_eta_expand_if_required h + (Array.to_list t) t' + compute_result_if_eta_expansion_not_required + | T.Const kn -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort && expected_available then + add_inner_type fresh_id'' ; + let compute_result_if_eta_expansion_not_required _ _ = + A.AConst (fresh_id'', subst, (uri_of_kernel_name (Constant kn))) + in + let (_,subst') = subst in + explicit_substitute_and_eta_expand_if_required tt [] + (List.map snd subst') + compute_result_if_eta_expansion_not_required + | T.Ind (kn,i) -> + let compute_result_if_eta_expansion_not_required _ _ = + A.AInd (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i) + in + let (_,subst') = subst in + explicit_substitute_and_eta_expand_if_required tt [] + (List.map snd subst') + compute_result_if_eta_expansion_not_required + | T.Construct ((kn,i),j) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort && expected_available then + add_inner_type fresh_id'' ; + let compute_result_if_eta_expansion_not_required _ _ = + A.AConstruct + (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i, j) + in + let (_,subst') = subst in + explicit_substitute_and_eta_expand_if_required tt [] + (List.map snd subst') + compute_result_if_eta_expansion_not_required + | T.Case ({T.ci_ind=(kn,i)},ty,term,a) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort then + add_inner_type fresh_id'' ; + let a' = + Array.fold_right (fun x i -> (aux' env idrefs x)::i) a [] + in + A.ACase + (fresh_id'', (uri_of_kernel_name (Inductive kn)), i, + aux' env idrefs ty, aux' env idrefs term, a') + | T.Fix ((ai,i),(f,t,b)) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort then add_inner_type fresh_id'' ; + let fresh_idrefs = + Array.init (Array.length t) (function _ -> gen_id seed) in + let new_idrefs = + (List.rev (Array.to_list fresh_idrefs)) @ idrefs + in + let f' = + let ids = ref (Termops.ids_of_context env) in + Array.map + (function + N.Anonymous -> Util.error "Anonymous fix function met" + | N.Name id as n -> + let res = N.Name (Namegen.next_name_away n !ids) in + ids := id::!ids ; + res + ) f + in + A.AFix (fresh_id'', i, + Array.fold_right + (fun (id,fi,ti,bi,ai) i -> + let fi' = + match fi with + N.Name fi -> fi + | N.Anonymous -> Util.error "Anonymous fix function met" + in + (id, fi', ai, + aux' env idrefs ti, + aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i) + (Array.mapi + (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j),ai.(j))) f' + ) [] + ) + | T.CoFix (i,(f,t,b)) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort then add_inner_type fresh_id'' ; + let fresh_idrefs = + Array.init (Array.length t) (function _ -> gen_id seed) in + let new_idrefs = + (List.rev (Array.to_list fresh_idrefs)) @ idrefs + in + let f' = + let ids = ref (Termops.ids_of_context env) in + Array.map + (function + N.Anonymous -> Util.error "Anonymous fix function met" + | N.Name id as n -> + let res = N.Name (Namegen.next_name_away n !ids) in + ids := id::!ids ; + res + ) f + in + A.ACoFix (fresh_id'', i, + Array.fold_right + (fun (id,fi,ti,bi) i -> + let fi' = + match fi with + N.Name fi -> fi + | N.Anonymous -> Util.error "Anonymous fix function met" + in + (id, fi', + aux' env idrefs ti, + aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i) + (Array.mapi + (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j)) ) f' + ) [] + ) + in + aux computeinnertypes None [] env idrefs t +;; + +(* Obsolete [HH 1/2009] +let acic_of_cic_context metasenv context t = + let ids_to_terms = Hashtbl.create 503 in + let constr_to_ids = Acic.CicHash.create 503 in + let ids_to_father_ids = Hashtbl.create 503 in + let ids_to_inner_sorts = Hashtbl.create 503 in + let ids_to_inner_types = Hashtbl.create 503 in + let seed = ref 0 in + acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids + ids_to_inner_sorts ids_to_inner_types metasenv context t, + ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types +;; +*) + +let acic_object_of_cic_object sigma obj = + let module A = Acic in + let ids_to_terms = Hashtbl.create 503 in + let constr_to_ids = Acic.CicHash.create 503 in + let ids_to_father_ids = Hashtbl.create 503 in + let ids_to_inner_sorts = Hashtbl.create 503 in + let ids_to_inner_types = Hashtbl.create 503 in + let ids_to_conjectures = Hashtbl.create 11 in + let ids_to_hypotheses = Hashtbl.create 127 in + let hypotheses_seed = ref 0 in + let conjectures_seed = ref 0 in + let seed = ref 0 in + let acic_term_of_cic_term_context' = + acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids + ids_to_inner_sorts ids_to_inner_types in +(*CSC: is this the right env to use? Hhmmm. There is a problem: in *) +(*CSC: Global.env () the object we are exporting is already defined, *) +(*CSC: either in the environment or in the named context (in the case *) +(*CSC: of variables. Is this a problem? *) + let env = Global.env () in + let acic_term_of_cic_term' ?fake_dependent_products = + acic_term_of_cic_term_context' ?fake_dependent_products env [] sigma in +(*CSC: the fresh_id is not stored anywhere. This _MUST_ be fixed using *) +(*CSC: a modified version of the already existent fresh_id function *) + let fresh_id () = + let res = "i" ^ string_of_int !seed in + incr seed ; + res + in + let aobj = + match obj with + A.Constant (id,bo,ty,params) -> + let abo = + match bo with + None -> None + | Some bo' -> Some (acic_term_of_cic_term' bo' (Some ty)) + in + let aty = acic_term_of_cic_term' ty None in + A.AConstant (fresh_id (),id,abo,aty,params) + | A.Variable (id,bo,ty,params) -> + let abo = + match bo with + Some bo -> Some (acic_term_of_cic_term' bo (Some ty)) + | None -> None + in + let aty = acic_term_of_cic_term' ty None in + A.AVariable (fresh_id (),id,abo,aty,params) + | A.CurrentProof (id,conjectures,bo,ty) -> + let aconjectures = + List.map + (function (i,canonical_context,term) as conjecture -> + let cid = "c" ^ string_of_int !conjectures_seed in + Hashtbl.add ids_to_conjectures cid conjecture ; + incr conjectures_seed ; + let canonical_env,idrefs',acanonical_context = + let rec aux env idrefs = + function + [] -> env,idrefs,[] + | ((n,decl_or_def) as hyp)::tl -> + let hid = "h" ^ string_of_int !hypotheses_seed in + let new_idrefs = hid::idrefs in + Hashtbl.add ids_to_hypotheses hid hyp ; + incr hypotheses_seed ; + match decl_or_def with + A.Decl t -> + let final_env,final_idrefs,atl = + aux (Environ.push_rel (Names.Name n,None,t) env) + new_idrefs tl + in + let at = + acic_term_of_cic_term_context' env idrefs sigma t None + in + final_env,final_idrefs,(hid,(n,A.Decl at))::atl + | A.Def (t,ty) -> + let final_env,final_idrefs,atl = + aux + (Environ.push_rel (Names.Name n,Some t,ty) env) + new_idrefs tl + in + let at = + acic_term_of_cic_term_context' env idrefs sigma t None + in + let dummy_never_used = + let s = "dummy_never_used" in + A.ARel (s,99,s,Names.id_of_string s) + in + final_env,final_idrefs, + (hid,(n,A.Def (at,dummy_never_used)))::atl + in + aux env [] canonical_context + in + let aterm = + acic_term_of_cic_term_context' canonical_env idrefs' sigma term + None + in + (cid,i,List.rev acanonical_context,aterm) + ) conjectures in + let abo = acic_term_of_cic_term_context' env [] sigma bo (Some ty) in + let aty = acic_term_of_cic_term_context' env [] sigma ty None in + A.ACurrentProof (fresh_id (),id,aconjectures,abo,aty) + | A.InductiveDefinition (tys,params,paramsno) -> + let env' = + List.fold_right + (fun (name,_,arity,_) env -> + Environ.push_rel (Names.Name name, None, arity) env + ) (List.rev tys) env in + let idrefs = List.map (function _ -> gen_id seed) tys in + let atys = + List.map2 + (fun id (name,inductive,ty,cons) -> + let acons = + List.map + (function (name,ty) -> + (name, + acic_term_of_cic_term_context' ~fake_dependent_products:true + env' idrefs Evd.empty ty None) + ) cons + in + let aty = + acic_term_of_cic_term' ~fake_dependent_products:true ty None + in + (id,name,inductive,aty,acons) + ) (List.rev idrefs) tys + in + A.AInductiveDefinition (fresh_id (),atys,params,paramsno) + in + aobj,ids_to_terms,constr_to_ids,ids_to_father_ids,ids_to_inner_sorts, + ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses +;; diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml new file mode 100644 index 00000000..f8921aec --- /dev/null +++ b/plugins/xml/doubleTypeInference.ml @@ -0,0 +1,272 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Some {Environ.utj_val = j.Environ.uj_val; Environ.utj_type = s } + | _ -> None (* None means the CProp constant *) +;; + +let double_type_of env sigma cstr expectedty subterms_to_types = + (*CSC: the code is inefficient because judgments are created just to be *) + (*CSC: destroyed using Environ.j_type. Moreover I am pretty sure that the *) + (*CSC: functions used do checks that we do not need *) + let rec execute env sigma cstr expectedty = + let module T = Term in + let module E = Environ in + (* the type part is the synthesized type *) + let judgement = + match T.kind_of_term cstr with + T.Meta n -> + Util.error + "DoubleTypeInference.double_type_of: found a non-instanciated goal" + + | T.Evar ((n,l) as ev) -> + let ty = Unshare.unshare (Evd.existential_type sigma ev) in + let jty = execute env sigma ty None in + let jty = assumption_of_judgment env sigma jty in + let evar_context = + E.named_context_of_val (Evd.find sigma n).Evd.evar_hyps in + let rec iter actual_args evar_context = + match actual_args,evar_context with + [],[] -> () + | he1::tl1,(n,_,ty)::tl2 -> + (* for side-effects *) + let _ = execute env sigma he1 (Some ty) in + let tl2' = + List.map + (function (m,bo,ty) -> + (* Warning: the substitution should be performed also on bo *) + (* This is not done since bo is not used later yet *) + (m,bo,Unshare.unshare (T.replace_vars [n,he1] ty)) + ) tl2 + in + iter tl1 tl2' + | _,_ -> assert false + in + (* for side effects only *) + iter (List.rev (Array.to_list l)) (List.rev evar_context) ; + E.make_judge cstr jty + + | T.Rel n -> + Typeops.judge_of_relative env n + + | T.Var id -> + Typeops.judge_of_variable env id + + | T.Const c -> + E.make_judge cstr (Typeops.type_of_constant env c) + + | T.Ind ind -> + E.make_judge cstr (Inductiveops.type_of_inductive env ind) + + | T.Construct cstruct -> + E.make_judge cstr (Inductiveops.type_of_constructor env cstruct) + + | T.Case (ci,p,c,lf) -> + let expectedtype = + Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in + let cj = execute env sigma c (Some expectedtype) in + let pj = execute env sigma p None in + let (expectedtypes,_,_) = + let indspec = Inductive.find_rectype env cj.Environ.uj_type in + Inductive.type_case_branches env indspec pj cj.Environ.uj_val + in + let lfj = + execute_array env sigma lf + (Array.map (function x -> Some x) expectedtypes) in + let (j,_) = Typeops.judge_of_case env ci pj cj lfj in + j + + | T.Fix ((vn,i as vni),recdef) -> + let (_,tys,_ as recdef') = execute_recdef env sigma recdef in + let fix = (vni,recdef') in + E.make_judge (T.mkFix fix) tys.(i) + + | T.CoFix (i,recdef) -> + let (_,tys,_ as recdef') = execute_recdef env sigma recdef in + let cofix = (i,recdef') in + E.make_judge (T.mkCoFix cofix) tys.(i) + + | T.Sort (T.Prop c) -> + Typeops.judge_of_prop_contents c + + | T.Sort (T.Type u) -> +(*CSC: In case of need, I refresh the universe. But exportation of the *) +(*CSC: right universe level information is destroyed. It must be changed *) +(*CSC: again once Judicael will introduce his non-bugged algebraic *) +(*CSC: universes. *) +(try + Typeops.judge_of_type u + with _ -> (* Successor of a non universe-variable universe anomaly *) + (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ; + Typeops.judge_of_type (Termops.new_univ ()) +) + + | T.App (f,args) -> + let expected_head = + Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in + let j = execute env sigma f (Some expected_head) in + let expected_args = + let rec aux typ = + function + [] -> [] + | hj::restjl -> + match T.kind_of_term (Reduction.whd_betadeltaiota env typ) with + T.Prod (_,c1,c2) -> + (Some (Reductionops.nf_beta sigma c1)) :: + (aux (T.subst1 hj c2) restjl) + | _ -> assert false + in + Array.of_list (aux j.Environ.uj_type (Array.to_list args)) + in + let jl = execute_array env sigma args expected_args in + let (j,_) = Typeops.judge_of_apply env j jl in + j + + | T.Lambda (name,c1,c2) -> + let j = execute env sigma c1 None in + let var = type_judgment env sigma j in + let env1 = E.push_rel (name,None,var.E.utj_val) env in + let expectedc2type = + match expectedty with + None -> None + | Some ety -> + match T.kind_of_term (Reduction.whd_betadeltaiota env ety) with + T.Prod (_,_,expected_target_type) -> + Some (Reductionops.nf_beta sigma expected_target_type) + | _ -> assert false + in + let j' = execute env1 sigma c2 expectedc2type in + Typeops.judge_of_abstraction env1 name var j' + + | T.Prod (name,c1,c2) -> + let j = execute env sigma c1 None in + let varj = type_judgment env sigma j in + let env1 = E.push_rel (name,None,varj.E.utj_val) env in + let j' = execute env1 sigma c2 None in + (match type_judgment_cprop env1 sigma j' with + Some varj' -> Typeops.judge_of_product env name varj varj' + | None -> + (* CProp found *) + { Environ.uj_val = T.mkProd (name, j.Environ.uj_val, j'.Environ.uj_val); + Environ.uj_type = T.mkConst cprop }) + + | T.LetIn (name,c1,c2,c3) -> +(*CSC: What are the right expected types for the source and *) +(*CSC: target of a LetIn? None used. *) + let j1 = execute env sigma c1 None in + let j2 = execute env sigma c2 None in + let j2 = type_judgment env sigma j2 in + let env1 = + E.push_rel (name,Some j1.E.uj_val,j2.E.utj_val) env + in + let j3 = execute env1 sigma c3 None in + Typeops.judge_of_letin env name j1 j2 j3 + + | T.Cast (c,k,t) -> + let cj = execute env sigma c (Some (Reductionops.nf_beta sigma t)) in + let tj = execute env sigma t None in + let tj = type_judgment env sigma tj in + let j, _ = Typeops.judge_of_cast env cj k tj in + j + in + let synthesized = E.j_type judgement in + let synthesized' = Reductionops.nf_beta sigma synthesized in + let types,res = + match expectedty with + None -> + (* No expected type *) + {synthesized = synthesized' ; expected = None}, synthesized + | Some ty when Term.eq_constr synthesized' ty -> + (* The expected type is synthactically equal to the *) + (* synthesized type. Let's forget it. *) + (* Note: since eq_constr is up to casts, it is better *) + (* to keep the expected type, since it can bears casts *) + (* that change the innersort to CProp *) + {synthesized = ty ; expected = None}, ty + | Some expectedty' -> + {synthesized = synthesized' ; expected = Some expectedty'}, + expectedty' + in +(*CSC: debugging stuff to be removed *) +if Acic.CicHash.mem subterms_to_types cstr then + (Pp.ppnl (Pp.(++) (Pp.str "DUPLICATE INSERTION: ") (Printer.pr_lconstr cstr)) ; flush stdout ) ; + Acic.CicHash.add subterms_to_types cstr types ; + E.make_judge cstr res + + + and execute_recdef env sigma (names,lar,vdef) = + let length = Array.length lar in + let larj = + execute_array env sigma lar (Array.make length None) in + let lara = Array.map (assumption_of_judgment env sigma) larj in + let env1 = Environ.push_rec_types (names,lara,vdef) env in + let expectedtypes = + Array.map (function i -> Some (Term.lift length i)) lar + in + let vdefj = execute_array env1 sigma vdef expectedtypes in + let vdefv = Array.map Environ.j_val vdefj in + (names,lara,vdefv) + + and execute_array env sigma v expectedtypes = + let jl = + execute_list env sigma (Array.to_list v) (Array.to_list expectedtypes) + in + Array.of_list jl + + and execute_list env sigma = + List.map2 (execute env sigma) + +in + ignore (execute env sigma cstr expectedty) +;; diff --git a/plugins/xml/doubleTypeInference.mli b/plugins/xml/doubleTypeInference.mli new file mode 100644 index 00000000..b604ec4c --- /dev/null +++ b/plugins/xml/doubleTypeInference.mli @@ -0,0 +1,24 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Evd.evar_map -> Term.constr -> Term.constr + +val double_type_of : + Environ.env -> Evd.evar_map -> Term.constr -> Term.constr option -> + types Acic.CicHash.t -> unit diff --git a/plugins/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4 new file mode 100644 index 00000000..9419ba59 --- /dev/null +++ b/plugins/xml/dumptree.ml4 @@ -0,0 +1,152 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + try + if Sign.lookup_named id osign = (id,c,ty) then sign + else raise Different + with Not_found | Different -> Environ.push_named_context_val d sign) + sign ~init:Environ.empty_named_context_val +;; + +let pr_tactic_xml = function + | TacArg (Tacexp t) -> str "" + | t -> str "" +;; + +let pr_proof_instr_xml instr = + Ppdecl_proof.pr_proof_instr (Global.env()) instr +;; + +let pr_rule_xml pr = function + | Prim r -> str "" + | Nested(cmpd, subtree) -> + hov 2 (str "" ++ fnl () ++ + begin match cmpd with + Tactic (texp, _) -> pr_tactic_xml texp + | Proof_instr (_,instr) -> pr_proof_instr_xml instr + end ++ fnl () + ++ pr subtree + ) ++ fnl () ++ str "" + | Daimon -> str "" + | Decl_proof _ -> str "" +(* | Change_evars -> str ""*) +;; + +let pr_var_decl_xml env (id,c,typ) = + let ptyp = print_constr_env env typ in + match c with + | None -> + (str "") + | Some c -> + (* Force evaluation *) + let pb = print_constr_env env c in + (str "") +;; + +let pr_rel_decl_xml env (na,c,typ) = + let pbody = match c with + | None -> mt () + | Some c -> + (* Force evaluation *) + let pb = print_constr_env env c in + (str" body=\"" ++ xmlstream pb ++ str "\"") in + let ptyp = print_constr_env env typ in + let pid = + match na with + | Anonymous -> mt () + | Name id -> str " id=\"" ++ pr_id id ++ str "\"" + in + (str "") +;; + +let pr_context_xml env = + let sign_env = + fold_named_context + (fun env d pp -> pp ++ pr_var_decl_xml env d) + env ~init:(mt ()) + in + let db_env = + fold_rel_context + (fun env d pp -> pp ++ pr_rel_decl_xml env d) + env ~init:(mt ()) + in + (sign_env ++ db_env) +;; + +let pr_subgoal_metas_xml metas env= + let pr_one (meta, typ) = + fnl () ++ str "" + in + List.fold_left (++) (mt ()) (List.map pr_one metas) +;; + +let pr_goal_xml g = + let env = try evar_unfiltered_env g with _ -> empty_env in + if g.evar_extra = None then + (hov 2 (str "" ++ fnl () ++ str "" ++ + (pr_context_xml env)) ++ + fnl () ++ str "") + else + (hov 2 (str "" ++ + (pr_context_xml env)) ++ + fnl () ++ str "") +;; + +let rec print_proof_xml sigma osign pf = + let hyps = Environ.named_context_of_val pf.goal.evar_hyps in + let hyps' = thin_sign osign hyps in + match pf.ref with + | None -> hov 2 (str "" ++ fnl () ++ (pr_goal_xml {pf.goal with evar_hyps=hyps'})) ++ fnl () ++ str "" + | Some(r,spfl) -> + hov 2 (str "" ++ fnl () ++ + (pr_goal_xml {pf.goal with evar_hyps=hyps'}) ++ fnl () ++ (pr_rule_xml (print_proof_xml sigma osign) r) ++ + (List.fold_left (fun x y -> x ++ fnl () ++ y) (mt ()) (List.map (print_proof_xml sigma hyps) spfl))) ++ fnl () ++ str "" +;; + +let print_proof_xml () = + let pp = print_proof_xml Evd.empty Sign.empty_named_context + (Tacmach.proof_of_pftreestate (Refiner.top_of_tree (Pfedit.get_pftreestate ()))) + in + msgnl pp +;; + +VERNAC COMMAND EXTEND DumpTree + [ "Dump" "Tree" ] -> [ print_proof_xml () ] +END diff --git a/plugins/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml new file mode 100644 index 00000000..1beabf26 --- /dev/null +++ b/plugins/xml/proof2aproof.ml @@ -0,0 +1,176 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t + | T.Cast (c1,k,c2) -> T.mkCast (aux c1, k, aux c2) + | T.Prod (na,c1,c2) -> T.mkProd (na, aux c1, aux c2) + | T.Lambda (na,t,c) -> T.mkLambda (na, aux t, aux c) + | T.LetIn (na,b,t,c) -> T.mkLetIn (na, aux b, aux t, aux c) + | T.App (c,l) -> + let c' = aux c in + let l' = Array.map aux l in + (match T.kind_of_term c' with + T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l') + | T.Cast (he,_,_) -> + (match T.kind_of_term he with + T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l') + | _ -> T.mkApp (c', l') + ) + | _ -> T.mkApp (c', l')) + | T.Evar (e,l) when Evd.mem sigma e & Evd.is_defined sigma e -> + aux (Evd.existential_value sigma (e,l)) + | T.Evar (e,l) -> T.mkEvar (e, Array.map aux l) + | T.Case (ci,p,c,bl) -> T.mkCase (ci, aux p, aux c, Array.map aux bl) + | T.Fix (ln,(lna,tl,bl)) -> + T.mkFix (ln,(lna,Array.map aux tl,Array.map aux bl)) + | T.CoFix(ln,(lna,tl,bl)) -> + T.mkCoFix (ln,(lna,Array.map aux tl,Array.map aux bl)) + in + aux +;; + +(* Unshares a proof-tree. *) +(* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *) +let rec unshare_proof_tree = + let module PT = Proof_type in + function {PT.open_subgoals = status ; + PT.goal = goal ; + PT.ref = ref} -> + let unshared_ref = + match ref with + None -> None + | Some (rule,pfs) -> + let unshared_rule = + match rule with + PT.Nested (cmpd, pf) -> + PT.Nested (cmpd, unshare_proof_tree pf) + | other -> other + in + Some (unshared_rule, List.map unshare_proof_tree pfs) + in + {PT.open_subgoals = status ; + PT.goal = goal ; + PT.ref = unshared_ref} +;; + +module ProofTreeHash = + Hashtbl.Make + (struct + type t = Proof_type.proof_tree + let equal = (==) + let hash = Hashtbl.hash + end) +;; + + +let extract_open_proof sigma pf = + let module PT = Proof_type in + let module L = Logic in + let evd = ref (Evd.create_evar_defs sigma) in + let proof_tree_to_constr = ProofTreeHash.create 503 in + let proof_tree_to_flattened_proof_tree = ProofTreeHash.create 503 in + let unshared_constrs = ref S.empty in + let rec proof_extractor vl node = + let constr = + match node with + {PT.ref=Some(PT.Prim _,_)} as pf -> + L.prim_extractor proof_extractor vl pf + + | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} -> + let sgl,v = Refiner.frontier hidden_proof in + let flat_proof = v spfl in + ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ; + proof_extractor vl flat_proof + + | {PT.ref=None;PT.goal=goal} -> + let visible_rels = + Util.map_succeed + (fun id -> + (* Section variables are in the [id] list but are not *) + (* lambda abstracted in the term [vl] *) + try let n = Logic.proof_variable_index id vl in (n,id) + with Not_found -> failwith "caught") +(*CSC: the above function must be modified such that when it is found *) +(*CSC: it becomes a Rel; otherwise a Var. Then it can be already used *) +(*CSC: as the evar_instance. Ordering the instance becomes useless (it *) +(*CSC: will already be ordered. *) + (Termops.ids_of_named_context + (Environ.named_context_of_val goal.Evd.evar_hyps)) in + let sorted_rels = + Sort.list (fun (n1,_) (n2,_) -> n1 < n2 ) visible_rels in + let context = + let l = + List.map + (fun (_,id) -> Sign.lookup_named id + (Environ.named_context_of_val goal.Evd.evar_hyps)) + sorted_rels in + Environ.val_of_named_context l + in +(*CSC: the section variables in the right order must be added too *) + let evar_instance = List.map (fun (n,_) -> Term.mkRel n) sorted_rels in + (* let env = Global.env_of_context context in *) + let evd',evar = + Evarutil.new_evar_instance context !evd goal.Evd.evar_concl + evar_instance in + evd := evd' ; + evar + + | _ -> Util.anomaly "Bug : a case has been forgotten in proof_extractor" + in + let unsharedconstr = + let evar_nf_constr = + nf_evar ( !evd) + ~preserve:(function e -> S.mem e !unshared_constrs) constr + in + Unshare.unshare + ~already_unshared:(function e -> S.mem e !unshared_constrs) + evar_nf_constr + in +(*CSC: debugging stuff to be removed *) +if ProofTreeHash.mem proof_tree_to_constr node then + Pp.ppnl (Pp.(++) (Pp.str "#DUPLICATE INSERTION: ") + (Tactic_printer.print_proof ( !evd) [] node)) ; + ProofTreeHash.add proof_tree_to_constr node unsharedconstr ; + unshared_constrs := S.add unsharedconstr !unshared_constrs ; + unsharedconstr + in + let unshared_pf = unshare_proof_tree pf in + let pfterm = proof_extractor [] unshared_pf in + (pfterm, !evd, proof_tree_to_constr, proof_tree_to_flattened_proof_tree, + unshared_pf) +;; + +let extract_open_pftreestate pts = + extract_open_proof (Refiner.evc_of_pftreestate pts) + (Tacmach.proof_of_pftreestate pts) +;; diff --git a/plugins/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4 new file mode 100644 index 00000000..3f1e0a63 --- /dev/null +++ b/plugins/xml/proofTree2Xml.ml4 @@ -0,0 +1,210 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* not (List.mem n real_named_context)) named_context + in + let idrefs = + List.map + (function x,_,_ -> idref_of_id (Names.string_of_id x)) named_context' in + let rel_context = Sign.push_named_to_rel_context named_context' [] in + let rel_env = + Environ.push_rel_context rel_context + (Environ.reset_with_named_context + (Environ.val_of_named_context real_named_context) env) in + let obj' = + Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in + let seed = ref 0 in + try + let annobj = + Cic2acic.acic_of_cic_context' false seed ids_to_terms constr_to_ids + ids_to_father_ids ids_to_inner_sorts ids_to_inner_types rel_env + idrefs sigma (Unshare.unshare obj') None + in + Acic2Xml.print_term ids_to_inner_sorts annobj + with e -> + Util.anomaly + ("Problem during the conversion of constr into XML: " ^ + Printexc.to_string e) +(* CSC: debugging stuff +Pp.ppnl (Pp.str "Problem during the conversion of constr into XML") ; +Pp.ppnl (Pp.str "ENVIRONMENT:") ; +Pp.ppnl (Printer.pr_context_of rel_env) ; +Pp.ppnl (Pp.str "TERM:") ; +Pp.ppnl (Printer.pr_lconstr_env rel_env obj') ; +Pp.ppnl (Pp.str "RAW-TERM:") ; +Pp.ppnl (Printer.pr_lconstr obj') ; +Xml.xml_empty "MISSING TERM" [] (*; raise e*) +*) +;; + +let first_word s = + try let i = String.index s ' ' in + String.sub s 0 i + with _ -> s +;; + +let string_of_prim_rule x = match x with + | Proof_type.Intro _-> "Intro" + | Proof_type.Cut _ -> "Cut" + | Proof_type.FixRule _ -> "FixRule" + | Proof_type.Cofix _ -> "Cofix" + | Proof_type.Refine _ -> "Refine" + | Proof_type.Convert_concl _ -> "Convert_concl" + | Proof_type.Convert_hyp _->"Convert_hyp" + | Proof_type.Thin _ -> "Thin" + | Proof_type.ThinBody _-> "ThinBody" + | Proof_type.Move (_,_,_) -> "Move" + | Proof_type.Order _ -> "Order" + | Proof_type.Rename (_,_) -> "Rename" + | Proof_type.Change_evars -> "Change_evars" + +let + print_proof_tree curi sigma pf proof_tree_to_constr + proof_tree_to_flattened_proof_tree constr_to_ids += + let module PT = Proof_type in + let module L = Logic in + let module X = Xml in + let module T = Tacexpr in + let ids_of_node node = + let constr = Proof2aproof.ProofTreeHash.find proof_tree_to_constr node in +(* +let constr = + try + Proof2aproof.ProofTreeHash.find proof_tree_to_constr node + with _ -> Pp.ppnl (Pp.(++) (Pp.str "Node of the proof-tree that generated +no lambda-term: ") (Refiner.print_script true (Evd.empty) +(Global.named_context ()) node)) ; assert false (* Closed bug, should not +happen any more *) +in +*) + try + Some (Acic.CicHash.find constr_to_ids constr) + with _ -> +Pp.ppnl (Pp.(++) (Pp.str +"The_generated_term_is_not_a_subterm_of_the_final_lambda_term") +(Printer.pr_lconstr constr)) ; + None + in + let rec aux node old_hyps = + let of_attribute = + match ids_of_node node with + None -> [] + | Some id -> ["of",id] + in + match node with + {PT.ref=Some(PT.Prim tactic_expr,nodes)} -> + let tac = string_of_prim_rule tactic_expr in + let of_attribute = ("name",tac)::of_attribute in + if nodes = [] then + X.xml_empty "Prim" of_attribute + else + X.xml_nempty "Prim" of_attribute + (List.fold_left + (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes) + + | {PT.goal=goal; + PT.ref=Some(PT.Nested (PT.Tactic(tactic_expr,_),hidden_proof),nodes)} -> + (* [hidden_proof] is the proof of the tactic; *) + (* [nodes] are the proof of the subgoals generated by the tactic; *) + (* [flat_proof] if the proof-tree obtained substituting [nodes] *) + (* for the holes in [hidden_proof] *) + let flat_proof = + Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node + in begin + match tactic_expr with + | T.TacArg (T.Tacexp _) -> + (* We don't need to keep the level of abstraction introduced at *) + (* user-level invocation of tactic... (see Tacinterp.hide_interp)*) + aux flat_proof old_hyps + | _ -> + (****** la tactique employee *) + let prtac = Pptactic.pr_tactic (Global.env()) in + let tac = std_ppcmds_to_string (prtac tactic_expr) in + let tacname= first_word tac in + let of_attribute = ("name",tacname)::("script",tac)::of_attribute in + + (****** le but *) + let {Evd.evar_concl=concl; + Evd.evar_hyps=hyps}=goal in + + let env = Global.env_of_context hyps in + + let xgoal = + X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in + + let rec build_hyps = + function + | [] -> xgoal + | (id,c,tid)::hyps1 -> + let id' = Names.string_of_id id in + [< build_hyps hyps1; + (X.xml_nempty "Hypothesis" + ["id",idref_of_id id' ; "name",id'] + (constr_to_xml tid sigma env)) + >] in + let old_names = List.map (fun (id,c,tid)->id) old_hyps in + let nhyps = Environ.named_context_of_val hyps in + let new_hyps = + List.filter (fun (id,c,tid)-> not (List.mem id old_names)) nhyps in + + X.xml_nempty "Tactic" of_attribute + [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>] + end + + | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} -> + Util.anomaly "Not Implemented" + + | {PT.ref=Some(PT.Daimon,_)} -> + X.xml_empty "Hidden_open_goal" of_attribute + + | {PT.ref=None;PT.goal=goal} -> + X.xml_empty "Open_goal" of_attribute + in + [< X.xml_cdata "\n" ; + X.xml_cdata ("\n\n"); + X.xml_nempty "ProofTree" ["of",curi] (aux pf []) + >] +;; + + +(* Hook registration *) +(* CSC: debranched since it is bugged +Xmlcommand.set_print_proof_tree print_proof_tree;; +*) diff --git a/plugins/xml/theoryobject.dtd b/plugins/xml/theoryobject.dtd new file mode 100644 index 00000000..953fe009 --- /dev/null +++ b/plugins/xml/theoryobject.dtd @@ -0,0 +1,62 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/plugins/xml/unshare.ml b/plugins/xml/unshare.ml new file mode 100644 index 00000000..f30f8230 --- /dev/null +++ b/plugins/xml/unshare.ml @@ -0,0 +1,52 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* false) t = + let obj = Obj.repr t in + let rec aux obj = + if already_unshared (Obj.obj obj) then + obj + else + (if Obj.is_int obj then + obj + else if Obj.is_block obj then + begin + let tag = Obj.tag obj in + if tag < Obj.no_scan_tag then + begin + let size = Obj.size obj in + let new_obj = Obj.new_block 0 size in + Obj.set_tag new_obj tag ; + for i = 0 to size - 1 do + Obj.set_field new_obj i (aux (Obj.field obj i)) + done ; + new_obj + end + else if tag = Obj.string_tag then + obj + else + raise CanNotUnshare + end + else + raise CanNotUnshare + ) + in + Obj.obj (aux obj) +;; diff --git a/plugins/xml/unshare.mli b/plugins/xml/unshare.mli new file mode 100644 index 00000000..31ba9037 --- /dev/null +++ b/plugins/xml/unshare.mli @@ -0,0 +1,21 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool) -> 'a -> 'a diff --git a/plugins/xml/xml.ml4 b/plugins/xml/xml.ml4 new file mode 100644 index 00000000..5b217119 --- /dev/null +++ b/plugins/xml/xml.ml4 @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ] +let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >] +let xml_cdata str = [< 'Str str >] + +(* Usage: *) +(* pp tokens None pretty prints the output on stdout *) +(* pp tokens (Some filename) pretty prints the output on the file filename *) +let pp_ch strm channel = + let rec pp_r m = + parser + [< 'Str a ; s >] -> + print_spaces m ; + fprint_string (a ^ "\n") ; + pp_r m s + | [< 'Empty(n,l) ; s >] -> + print_spaces m ; + fprint_string ("<" ^ n) ; + List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l; + fprint_string "/>\n" ; + pp_r m s + | [< 'NEmpty(n,l,c) ; s >] -> + print_spaces m ; + fprint_string ("<" ^ n) ; + List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l; + fprint_string ">\n" ; + pp_r (m+1) c ; + print_spaces m ; + fprint_string ("\n") ; + pp_r m s + | [< >] -> () + and print_spaces m = + for i = 1 to m do fprint_string " " done + and fprint_string str = + output_string channel str + in + pp_r 0 strm +;; + + +let pp strm fn = + match fn with + Some filename -> + let filename = filename ^ ".xml" in + let ch = open_out filename in + pp_ch strm ch; + close_out ch ; + print_string ("\nWriting on file \"" ^ filename ^ "\" was successful\n"); + flush stdout + | None -> + pp_ch strm stdout +;; + diff --git a/plugins/xml/xml.mli b/plugins/xml/xml.mli new file mode 100644 index 00000000..3775287a --- /dev/null +++ b/plugins/xml/xml.mli @@ -0,0 +1,40 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (string * string) list -> token Stream.t +val xml_nempty : + string -> (string * string) list -> token Stream.t -> token Stream.t +val xml_cdata : string -> token Stream.t + +val pp_ch : token Stream.t -> out_channel -> unit + +(* The pretty printer for streams of token *) +(* Usage: *) +(* pp tokens None pretty prints the output on stdout *) +(* pp tokens (Some filename) pretty prints the output on the file filename *) +val pp : token Stream.t -> string option -> unit diff --git a/plugins/xml/xml_plugin.mllib b/plugins/xml/xml_plugin.mllib new file mode 100644 index 00000000..90797e8d --- /dev/null +++ b/plugins/xml/xml_plugin.mllib @@ -0,0 +1,13 @@ +Unshare +Xml +Acic +DoubleTypeInference +Cic2acic +Acic2Xml +Proof2aproof +Xmlcommand +ProofTree2Xml +Xmlentries +Cic2Xml +Dumptree +Xml_plugin_mod diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml new file mode 100644 index 00000000..2299e6c8 --- /dev/null +++ b/plugins/xml/xmlcommand.ml @@ -0,0 +1,719 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* None) in + (fun () -> !print_proof_tree), + (fun f -> + print_proof_tree := + fun + curi sigma0 pf proof_tree_to_constr proof_tree_to_flattened_proof_tree + constr_to_ids + -> + Some + (f curi sigma0 pf proof_tree_to_constr + proof_tree_to_flattened_proof_tree constr_to_ids)) +;; + +(* UTILITY FUNCTIONS *) + +let print_if_verbose s = if !verbose then print_string s;; + +(* Next exception is used only inside print_coq_object and tag_of_string_tag *) +exception Uninteresting;; + +(* NOT USED anymore, we back to the V6 point of view with global parameters + +(* Internally, for Coq V7, params of inductive types are associated *) +(* not to the whole block of mutual inductive (as it was in V6) but to *) +(* each member of the block; but externally, all params are required *) +(* to be the same; the following function checks that the parameters *) +(* of each inductive of a same block are all the same, then returns *) +(* this number; it fails otherwise *) +let extract_nparams pack = + let module D = Declarations in + let module U = Util in + let module S = Sign in + + let {D.mind_nparams=nparams0} = pack.(0) in + let arity0 = pack.(0).D.mind_user_arity in + let params0, _ = S.decompose_prod_n_assum nparams0 arity0 in + for i = 1 to Array.length pack - 1 do + let {D.mind_nparams=nparamsi} = pack.(i) in + let arityi = pack.(i).D.mind_user_arity in + let paramsi, _ = S.decompose_prod_n_assum nparamsi arityi in + if params0 <> paramsi then U.error "Cannot convert a block of inductive definitions with parameters specific to each inductive to a block of mutual inductive definitions with parameters global to the whole block" + done; + nparams0 + +*) + +(* could_have_namesakes sp = true iff o is an object that could be cooked and *) +(* than that could exists in cooked form with the same name in a super *) +(* section of the actual section *) +let could_have_namesakes o sp = (* namesake = omonimo in italian *) + let module DK = Decl_kinds in + let module D = Declare in + let tag = Libobject.object_tag o in + print_if_verbose ("Object tag: " ^ tag ^ "\n") ; + match tag with + "CONSTANT" -> true (* constants/parameters are non global *) + | "INDUCTIVE" -> true (* mutual inductive types are never local *) + | "VARIABLE" -> false (* variables are local, so no namesakes *) + | _ -> false (* uninteresting thing that won't be printed*) +;; + +(* filter_params pvars hyps *) +(* filters out from pvars (which is a list of lists) all the variables *) +(* that does not belong to hyps (which is a simple list) *) +(* It returns a list of couples relative section path -- list of *) +(* variable names. *) +let filter_params pvars hyps = + let rec aux ids = + function + [] -> [] + | (id,he)::tl -> + let ids' = id::ids in + let ids'' = + "cic:/" ^ + String.concat "/" (List.rev (List.map Names.string_of_id ids')) in + let he' = + ids'', List.rev (List.filter (function x -> List.mem x hyps) he) in + let tl' = aux ids' tl in + match he' with + _,[] -> tl' + | _,_ -> he'::tl' + in + let cwd = Lib.cwd () in + let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in + let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in + aux (Names.repr_dirpath modulepath) (List.rev pvars) +;; + +type variables_type = + Definition of string * Term.constr * Term.types + | Assumption of string * Term.constr +;; + +(* The computation is very inefficient, but we can't do anything *) +(* better unless this function is reimplemented in the Declare *) +(* module. *) +let search_variables () = + let module N = Names in + let cwd = Lib.cwd () in + let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in + let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in + let rec aux = + function + [] -> [] + | he::tl as modules -> + let one_section_variables = + let dirpath = N.make_dirpath (modules @ N.repr_dirpath modulepath) in + let t = List.map N.string_of_id (Decls.last_section_hyps dirpath) in + [he,t] + in + one_section_variables @ aux tl + in + aux + (Cic2acic.remove_module_dirpath_from_dirpath + ~basedir:modulepath cwd) +;; + +(* FUNCTIONS TO PRINT A SINGLE OBJECT OF COQ *) + +let rec join_dirs cwd = + function + [] -> cwd + | he::tail -> + (try + Unix.mkdir cwd 0o775 + with _ -> () (* Let's ignore the errors on mkdir *) + ) ; + let newcwd = cwd ^ "/" ^ he in + join_dirs newcwd tail +;; + +let filename_of_path xml_library_root tag = + let module N = Names in + match xml_library_root with + None -> None (* stdout *) + | Some xml_library_root' -> + let tokens = Cic2acic.token_list_of_kernel_name tag in + Some (join_dirs xml_library_root' tokens) +;; + +let body_filename_of_filename = + function + Some f -> Some (f ^ ".body") + | None -> None +;; + +let types_filename_of_filename = + function + Some f -> Some (f ^ ".types") + | None -> None +;; + +let prooftree_filename_of_filename = + function + Some f -> Some (f ^ ".proof_tree") + | None -> None +;; + +let theory_filename xml_library_root = + let module N = Names in + match xml_library_root with + None -> None (* stdout *) + | Some xml_library_root' -> + let toks = List.map N.string_of_id (N.repr_dirpath (Lib.library_dp ())) in + (* theory from A/B/C/F.v goes into A/B/C/F.theory *) + let alltoks = List.rev toks in + Some (join_dirs xml_library_root' alltoks ^ ".theory") + +let print_object uri obj sigma proof_tree_infos filename = + (* function to pretty print and compress an XML file *) +(*CSC: Unix.system "gzip ..." is an horrible non-portable solution. *) + let pp xml filename = + Xml.pp xml filename ; + match filename with + None -> () + | Some fn -> + let fn' = + let rec escape s n = + try + let p = String.index_from s n '\'' in + String.sub s n (p - n) ^ "\\'" ^ escape s (p+1) + with Not_found -> String.sub s n (String.length s - n) + in + escape fn 0 + in + ignore (Unix.system ("gzip " ^ fn' ^ ".xml")) + in + let (annobj,_,constr_to_ids,_,ids_to_inner_sorts,ids_to_inner_types,_,_) = + Cic2acic.acic_object_of_cic_object sigma obj in + let (xml, xml') = Acic2Xml.print_object uri ids_to_inner_sorts annobj in + let xmltypes = + Acic2Xml.print_inner_types uri ids_to_inner_sorts ids_to_inner_types in + pp xml filename ; + begin + match xml' with + None -> () + | Some xml' -> pp xml' (body_filename_of_filename filename) + end ; + pp xmltypes (types_filename_of_filename filename) ; + match proof_tree_infos with + None -> () + | Some (sigma0,proof_tree,proof_tree_to_constr, + proof_tree_to_flattened_proof_tree) -> + let xmlprooftree = + print_proof_tree () + uri sigma0 proof_tree proof_tree_to_constr + proof_tree_to_flattened_proof_tree constr_to_ids + in + match xmlprooftree with + None -> () + | Some xmlprooftree -> + pp xmlprooftree (prooftree_filename_of_filename filename) +;; + +let string_list_of_named_context_list = + List.map + (function (n,_,_) -> Names.string_of_id n) +;; + +(* Function to collect the variables that occur in a term. *) +(* Used only for variables (since for constants and mutual *) +(* inductive types this information is already available. *) +let find_hyps t = + let module T = Term in + let rec aux l t = + match T.kind_of_term t with + T.Var id when not (List.mem id l) -> + let (_,bo,ty) = Global.lookup_named id in + let boids = + match bo with + Some bo' -> aux l bo' + | None -> l + in + id::(aux boids ty) + | T.Var _ + | T.Rel _ + | T.Meta _ + | T.Evar _ + | T.Sort _ -> l + | T.Cast (te,_, ty) -> aux (aux l te) ty + | T.Prod (_,s,t) -> aux (aux l s) t + | T.Lambda (_,s,t) -> aux (aux l s) t + | T.LetIn (_,s,_,t) -> aux (aux l s) t + | T.App (he,tl) -> Array.fold_left (fun i x -> aux i x) (aux l he) tl + | T.Const con -> + let hyps = (Global.lookup_constant con).Declarations.const_hyps in + map_and_filter l hyps @ l + | T.Ind ind + | T.Construct (ind,_) -> + let hyps = (fst (Global.lookup_inductive ind)).Declarations.mind_hyps in + map_and_filter l hyps @ l + | T.Case (_,t1,t2,b) -> + Array.fold_left (fun i x -> aux i x) (aux (aux l t1) t2) b + | T.Fix (_,(_,tys,bodies)) + | T.CoFix (_,(_,tys,bodies)) -> + let r = Array.fold_left (fun i x -> aux i x) l tys in + Array.fold_left (fun i x -> aux i x) r bodies + and map_and_filter l = + function + [] -> [] + | (n,_,_)::tl when not (List.mem n l) -> n::(map_and_filter l tl) + | _::tl -> map_and_filter l tl + in + aux [] t +;; + +(* Functions to construct an object *) + +let mk_variable_obj id body typ = + let hyps,unsharedbody = + match body with + None -> [],None + | Some bo -> find_hyps bo, Some (Unshare.unshare bo) + in + let hyps' = find_hyps typ @ hyps in + let hyps'' = List.map Names.string_of_id hyps' in + let variables = search_variables () in + let params = filter_params variables hyps'' in + Acic.Variable + (Names.string_of_id id, unsharedbody, Unshare.unshare typ, params) +;; + +(* Unsharing is not performed on the body, that must be already unshared. *) +(* The evar map and the type, instead, are unshared by this function. *) +let mk_current_proof_obj is_a_variable id bo ty evar_map env = + let unshared_ty = Unshare.unshare ty in + let metasenv = + List.map + (function + (n, {Evd.evar_concl = evar_concl ; + Evd.evar_hyps = evar_hyps} + ) -> + (* We map the named context to a rel context and every Var to a Rel *) + let final_var_ids,context = + let rec aux var_ids = + function + [] -> var_ids,[] + | (n,None,t)::tl -> + let final_var_ids,tl' = aux (n::var_ids) tl in + let t' = Term.subst_vars var_ids t in + final_var_ids,(n, Acic.Decl (Unshare.unshare t'))::tl' + | (n,Some b,t)::tl -> + let final_var_ids,tl' = aux (n::var_ids) tl in + let b' = Term.subst_vars var_ids b in + (* t will not be exported to XML. Thus no unsharing performed *) + final_var_ids,(n, Acic.Def (Unshare.unshare b',t))::tl' + in + aux [] (List.rev (Environ.named_context_of_val evar_hyps)) + in + (* We map the named context to a rel context and every Var to a Rel *) + (n,context,Unshare.unshare (Term.subst_vars final_var_ids evar_concl)) + ) (Evarutil.non_instantiated evar_map) + in + let id' = Names.string_of_id id in + if metasenv = [] then + let ids = + Names.Idset.union + (Environ.global_vars_set env bo) (Environ.global_vars_set env ty) in + let hyps0 = Environ.keep_hyps env ids in + let hyps = string_list_of_named_context_list hyps0 in + (* Variables are the identifiers of the variables in scope *) + let variables = search_variables () in + let params = filter_params variables hyps in + if is_a_variable then + Acic.Variable (id',Some bo,unshared_ty,params) + else + Acic.Constant (id',Some bo,unshared_ty,params) + else + Acic.CurrentProof (id',metasenv,bo,unshared_ty) +;; + +let mk_constant_obj id bo ty variables hyps = + let hyps = string_list_of_named_context_list hyps in + let ty = Unshare.unshare ty in + let params = filter_params variables hyps in + match bo with + None -> + Acic.Constant (Names.string_of_id id,None,ty,params) + | Some c -> + Acic.Constant + (Names.string_of_id id, Some (Unshare.unshare (Declarations.force c)), + ty,params) +;; + +let mk_inductive_obj sp mib packs variables nparams hyps finite = + let module D = Declarations in + let hyps = string_list_of_named_context_list hyps in + let params = filter_params variables hyps in +(* let nparams = extract_nparams packs in *) + let tys = + let tyno = ref (Array.length packs) in + Array.fold_right + (fun p i -> + decr tyno ; + let {D.mind_consnames=consnames ; + D.mind_typename=typename } = p + in + let arity = Inductive.type_of_inductive (Global.env()) (mib,p) in + let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in + let cons = + (Array.fold_right (fun (name,lc) i -> (name,lc)::i) + (Array.mapi + (fun j x ->(x,Unshare.unshare lc.(j))) consnames) + [] + ) + in + (typename,finite,Unshare.unshare arity,cons)::i + ) packs [] + in + Acic.InductiveDefinition (tys,params,nparams) +;; + +(* The current channel for .theory files *) +let theory_buffer = Buffer.create 4000;; + +let theory_output_string ?(do_not_quote = false) s = + (* prepare for coqdoc post-processing *) + let s = if do_not_quote then s else "(** #"^s^"\n#*)\n" in + print_if_verbose s; + Buffer.add_string theory_buffer s +;; + +let kind_of_global_goal = function + | Decl_kinds.Global, Decl_kinds.DefinitionBody _ -> "DEFINITION","InteractiveDefinition" + | Decl_kinds.Global, (Decl_kinds.Proof k) -> "THEOREM",Decl_kinds.string_of_theorem_kind k + | Decl_kinds.Local, _ -> assert false + +let kind_of_inductive isrecord kn = + "DEFINITION", + if (fst (Global.lookup_inductive (kn,0))).Declarations.mind_finite + then begin + match isrecord with + | Declare.KernelSilent -> "Record" + | _ -> "Inductive" + end + else "CoInductive" +;; + +let kind_of_variable id = + let module DK = Decl_kinds in + match Decls.variable_kind id with + | DK.IsAssumption DK.Definitional -> "VARIABLE","Assumption" + | DK.IsAssumption DK.Logical -> "VARIABLE","Hypothesis" + | DK.IsAssumption DK.Conjectural -> "VARIABLE","Conjecture" + | DK.IsDefinition DK.Definition -> "VARIABLE","LocalDefinition" + | DK.IsProof _ -> "VARIABLE","LocalFact" + | _ -> Util.anomaly "Unsupported variable kind" +;; + +let kind_of_constant kn = + let module DK = Decl_kinds in + match Decls.constant_kind kn with + | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration" + | DK.IsAssumption DK.Logical -> "AXIOM","Axiom" + | DK.IsAssumption DK.Conjectural -> + Pp.warning "Conjecture not supported in dtd (used Declaration instead)"; + "AXIOM","Declaration" + | DK.IsDefinition DK.Definition -> "DEFINITION","Definition" + | DK.IsDefinition DK.Example -> + Pp.warning "Example not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.Coercion -> + Pp.warning "Coercion not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.SubClass -> + Pp.warning "SubClass not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.CanonicalStructure -> + Pp.warning "CanonicalStructure not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.Fixpoint -> + Pp.warning "Fixpoint not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.CoFixpoint -> + Pp.warning "CoFixpoint not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.Scheme -> + Pp.warning "Scheme not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.StructureComponent -> + Pp.warning "StructureComponent not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.IdentityCoercion -> + Pp.warning "IdentityCoercion not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.Instance -> + Pp.warning "Instance not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.Method -> + Pp.warning "Method not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsProof (DK.Theorem|DK.Lemma|DK.Corollary|DK.Fact|DK.Remark as thm) -> + "THEOREM",DK.string_of_theorem_kind thm + | DK.IsProof _ -> + Pp.warning "Unsupported theorem kind (used Theorem instead)"; + "THEOREM",DK.string_of_theorem_kind DK.Theorem +;; + +let kind_of_global r = + let module Ln = Libnames in + let module DK = Decl_kinds in + match r with + | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> + let isrecord = + try let _ = Recordops.lookup_projections kn in Declare.KernelSilent + with Not_found -> Declare.KernelVerbose in + kind_of_inductive isrecord (fst kn) + | Ln.VarRef id -> kind_of_variable id + | Ln.ConstRef kn -> kind_of_constant kn +;; + +let print_object_kind uri (xmltag,variation) = + let s = + Printf.sprintf "\n" xmltag uri variation + in + theory_output_string s +;; + +(* print id dest *) +(* where sp is the qualified identifier (section path) of a *) +(* definition/theorem, variable or inductive definition *) +(* and dest is either None (for stdout) or (Some filename) *) +(* pretty prints via Xml.pp the object whose identifier is id on dest *) +(* Note: it is printed only (and directly) the most cooked available *) +(* form of the definition (all the parameters are *) +(* lambda-abstracted, but the object can still refer to variables) *) +let print internal glob_ref kind xml_library_root = + let module D = Declarations in + let module De = Declare in + let module G = Global in + let module N = Names in + let module Nt = Nametab in + let module T = Term in + let module X = Xml in + let module Ln = Libnames in + (* Variables are the identifiers of the variables in scope *) + let variables = search_variables () in + let tag,obj = + match glob_ref with + Ln.VarRef id -> + (* this kn is fake since it is not provided by Coq *) + let kn = + let (mod_path,dir_path) = Lib.current_prefix () in + N.make_kn mod_path dir_path (N.label_of_id id) + in + let (_,body,typ) = G.lookup_named id in + Cic2acic.Variable kn,mk_variable_obj id body typ + | Ln.ConstRef kn -> + let id = N.id_of_label (N.con_label kn) in + let {D.const_body=val0 ; D.const_type = typ ; D.const_hyps = hyps} = + G.lookup_constant kn in + let typ = Typeops.type_of_constant_type (Global.env()) typ in + Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps + | Ln.IndRef (kn,_) -> + let mib = G.lookup_mind kn in + let {D.mind_nparams=nparams; + D.mind_packets=packs ; + D.mind_hyps=hyps; + D.mind_finite=finite} = mib in + Cic2acic.Inductive kn,mk_inductive_obj kn mib packs variables nparams hyps finite + | Ln.ConstructRef _ -> + Util.error ("a single constructor cannot be printed in XML") + in + let fn = filename_of_path xml_library_root tag in + let uri = Cic2acic.uri_of_kernel_name tag in + (match internal with + | Declare.KernelSilent -> () + | _ -> print_object_kind uri kind); + print_object uri obj Evd.empty None fn +;; + +let print_ref qid fn = + let ref = Nametab.global qid in + print Declare.UserVerbose ref (kind_of_global ref) fn + +(* show dest *) +(* where dest is either None (for stdout) or (Some filename) *) +(* pretty prints via Xml.pp the proof in progress on dest *) +let show_pftreestate internal fn (kind,pftst) id = + let pf = Tacmach.proof_of_pftreestate pftst in + let typ = (Proof_trees.goal_of_proof pf).Evd.evar_concl in + let val0,evar_map,proof_tree_to_constr,proof_tree_to_flattened_proof_tree, + unshared_pf + = + Proof2aproof.extract_open_pftreestate pftst in + let env = Global.env () in + let obj = + mk_current_proof_obj (fst kind = Decl_kinds.Local) id val0 typ evar_map env in + let uri = + match kind with + Decl_kinds.Local, _ -> + let uri = + "cic:/" ^ String.concat "/" + (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.TVariable) + in + let kind_of_var = "VARIABLE","LocalFact" in + (match internal with + | Declare.KernelSilent -> () + | _ -> print_object_kind uri kind_of_var + ); uri + | Decl_kinds.Global, _ -> + let uri = Cic2acic.uri_of_declaration id Cic2acic.TConstant in + (match internal with + | Declare.KernelSilent -> () + | _ -> print_object_kind uri (kind_of_global_goal kind) + ); uri + in + print_object uri obj evar_map + (Some (Tacmach.evc_of_pftreestate pftst,unshared_pf,proof_tree_to_constr, + proof_tree_to_flattened_proof_tree)) fn +;; + +let show fn = + let pftst = Pfedit.get_pftreestate () in + let (id,kind,_,_) = Pfedit.current_proof_statement () in + show_pftreestate Declare.KernelVerbose fn (kind,pftst) id +;; + + +(* Let's register the callbacks *) +let xml_library_root = + try + Some (Sys.getenv "COQ_XML_LIBRARY_ROOT") + with Not_found -> None +;; + +let proof_to_export = ref None (* holds the proof-tree to export *) +;; + +let _ = + Pfedit.set_xml_cook_proof + (function pftreestate -> proof_to_export := Some pftreestate) +;; + +let _ = + Declare.set_xml_declare_variable + (function (sp,kn) -> + let id = Libnames.basename sp in + print Declare.UserVerbose (Libnames.VarRef id) (kind_of_variable id) xml_library_root ; + proof_to_export := None) +;; + +let _ = + Declare.set_xml_declare_constant + (function (internal,kn) -> + match !proof_to_export with + None -> + print internal (Libnames.ConstRef kn) (kind_of_constant kn) + xml_library_root + | Some pftreestate -> + (* It is a proof. Let's export it starting from the proof-tree *) + (* I saved in the Pfedit.set_xml_cook_proof callback. *) + let fn = filename_of_path xml_library_root (Cic2acic.Constant kn) in + show_pftreestate internal fn pftreestate + (Names.id_of_label (Names.con_label kn)) ; + proof_to_export := None) +;; + +let _ = + Declare.set_xml_declare_inductive + (function (isrecord,(sp,kn)) -> + print Declare.UserVerbose (Libnames.IndRef (Names.mind_of_kn kn,0)) + (kind_of_inductive isrecord (Names.mind_of_kn kn)) + xml_library_root) +;; + +let _ = + Vernac.set_xml_start_library + (function () -> + Buffer.reset theory_buffer; + theory_output_string "\n"; + theory_output_string ("\n" ^ + "\n" ^ + "\n\n" ^ + "%xhtml-lat1.ent;\n" ^ + "%xhtml-special.ent;\n" ^ + "%xhtml-symbol.ent;\n" ^ + "]>\n\n"); + theory_output_string "\n"; + theory_output_string "\n\n") +;; + +let _ = + Vernac.set_xml_end_library + (function () -> + theory_output_string "\n\n"; + let ofn = theory_filename xml_library_root in + begin + match ofn with + None -> + Buffer.output_buffer stdout theory_buffer ; + | Some fn -> + let ch = open_out (fn ^ ".v") in + Buffer.output_buffer ch theory_buffer ; + close_out ch; + (* dummy glob file *) + let ch = open_out (fn ^ ".glob") in + close_out ch + end ; + Option.iter + (fun fn -> + let coqdoc = Filename.concat (Envars.coqbin ()) ("coqdoc" ^ Coq_config.exec_extension) in + let options = " --html -s --body-only --no-index --latin1 --raw-comments" in + let command cmd = + if Sys.command cmd <> 0 then + Util.anomaly ("Error executing \"" ^ cmd ^ "\"") + in + command (coqdoc^options^" -o "^fn^".xml "^fn^".v"); + command ("rm "^fn^".v "^fn^".glob"); + print_string("\nWriting on file \"" ^ fn ^ ".xml\" was successful\n")) + ofn) +;; + +let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ;; + +let uri_of_dirpath dir = + "/" ^ String.concat "/" + (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir))) +;; + +let _ = + Lib.set_xml_open_section + (fun _ -> + let s = "cic:" ^ uri_of_dirpath (Lib.cwd ()) in + theory_output_string ("")) +;; + +let _ = + Lib.set_xml_close_section + (fun _ -> theory_output_string "") +;; + +let _ = + Library.set_xml_require + (fun d -> theory_output_string + (Printf.sprintf "Require %s.
" + (uri_of_dirpath d) (Names.string_of_dirpath d))) +;; diff --git a/plugins/xml/xmlcommand.mli b/plugins/xml/xmlcommand.mli new file mode 100644 index 00000000..66ff9f0b --- /dev/null +++ b/plugins/xml/xmlcommand.mli @@ -0,0 +1,41 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* string option -> unit + +(* show dest *) +(* where dest is either None (for stdout) or (Some filename) *) +(* pretty prints via Xml.pp the proof in progress on dest *) +val show : string option -> unit + +(* set_print_proof_tree f *) +(* sets a callback function f to export the proof_tree to XML *) +val set_print_proof_tree : + (string -> + Evd.evar_map -> + Proof_type.proof_tree -> + Term.constr Proof2aproof.ProofTreeHash.t -> + Proof_type.proof_tree Proof2aproof.ProofTreeHash.t -> + string Acic.CicHash.t -> Xml.token Stream.t) -> + unit diff --git a/plugins/xml/xmlentries.ml4 b/plugins/xml/xmlentries.ml4 new file mode 100644 index 00000000..41c107ad --- /dev/null +++ b/plugins/xml/xmlentries.ml4 @@ -0,0 +1,40 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ Some fn ] +| [ ] -> [ None ] +END + +(* Print XML and Show XML *) + +VERNAC COMMAND EXTEND Xml +| [ "Print" "XML" filename(fn) global(qid) ] -> [ Xmlcommand.print_ref qid fn ] + +| [ "Show" "XML" filename(fn) "Proof" ] -> [ Xmlcommand.show fn ] +END -- cgit v1.2.3